Nothing
#' Extract or Replace Parts of an Object
#'
#' S3 operators to extract or replace parts of \code{errors} objects.
#'
#' @param x object from which to extract element(s) or in which to replace element(s).
#' @param ... additional arguments to be passed to base methods
#' (see \code{\link[base]{Extract}}).
#' @param value typically an array-like \R object of a similar class as \code{x}.
#' @name Extract.errors
#'
#' @examples
#' x <- set_errors(1:3, 0.1)
#' y <- set_errors(4:6, 0.2)
#' (z <- rbind(x, y))
#' z[2, 2]
#' z[2, 2] <- -1
#' errors(z[[1, 2]]) <- 0.8
#' z[, 2]
#'
#' @export
`[.errors` <- function(x, ...) {
e <- .e(x)
dim(e) <- dim(x)
set_errors(unclass(NextMethod()), as.numeric(e[...]))
}
#' @rdname Extract.errors
#' @export
`[[.errors` <- function(x, ...) {
e <- .e(x)
dim(e) <- dim(x)
set_errors(unclass(NextMethod()), as.numeric(e[[...]]))
}
#' @rdname Extract.errors
#' @export
`[<-.errors` <- function(x, ..., value) {
e <- .e(x)
dim(e) <- dim(x)
e[...] <- .e(value)
set_errors(unclass(NextMethod()), as.numeric(e))
}
#' @rdname Extract.errors
#' @export
`[[<-.errors` <- function(x, ..., value) {
e <- .e(x)
dim(e) <- dim(x)
e[[...]] <- .e(value)
set_errors(unclass(NextMethod()), as.numeric(e))
}
#' Replicate Elements of Vectors and Lists
#'
#' S3 method for \code{errors} objects (see \code{\link{rep}}).
#'
#' @inheritParams base::rep
#'
#' @examples
#' rep(set_errors(1, 0.1), 4)
#'
#' @export
rep.errors <- function(x, ...)
set_errors(unclass(NextMethod()), rep(.e(x), ...))
#' Combine Values into a Vector or List
#'
#' S3 method for \code{errors} objects (see \code{\link{c}}).
#'
#' @inheritParams base::c
#'
#' @examples
#' c(set_errors(1, 0.2), set_errors(7:9, 0.1), 3)
#'
#' @export
c.errors <- function(..., recursive = FALSE)
set_errors(unclass(NextMethod()), c(unlist(sapply(list(...), .e))))
#' Lagged Differences
#'
#' S3 method for \code{errors} objects (see \code{\link{diff}}).
#'
#' @inheritParams base::diff
#'
#' @examples
#' diff(set_errors(1:10, 0.1), 2)
#' diff(set_errors(1:10, 0.1), 2, 2)
#' x <- cumsum(cumsum(set_errors(1:10, 0.1)))
#' diff(x, lag = 2)
#' diff(x, differences = 2)
#'
#' @export
diff.errors <- function(x, lag = 1L, differences = 1L, ...) {
ismat <- is.matrix(x)
xlen <- if (ismat)
dim(x)[1L]
else length(x)
if (length(lag) != 1L || length(differences) > 1L || lag < 1L || differences < 1L)
stop("'lag' and 'differences' must be integers >= 1")
if (lag * differences >= xlen)
return(x[0L])
r <- x
i1 <- -seq_len(lag)
if (ismat)
for (i in seq_len(differences))
r <- r[i1, , drop = FALSE] - r[-nrow(r):-(nrow(r) - lag + 1L), , drop = FALSE]
else for (i in seq_len(differences))
r <- r[i1] - r[-length(r):-(length(r) - lag + 1L)]
r
}
#' Coerce to a Data Frame
#'
#' S3 method for \code{errors} objects (see \code{\link{as.data.frame}}).
#'
#' @inheritParams base::as.data.frame
#'
#' @examples
#' x <- set_errors(1:3, 0.1)
#' y <- set_errors(4:6, 0.2)
#' (z <- cbind(x, y))
#' as.data.frame(z)
#'
#' @export
as.data.frame.errors <- function(x, row.names = NULL, optional = FALSE, ...) {
e <- .e(x)
dim(e) <- dim(x)
xx <- as.data.frame(unclass(x), row.names, optional, ...)
if (!optional && ncol(xx) == 1)
colnames(xx) <- deparse(substitute(x))
df2apply(xx, as.data.frame(e), set_errors)
}
#' Coerce to a List
#'
#' S3 method for \code{errors} objects (see \code{\link{as.list}}).
#'
#' @inheritParams base::as.list
#'
#' @examples
#' x <- set_errors(1:3, 0.1)
#' as.list(x)
#'
#' @export
as.list.errors <- function(x, ...)
Map(set_errors, unclass(x), .e(x))
#' Coerce to a Matrix
#'
#' S3 method for \code{errors} objects (see \code{\link{as.matrix}}).
#'
#' @inheritParams base::matrix
#'
#' @examples
#' as.matrix(set_errors(1:3, 0.1))
#'
#' @export
as.matrix.errors <- function(x, ...)
set_errors(unclass(NextMethod()), .e(x))
#' Matrix Transpose
#'
#' S3 method for \code{errors} objects (see \code{\link{t}}).
#'
#' @inheritParams base::t
#'
#' @examples
#' a <- matrix(1:30, 5, 6)
#' errors(a) <- 1:30
#' t(a)
#'
#' @export
t.errors <- function(x) {
e <- .e(x)
dim(e) <- dim(x)
set_errors(unclass(NextMethod()), as.numeric(t(e)))
}
#' Combine \R Objects by Rows or Columns
#'
#' S3 methods for \code{errors} objects (see \code{\link[base]{cbind}}).
#'
#' @inheritParams base::cbind
#' @name cbind.errors
#'
#' @seealso \code{\link{c.errors}}
#'
#' @examples
#' x <- set_errors(1, 0.1)
#' y <- set_errors(1:3, 0.2)
#' (m <- cbind(x, y)) # the '1' (= shorter vector) is recycled
#' (m <- cbind(m, 8:10)[, c(1, 3, 2)]) # insert a column
#' cbind(y, diag(3)) # vector is subset -> warning
#' cbind(0, rbind(x, y))
#'
#' @export
cbind.errors <- function(..., deparse.level = 1) {
call <- as.character(match.call()[[1]])
allargs <- lapply(list(...), unclass)
nm <- names(as.list(match.call()))
nm <- nm[nm != "" & nm != "deparse.level"]
if (is.null(nm))
names(allargs) <- sapply(substitute(list(...))[-1], deparse)
else names(allargs) <- nm
allerrs <- lapply(list(...), function(x) {
e <- .e(x)
dim(e) <- dim(x)
e
})
set_errors(
do.call(call, c(allargs, deparse.level=deparse.level)),
as.numeric(do.call(call, allerrs))
)
}
#' @rdname cbind.errors
#' @export
rbind.errors <- cbind.errors
#' @export
all.equal.errors <- function(target, current, ...) {
msg <- if (identical(attr(target, "id"), attr(current, "id")))
"id: target and current must have different IDs, otherwise, use 'identical'"
attr(target, "id") <- attr(current, "id") <- NULL
res <- NextMethod()
if (isTRUE(res) && is.null(msg))
TRUE
else if (!isTRUE(res))
c(msg, res)
else msg
}
#' @export
str.errors <- function(object, ...) {
rval <- NULL
file <- textConnection("rval", "w", local = TRUE)
sink(file)
on.exit({ sink(); close(file)})
NextMethod(give.attr=FALSE)
on.exit()
sink()
close(file)
cat(" Errors:", sub(" 'errors' ", "", rval), "\n")
}
#' @export
duplicated.errors <- function(x, incomparables=FALSE, ...) {
dx <- dim(x)
dval <- if (is.null(dx))
NextMethod() else duplicated.array(x, incomparables, ...)
x <- .e(x)
dim(x) <- dx
derr <- if (is.null(dx))
NextMethod() else duplicated.array(x, incomparables, ...)
dval & derr
}
#' @export
anyDuplicated.errors <- function(x, incomparables=FALSE, ...) {
if (any(dup <- duplicated(x, incomparables, ...)))
which(dup)[1] else 0
}
#' @export
unique.errors <- function(x, incomparables=FALSE, MARGIN=1, ...) {
dup <- duplicated(x, incomparables, ...)
if (is.null(dim(x)))
return(x[!dup])
# for matrices and arrays
args <- rep(alist(a = ), length(dim(x)))
names(args) <- NULL
args[[MARGIN]] <- !dup
do.call("[", c(list(x), args, list(drop = FALSE)))
}
#' @export
na.omit.errors <- function(object, ...) {
object[is.na(errors(object))] <- NA
NextMethod()
}
#' @export
na.fail.errors <- na.omit.errors
#' @export
na.exclude.errors <- na.omit.errors
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.