Nothing
#' Checks if a value exists / does not exist in each row (column) of a matrix
#'
#' Checks if a value exists / does not exist in each row (column) of a matrix.
#'
#' These functions takes either a matrix or a vector as input. If a vector,
#' then argument \code{dim.} must be specified and fulfill \code{prod(dim.) ==
#' length(x)}. The result will be identical to the results obtained when
#' passing \code{matrix(x, nrow = dim.[1L], ncol = dim.[2L])}, but avoids
#' having to temporarily create/allocate a matrix, if only such is needed
#' only for these calculations.
#'
#' @param x An NxK \code{\link[base]{matrix}} or, if \code{dim.} is specified,
#' an N * K \code{\link[base]{vector}}.
#'
#' @param idxs A \code{\link[base]{vector}} indicating subset of elements to
#' operate over. If \code{\link[base]{NULL}}, no subsetting is done.
#'
#' @param rows A \code{\link[base]{vector}} indicating subset of rows to
#' operate over. If \code{\link[base]{NULL}}, no subsetting is done.
#'
#' @param cols A \code{\link[base]{vector}} indicating subset of columns to
#' operate over. If \code{\link[base]{NULL}}, no subsetting is done.
#'
#' @param value A value to search for.
#'
#' @param na.rm If \code{\link[base:logical]{TRUE}}, missing values are
#' excluded.
#'
#' @param dim. An \code{\link[base]{integer}} \code{\link[base]{vector}} of
#' length two specifying the dimension of \code{x}, also when not a
#' \code{\link[base]{matrix}}. \emph{Comment:} The reason for this argument
#' being named with a period at the end is purely technical (we get a run-time
#' error if we try to name it \code{dim}).
#'
#' @param ... Not used.
#'
#' @param useNames If \code{\link[base:logical]{TRUE}} (default), names
#' attributes of the result are set, otherwise not.
#'
#' @return \code{rowAlls()} (\code{colAlls()}) returns an
#' \code{\link[base]{logical}} \code{\link[base]{vector}} of length N (K).
#' Analogously for \code{rowAnys()} (\code{rowAlls()}).
#'
#' @section Logical \code{value}:
#' When \code{value} is logical, the result is as if the function is applied
#' on \code{as.logical(x)}. More specifically, if \code{x} is numeric, then
#' all zeros are treated as \code{FALSE}, non-zero values as \code{TRUE},
#' and all missing values as \code{NA}.
#'
#' @example incl/rowAlls.R
#'
#' @author Henrik Bengtsson
#' @seealso rowCounts
#' @keywords array logic iteration univar
#' @export
rowAlls <- function(x, rows = NULL, cols = NULL, value = TRUE,
na.rm = FALSE, dim. = dim(x), ..., useNames = TRUE) {
if (is.numeric(x) && is.logical(value) && !is.na(value)) {
if (is.na(useNames)) deprecatedUseNamesNA()
has_nas <- TRUE
if (isTRUE(value)) {
counts <- .Call(C_rowCounts, x, dim., rows, cols, FALSE, 1L, na.rm, has_nas, useNames)
res <- (counts == 0L)
} else {
counts <- .Call(C_rowCounts, x, dim., rows, cols, FALSE, 0L, na.rm, has_nas, useNames)
res <- (counts == 1L)
}
} else if (is.numeric(x) || is.logical(x)) {
has_nas <- TRUE
counts <- .Call(C_rowCounts, x, dim., rows, cols, value, 0L, na.rm, has_nas, FALSE)
res <- as.logical(counts)
# Update names attribute?
if (!is.na(useNames)) {
if (useNames) {
names <- rownames(x)
if (!is.null(names)) {
if (!is.null(rows)) {
names <- names[rows]
# Zero-length attribute? Keep behavior same as base R function
if (length(names) == 0L) names <- NULL
}
names(res) <- names
}
} else {
names(res) <- NULL
}
} else {
deprecatedUseNamesNA()
}
} else {
if (!identical(dim(x), dim.)) dim(x) <- dim.
if (!is.matrix(x)) defunctShouldBeMatrixOrDim(x)
# Apply subset
if (!is.null(rows) && !is.null(cols)) x <- x[rows, cols, drop = FALSE]
else if (!is.null(rows)) x <- x[rows, , drop = FALSE]
else if (!is.null(cols)) x <- x[, cols, drop = FALSE]
dim. <- dim(x)
if (is.na(value)) {
return(rowAlls(is.na(x), na.rm = na.rm, dim. = dim., ..., useNames = useNames))
} else {
z <- (x == value)
dim <- dim(x) # for 0xN and Mx0 cases; needed in R (< 3.4.0)
if (!identical(dim(z), as.integer(dim))) dim(z) <- dim
if (isTRUE(useNames)) dimnames(z) <- dimnames(x)
return(rowAlls(z, na.rm = na.rm, dim. = dim., ..., useNames = useNames))
}
}
res
}
#' @rdname rowAlls
#' @export
colAlls <- function(x, rows = NULL, cols = NULL, value = TRUE,
na.rm = FALSE, dim. = dim(x), ..., useNames = TRUE) {
if (is.numeric(x) && is.logical(value) && !is.na(value)) {
if (is.na(useNames)) deprecatedUseNamesNA()
has_nas <- TRUE
if (isTRUE(value)) {
counts <- .Call(C_colCounts, x, dim., rows, cols, FALSE, 1L, na.rm, has_nas, useNames)
res <- (counts == 0L)
} else {
counts <- .Call(C_colCounts, x, dim., rows, cols, FALSE, 0L, na.rm, has_nas, useNames)
res <- (counts == 1L)
}
} else if (is.numeric(x) || is.logical(x)) {
has_nas <- TRUE
counts <- .Call(C_colCounts, x, dim., rows, cols, value, 0L, na.rm, has_nas, FALSE)
res <- as.logical(counts)
# Update names attribute?
if (!is.na(useNames)) {
if (useNames) {
names <- colnames(x)
if (!is.null(names)) {
if (!is.null(cols)) {
names <- names[cols]
# Zero-length attribute? Keep behavior same as base R function
if (length(names) == 0L) names <- NULL
}
names(res) <- names
}
} else {
names(res) <- NULL
}
}
} else {
if (!identical(dim(x), dim.)) dim(x) <- dim.
if (!is.matrix(x)) defunctShouldBeMatrixOrDim(x)
# Apply subset
if (!is.null(rows) && !is.null(cols)) x <- x[rows, cols, drop = FALSE]
else if (!is.null(rows)) x <- x[rows, , drop = FALSE]
else if (!is.null(cols)) x <- x[, cols, drop = FALSE]
dim. <- dim(x)
if (is.na(value)) {
return(colAlls(is.na(x), na.rm = na.rm, dim. = dim., ..., useNames = useNames))
} else {
z <- (x == value)
dim <- dim(x) # for 0xN and Mx0 cases; needed in R (< 3.4.0)
if (!identical(dim(z), as.integer(dim))) dim(z) <- dim
if (isTRUE(useNames)) dimnames(z) <- dimnames(x)
return(colAlls(z, na.rm = na.rm, dim. = dim., ..., useNames = useNames))
}
}
res
}
#' @rdname rowAlls
#' @export
allValue <- function(x, idxs = NULL, value = TRUE, na.rm = FALSE, ...) {
if (is.numeric(x) && is.logical(value) && !is.na(value)) {
has_nas <- TRUE
if (isTRUE(value)) {
counts <- .Call(C_count, x, idxs, FALSE, 1L, na.rm, has_nas)
(counts == 0L)
} else {
counts <- .Call(C_count, x, idxs, FALSE, 0L, na.rm, has_nas)
(counts == 1L)
}
} else if (is.numeric(x) || is.logical(x)) {
has_nas <- TRUE
counts <- .Call(C_count, x, idxs, value, 0L, na.rm, has_nas)
as.logical(counts)
} else {
# Apply subset
if (!is.null(idxs)) x <- x[idxs]
if (is.na(value)) {
allValue(is.na(x), na.rm = na.rm, ...)
} else {
allValue(x == value, na.rm = na.rm, ...)
}
}
}
#' @rdname rowAlls
#' @export
rowAnys <- function(x, rows = NULL, cols = NULL, value = TRUE,
na.rm = FALSE, dim. = dim(x), ..., useNames = TRUE) {
if (is.numeric(x) && is.logical(value) && !is.na(value)) {
if (is.na(useNames)) deprecatedUseNamesNA()
has_nas <- TRUE
if (isTRUE(value)) {
counts <- .Call(C_rowCounts, x, dim., rows, cols, FALSE, 0L, na.rm, has_nas, useNames)
res <- (counts == 0L)
} else {
counts <- .Call(C_rowCounts, x, dim., rows, cols, FALSE, 1L, na.rm, has_nas, useNames)
res <- (counts == 1L)
}
} else if (is.numeric(x) || is.logical(x)) {
has_nas <- TRUE
counts <- .Call(C_rowCounts, x, dim., rows, cols, value, 1L, na.rm, has_nas, useNames)
res <- as.logical(counts)
# Preserve names attribute
names <- names(counts)
res <- as.logical(counts)
names(res) <- names
} else {
if (!identical(dim(x), dim.)) dim(x) <- dim.
if (!is.matrix(x)) defunctShouldBeMatrixOrDim(x)
# Apply subset
if (!is.null(rows) && !is.null(cols)) x <- x[rows, cols, drop = FALSE]
else if (!is.null(rows)) x <- x[rows, , drop = FALSE]
else if (!is.null(cols)) x <- x[, cols, drop = FALSE]
dim. <- dim(x)
if (is.na(value)) {
return(rowAnys(is.na(x), na.rm = na.rm, dim. = dim., ..., useNames = useNames))
} else {
z <- (x == value)
dim <- dim(x) # for 0xN and Mx0 cases; needed in R (< 3.4.0)
if (!identical(dim(z), as.integer(dim))) dim(z) <- dim
if (isTRUE(useNames)) dimnames(z) <- dimnames(x)
return(rowAnys(z, na.rm = na.rm, dim. = dim., ..., useNames = useNames))
}
}
res
}
#' @rdname rowAlls
#' @export
colAnys <- function(x, rows = NULL, cols = NULL, value = TRUE,
na.rm = FALSE, dim. = dim(x), ..., useNames = TRUE) {
if (is.numeric(x) && is.logical(value) && !is.na(value)) {
if (is.na(useNames)) deprecatedUseNamesNA()
has_nas <- TRUE
if (isTRUE(value)) {
counts <- .Call(C_colCounts, x, dim., rows, cols, FALSE, 0L, na.rm, has_nas, useNames)
res <- (counts == 0L)
} else {
counts <- .Call(C_colCounts, x, dim., rows, cols, FALSE, 1L, na.rm, has_nas, useNames)
res <- (counts == 1L)
}
} else if (is.numeric(x) || is.logical(x)) {
has_nas <- TRUE
counts <- .Call(C_colCounts, x, dim., rows, cols, value, 1L, na.rm, has_nas, useNames)
# Preserve names attribute
names <- names(counts)
res <- as.logical(counts)
names(res) <- names
} else {
if (!identical(dim(x), dim.)) dim(x) <- dim.
if (!is.matrix(x)) defunctShouldBeMatrixOrDim(x)
# Apply subset
if (!is.null(rows) && !is.null(cols)) x <- x[rows, cols, drop = FALSE]
else if (!is.null(rows)) x <- x[rows, , drop = FALSE]
else if (!is.null(cols)) x <- x[, cols, drop = FALSE]
dim. <- dim(x)
if (is.na(value)) {
return(colAnys(is.na(x), na.rm = na.rm, dim. = dim., ..., useNames = useNames))
} else {
z <- (x == value)
dim <- dim(x) # for 0xN and Mx0 cases; needed in R (< 3.4.0)
if (!identical(dim(z), as.integer(dim))) dim(z) <- dim
if (isTRUE(useNames)) dimnames(z) <- dimnames(x)
return(colAnys(z, na.rm = na.rm, dim. = dim., ..., useNames = useNames))
}
}
res
}
#' @rdname rowAlls
#' @export
anyValue <- function(x, idxs = NULL, value = TRUE, na.rm = FALSE, ...) {
if (is.numeric(x) && is.logical(value) && !is.na(value)) {
has_nas <- TRUE
if (isTRUE(value)) {
counts <- .Call(C_count, x, idxs, FALSE, 0L, na.rm, has_nas)
(counts == 0L)
} else {
counts <- .Call(C_count, x, idxs, FALSE, 1L, na.rm, has_nas)
(counts == 1L)
}
} else if (is.numeric(x) || is.logical(x)) {
has_nas <- TRUE
counts <- .Call(C_count, x, idxs, value, 1L, na.rm, has_nas)
as.logical(counts)
} else {
# Apply subset
if (!is.null(idxs)) x <- x[idxs]
if (is.na(value)) {
anyValue(is.na(x), na.rm = na.rm, ...)
} else {
anyValue(x == value, na.rm = na.rm, ...)
}
}
}
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.