Nothing
#' Determine which edits contain which variable(s)
#'
#' For an \code{\link{editmatrix}}, variables with coefficients smaller than
#' \code{tol} are considered not to be contained in an edit.
#'
#' @param E \code{\link{editarray}}, \code{\link{editmatrix}}, \code{\link{editset}}, or \code{matrix}
#' @param var \code{character}, names of a categorical variables in \code{E}. If var=NULL, all variables are treated.
#' @param ... arguments to be passed to other methods
#' @return \code{logical} vector of length nrow(E), TRUE for edits containing \code{var}
#' @export
contains <- function(E,var=NULL,...){
if (nedits(E)==0){
if ( is.null(var) ) var <- getVars(E)
return(
array(
logical(0),
dim=c(0,length(var)),
dimnames=list(edit=NULL,variable=var)
)
)
}
UseMethod('contains')
}
#' matrix method for contains
#'
#' @method contains matrix
#' @rdname contains
#' @export
#' @keywords internal
contains.matrix <- function(E, var=NULL, tol=sqrt(.Machine$double.eps),...){
if ( is.null(var) && !is.null(colnames(E)) ) var <- colnames(E)
if ( is.null(var) ) var <- 1:ncol(E)
u <- abs(E[,var,drop=FALSE]) > tol
dimnames(u) <- dimnames(E[,var,drop=FALSE])
u
}
#' editmatrix method for contains
#'
#' @method contains editmatrix
#' @rdname contains
#' @param tol tolerance to check zero-entries
#' @export
#' @keywords internal
contains.editmatrix <- function(E, var=NULL, tol=sqrt(.Machine$double.eps), ...){
A <- getA(E)
vars <- getVars.editmatrix(E)
if (is.null(var)){
var <- vars
} else {
stopifnot(all(var %in% vars))
}
if ( length(var) > 0 ){
u <- abs(A[,var,drop=FALSE]) > tol
} else {
u <- array(FALSE,dim=c(nrow(A),0))
}
dimnames(u) <- list(edit=rownames(E),variable=var)
u
}
#' contains method for editarray
#'
#' @method contains editarray
#' @rdname contains
#' @export
#' @keywords internal
contains.editarray <- function(E,var=NULL,...){
if ( !is.editarray(E) ) stop("Argument not of class editarray")
ind <- getInd(E)
if ( is.null(var)) var <- names(ind)
contains.boolmat(getArr(E),var = var, ind = ind)
}
#' Determine if a boolean matrix contains \code{var}
#'
#' @param E array
#' @param ind index
#' @param var variable name
#' @export
#' @keywords internal
contains.boolmat <- function(E, var=NULL, ind, ...){
ind <- ind[var]
v <- vapply(ind, function(ii) rowSums(E[,ii,drop=FALSE]) < length(ii), FUN.VALUE=logical(nrow(E)))
if ( is.vector(v) ){
v <- array(v,dim=c(1,length(v)), dimnames=list(edit=rownames(E),var=names(v)))
} else {
dimnames(v) <- list(edit=rownames(E),variable=colnames(v))
}
v
}
#' contains method for cateditmatrix
#'
#' @rdname contains
#' @export
#' @keywords internal
contains.cateditmatrix <- function(E, var=NULL, ...){
m <- contains.editmatrix(E)
ind <- indFromArray(m,sep=":")
vapply(ind, function(ii) rowSums(m[,ii,drop=FALSE])>0, FUN.VALUE=logical(nrow(m)) )
}
#' contains method for editset
#'
#' @method contains editset
#' @rdname contains
#' @export
#' @keywords internal
contains.editset <- function(E,var=NULL,...){
if ( is.null(var) ) var <- getVars(E)
nedits <- nrow(E$num) + nrow(E$mixcat)
# create a boolean array holding the answer
T <- array(FALSE,
dim=c(nedits,length(var)),
dimnames=list(
edits=c(
rownames(E$num),
rownames(E$mixcat)
),
variables=var
)
)
# contains for numerical variables
numvar <- var[var %in% getVars(E$num)]
nnum <- nrow(E$num)
ivr <- var %in% numvar
if ( any(ivr) && length(numvar) > 0 && nnum > 0 ){
T[1:nrow(E$num),numvar] <- contains(E$num, var[ivr])
}
# contains for categorical variables in conditional edits (mix)
nmix <- nrow(E$mixcat)
if (nmix>0){
imix <- (nnum+1):(nnum+nmix)
catvar <- var[var %in% getVars(E,type='cat')]
if (length(catvar) > 0){
T[imix,catvar] <- contains(E$mixcat, catvar)
}
# contains for numerical variables in mixed edits
vnm <- var[var %in% getVars(E$mixnum)]
if ( length(vnm) > 0 ){
vmc <- getVars(E$mixcat)
emn <- rownames(E$mixnum)
vmc <- vmc[vmc %in% emn]
vmc <- vmc[match(emn,vmc)]
X <- contains(E$mixcat)[,vmc,drop=FALSE]
Y <- contains(E$mixnum,vnm)
T[imix,vnm] <- (X%*%Y) > 0
}
}
T
}
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.