File: assertions-scalar.R

package info (click to toggle)
r-cran-assertthat 0.2.1-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 220 kB
  • sloc: sh: 9; makefile: 2
file content (93 lines) | stat: -rw-r--r-- 2,199 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
#' @include on-failure.r
NULL

#' Assert input is a scalar.
#' 
#' \code{is.scalar} provides a generic method for checking input is a scalar.
#' \code{is.string}, \code{is.flag}, \code{is.number} and \code{is.count}
#' provide tests for specific types.
#' 
#' @family assertions
#' @param x object to test
#' @name scalar
#' @aliases NULL
NULL

#' @rdname scalar
#' @export
#' @examples
#' # Generic check for scalars
#' see_if(is.scalar("a"))
#' see_if(is.scalar(1:10))
#' 
is.scalar <- function(x) {
  length(x) == 1L
}
on_failure(is.scalar) <- function(call, env) {
  type <- eval(call$type, env)
  paste0(deparse(call$x), " is not a scalar.")
}


#' @rdname scalar
#' @export
#' @examples
#' # string = scalar character vector
#' see_if(is.string(1:3))
#' see_if(is.string(c("a", "b")))
#' see_if(is.string("x"))
#' 
is.string <- function(x) is.character(x) && length(x) == 1
on_failure(is.string) <- function(call, env) {
  paste0(deparse(call$x), " is not a string (a length one character vector).")
}


#' @rdname scalar
#' @export
#' @examples
#' # number = scalar numeric/integer vector
#' see_if(is.number(1:3))
#' see_if(is.number(1.5))
#' 
is.number <- function(x) is.numeric(x) && length(x) == 1
on_failure(is.number) <- function(call, env) {
  paste0(deparse(call$x), " is not a number (a length one numeric vector).")
}

#' @rdname scalar
#' @export
#' @examples
#' # flag = scalar logical vector
#' see_if(is.flag(1:3))
#' see_if(is.flag("a"))
#' see_if(is.flag(c(FALSE, FALSE, TRUE)))
#' see_if(is.flag(FALSE))
#' 
is.flag <- function(x) is.logical(x) && length(x) == 1
on_failure(is.flag) <- function(call, env) {
  paste0(deparse(call$x), " is not a flag (a length one logical vector).")
}


#' @rdname scalar
#' @export
#' @examples
#' # count = scalar positive integer
#' see_if(is.count("a"))
#' see_if(is.count(-1))
#' see_if(is.count(1:5))
#' see_if(is.count(1.5))
#' see_if(is.count(1))
#' 
is.count <- function(x) {
  if (length(x) != 1) return(FALSE)
  if (!is.integerish(x)) return(FALSE)
  
  # is.na() to handle NA_integer_
  x > 0 && !is.na(x)
}
on_failure(is.count) <- function(call, env) {
  paste0(deparse(call$x), " is not a count (a single positive integer)")
}