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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
#' Get or set the \code{"cause"} attribute
#'
#' Gets or sets the \code{"cause"} (of failure) attribute of a variable.
#'
#' @param x Any variable.
#' @param value Passed to \code{gettextf} and stored in the \code{"cause"}
#' attribute.
#' @return The get method returns the \code{"cause"} attribute.
#' @seealso \code{\link{set_cause}}
#' @examples
#' # Scalar case
#' yn <- is_identical_to_true(FALSE)
#' cause(yn)
#'
#' # Vector case
#' yn <- is_true(c(TRUE, FALSE, NA))
#' cause(yn)
#' @export
cause <- function(x)
{
y <- attr(x, "cause")
if(is.null(y))
{
return(noquote(character(length(x))))
}
y
}
#' @rdname cause
#' @export
`cause<-` <- function(x, value)
{
# Can't use is_scalar here due to dependency on this
if(length(value) != 1 && length(value) != length(x))
{
stop(
sprintf(
"The length of value should be 1 or the length of x (%d) but is %d.",
length(x),
length(value)
)
)
}
attr(x, "cause") <- noquote(as.character(value))
x
}
#' Set a cause and return the input
#'
#' Sets the cause attribute of an object and returns that object.
#' @param x A variable.
#' @param false_value A character vector to set the cause to, where \code{x} is
#' \code{FALSE}.
#' @param missing_value A character vector to set the cause to, where \code{x} is
#' \code{NA}.
#' @details If \code{x} is \code{TRUE} everywhere, this returns the input
#' without setting a cause. Otherwise, the cause is an empty string where
#' \code{x} is \code{TRUE}, \code{false_value} where it is \code{FALSE}, and
#' \code{missing_value} where it is \code{NA}.
#' @return \code{x}, with a new cause attribute.
#' @seealso \code{\link{cause}}, \code{\link[stats]{setNames}}
#' @export
set_cause <- function(x, false_value, missing_value = "missing")
{
if(!anyNA(x) && all(x, na.rm = TRUE)) # fast version of all(!is.na(x) & x)
{
return(x)
}
is_na_x <- is.na(x)
len_x <- length(x)
# TRUEs
cause_value <- character(len_x)
# NAs
if(length(missing_value) == 1)
{
cause_value[is_na_x] <- missing_value
} else
{
missing_value <- rep_len(missing_value, len_x)
cause_value[is_na_x] <- missing_value[is_na_x]
}
# FALSEs
false_index <- !(x | is_na_x) # more efficient to calc than !x & !is_na_x
if(length(false_value) == 1)
{
cause_value[false_index] <- false_value
} else
{
false_value <- rep_len(false_value, len_x)
cause_value[false_index] <- false_value[false_index]
}
cause(x) <- cause_value
class(x) <- c("vector_with_cause", "logical")
x
}
#' @rdname print.vector_with_cause
#' @method print scalar_with_cause
#' @export
print.scalar_with_cause <- function(x, ...)
{
if(length(x) != 1L)
{
stop("x is malformed; it should have length 1.", domain = NA)
}
print(x[1])
cat("Cause of failure: ", cause(x), "\n")
}
#' Print methods for objects with a cause attribute
#'
#' Prints objects of class \code{scalar_with_cause} and
#' \code{vector_with_cause}.
#' @param x an object of class \code{scalar_with_cause} or
#' \code{vector_with_cause}.
#' @param na_ignore A logical value. If \code{FALSE}, \code{NA} values
#' are printed; otherwise they do not. Like \code{na.rm} in many
#' stats package functions, except that the position of the failing
#' values does not change.
#' @param n_to_show A natural number. The maximum number of failures
#' to show.
#' @param ... Currently unused.
#' @method print vector_with_cause
#' @importFrom utils head
#' @export
print.vector_with_cause <- function(x, na_ignore = FALSE, n_to_show = 10, ...)
{
cause_x <- cause(x)
names_x <- names(x)
if(is.null(names_x))
{
names_x <- character(length(x))
}
x <- strip_attributes(x)
ok <- if(na_ignore)
{
# ok can be TRUE or NA; FALSE is bad
x | is.na(x)
} else
{
# ok can be TRUE; FALSE or NA is bad
x & !is.na(x)
}
# Append first few failure values and positions to the error message.
fail_index <- which(!ok)
n <- length(fail_index)
fail_index <- head(fail_index, n_to_show)
failures <- data.frame(
Position = fail_index,
Value = truncate(names_x[fail_index]),
Cause = unclass(cause_x[fail_index]), # See bug 15997
row.names = seq_along(fail_index)
)
# Slightly convoluted way of creating message done to ensure that xgettext
# creates all the translation strings
msg_showing_first <- if(nrow(failures) < n)
{
paste0(
" ",
gettextf(
"(showing the first %d)",
nrow(failures),
domain = "R-assertive.base"
)
)
} else ""
msg_n_failures <- ngettext(
n,
"There was %d failure%s:\n",
"There were %d failures%s:\n",
domain = "R-assertive.base"
)
cat(enc2utf8(sprintf(msg_n_failures, n, msg_showing_first)))
print(failures)
}
|
