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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
#' Alternative version of is
#'
#' If a function named \code{is.class} exists, call \code{is.class(x)}.
#' If not, call \code{is(x, class)}.
#' @param x Input to check.
#' @param class Target class that \code{x} maybe belong to.
#' @param .xname Not intended to be used directly.
#' @return \code{TRUE} if x belongs to the class and \code{FALSE}
#' otherwise.
#' @seealso \code{\link[methods]{is}}, and
#' \code{\link[assertive.types]{assert_is_all_of}} for the corresponding assert fns.
#' @examples
#' is2(1:5, "character")
#' is2(matrix(1:5), "character")
#' is2(1:5, c("character", "list", "numeric"))
#' is2(mean, c("function", "data.frame"))
#' @importFrom methods is
#' @export
is2 <- function(x, class, .xname = get_name_in_parent(x))
{
# Can't use is_empty in next line because that function calls this one.
if(length(class) == 0L) stop("You must provide a class.")
if(length(class) > 1L)
{
return(
set_cause(
bapply(class, function(cl) is2(x, cl, "")),
sprintf("%s is not '%s'", type_description(x), class)
)
)
}
ok <- tryCatch(
{
is.class <- match.fun(paste0("is.", class))
is.class(x)
},
error = function(e)
{
is(x, class)
}
)
if(!ok)
{
return(
false(
"%s is not of class '%s'; it has %s.",
.xname,
class,
type_description(x)
)
)
}
TRUE
}
#' Coerce variable to a different class
#'
#' Coerce the input to a different class, with a warning. More reliable then
#' \code{\link[methods]{as}}, and supports coercion to multiple classes.
#'
#' @param x Input to coerce.
#' @param target_class The desired class of x. Multiple values allowed (see
#' note).
#' @param .xname Not intended to be used directly.
#' @return The input \code{x} after attempted coercion to the target class.
#' @note If x does not already have the target class, a warning is given
#' before coercion.
#' The function will try and convert the \code{x} to each of the classes given
#' in \code{target_class}, in order, until it succeeds or runs out of classes
#' to try. It will first try and convert \code{x} using a dedicated
#' \code{as.target_class} function if that exists. If it does not exist, or
#' throws an error then \code{coerce_to} will try to use
#' \code{as(x, target_class)}.
#' @seealso \code{\link[methods]{is}} and \code{\link[methods]{as}}.
#' @examples
#' # Numbers can be coerced to characters but not to calls.
#' dont_stop(coerce_to(1:5, c("call", "character")))
#' @importFrom methods as
#' @export
coerce_to <- function(x, target_class, .xname = get_name_in_parent(x))
{
# Can't use is_empty in next line because that function calls this one.
if(length(target_class) == 0L)
{
stop("You must provide a class.")
}
if(!is.character(target_class))
{
stop("target_class should be a character vector.")
}
for(this_class in target_class)
{
if(!is2(x, this_class))
{
warning(
sprintf(
"Coercing %s to class %s.",
.xname,
sQuote(this_class)
),
call. = FALSE
)
}
tryCatch(
{
as.this_class <- match.fun(paste0("as.", this_class))
return(as.this_class(x))
},
error = function(e)
{
# as.this_class doesn't exist; try as(, "this_class") instead
tryCatch(
return(as(x, this_class)),
error = function(e)
{
# Can't coerce to this class; warn and move to next class
warning(
sprintf(
"%s cannot be coerced to type %s.",
.xname,
sQuote(this_class)
),
call. = FALSE
)
}
)
}
)
}
# Nothing worked; throw an error
stop(
sprintf(
"%s cannot be coerced to any of these types: %s.",
.xname,
toString(sQuote(target_class))
)
)
}
#' Describe the type of object
#'
#' Get the class or mode (for arrays).
#' @param x A variable.
#' @return A string.
#' @noRd
type_description <- function(x)
{
if(is.array(x))
{
sprintf(sprintf("class '%s %s'", class(x[FALSE]), toString(class(x))))
} else if(is.function(x))
{
sprintf(sprintf("class '%s %s'", typeof(x), toString(class(x))))
} else if(isS4(x))
{
sprintf(sprintf("S4 class '%s'", toString(class(x))))
} else
{
sprintf("class '%s'", toString(class(x)))
}
}
|
