Nothing
# Evaluate an 'disjuntion of conjunctions'
# condstr string in 'visible' syntax with 'standard boolean' format, i.e. a disjunction of conjunctions
# sc 'scores' matrix
qcond_bool <- function(condstr, sc){
if (inherits(sc, "cti")) sc <- sc$scores
spl <- strsplit(condstr, "+", fixed = TRUE)
conjs <- as.character(unique(unlist(spl, use.names = FALSE, recursive = FALSE)))
splc <- strsplit(conjs, "*", fixed = TRUE)
# Check for presence of the factors in the data
usplc <- unlist(splc, recursive = FALSE, use.names = FALSE)
nms <- colnames(sc)
if (!all(usplc %in% nms))
stop("Invalid factor value(s) in condition: ", paste0(setdiff(usplc, nms), collapse = ","),
call. = FALSE)
factors <- unique(toupper(usplc))
factor_ok <- !is.na(match(factors, nms))
if (any(!factor_ok)) stop("Invalid condition specified.", call. = FALSE)
n <- NROW(sc)
ms_conjs <- matrix(vapply(splc, function(x) rowMins(sc[, x, drop = FALSE]),
numeric(n)),
nrow = n, ncol = length(splc))
out <- matrix(vapply(spl,
function(x) rowMaxs(ms_conjs[, match(x, table = conjs), drop = FALSE]),
numeric(n)),
nrow = n, ncol = length(condstr))
colnames(out) <- condstr
out
}
# ===== Handling of 'asf' strings =====
# Evaluate an 'atomic condition' seperated with <-> or ->
# condstr string in 'visible' syntax with 'asf' format
# sc 'scores' matrix
# value: array of dimension nrow(sc) x 2 x length(condstr),
# with attributes 'condition' and 'response'
qcond_asf <- function(condstr, sc, force.bool = FALSE){
if (inherits(sc, "cti")) sc <- sc$scores
l <- length(condstr)
n <- nrow(sc)
lr <- strsplit(condstr, "<*->")
out <- qcond_bool(as.character(unlist(lr, recursive = FALSE, use.names = FALSE)), sc)
if (force.bool){
dim(out) <- c(n, 2, l)
equiv <- grepl("<->", condstr, fixed = TRUE)
out1 <- numeric(n*l)
dim(out1) <- c(n, l)
if (any(equiv)) out1[, equiv] <- out[, 1, equiv] == out[, 2, equiv]
if (any(!equiv)) out1[, !equiv] <- out[, 1, !equiv] <= out[, 2, !equiv]
colnames(out1) <- condstr
return(out1)
}
response <- colnames(out)[1:l * 2]
dim(out) <- c(n, 2, l)
structure(out,
condition = condstr,
response = response)
}
# quick version of condTbl for 'atomic condition'
# parametes: as above
# Value: condTbl with columns outcome, condition, con, cov
qcondTbl_asf <- function(condstr, cti, asf.selection = "none", conCovDef = 1:2, ...){
stopifnot(asf.selection %in% c("none", "cs", "fs"))
if (cti$type == "fs"){
cutoff <- cti$fsInfo$cutoff
border <- cti$fsInfo$border
} else {
cutoff <- 0.5
border <- "up"
}
cond <- qcond_asf(condstr, cti$scores)
if (asf.selection != "none"){
# select condition where outcome varies within concordant cases:
varying <- apply(cond, 3, function(tbl){
C_varies(tbl[, 1], tbl[, 2], asfSelection = asf.selection,
cutoff = cutoff, border = border)
}, simplify = TRUE)
if (!any(varying)) return(emptyCondTbl("stdAtomic", measures = conCovDef))
cond <- structure(cond[, , varying, drop = FALSE],
condition = attr(cond, "condition")[varying],
response = attr(cond, "response")[varying])
}
cond2condTbl(cond, cti$freq, conCovDef = conCovDef, ...)
}
# Take an expanded 'qcond_asf' array and return the corresponding condTbl
# cond output from qcond_asf or qcond_csf
cond2condTbl <- function(cond, freqs, conCovDef = 1:2, imposeLength2 = TRUE){
coco <- conCovFromArray(cond, freqs, def = conCovDef,
imposeLength2 = imposeLength2) # !detailed
if (imposeLength2){
out <- structure(
data.frame(outcome = structure(attr(cond, "response"),
class = c("outcomeString", "character")),
condition = structure(attr(cond, "condition"),
class = c("stdAtomic", "character")),
con = coco[1, ], cov = coco[2, ],
row.names = NULL, stringsAsFactors = FALSE),
measures = if (imposeLength2) resolveMeasures(conCovDef),
class = c("condTbl", "data.frame"))
} else {
meas <- resolveMeasures(conCovDef, imposeLength2 = FALSE)
colnames(coco) <- make.names(meas$shortNames)
out <- structure(
data.frame(outcome = structure(attr(cond, "response"),
class = c("outcomeString", "character")),
condition = structure(attr(cond, "condition"),
class = c("stdAtomic", "character")),
coco, row.names = NULL, stringsAsFactors = FALSE),
class = c("condTbl", "data.frame"))
}
out
}
# ===== Handling of 'csf' strings =====
# Evaluate an 'complex condition'
# condstr string in 'visible' syntax with 'csf' format
# sc 'scores' matrix
# force.bool
# freqs if (force.bool & !flat) and freqs is supplied, an attribute conCov is attached
# Value:
# - if flat = TRUE: Returns an array resulting from applying qcond_asf() to the (flattended)
# vector of all asf present in 'condstr', with additional attribute csflengths
# - if flat = FALSE: Returns a list with a separate object as returned by qcond_asf() for each csf
qcond_csf <- function(condstr, sc, conCovDef = NULL, freqs = NULL,
flat = FALSE, force.bool = FALSE){
if (inherits(sc, "cti")) sc <- sc$scores
n <- nrow(sc)
asfs <- extract_asf(condstr)
lengths <- lengths(asfs)
unlasfs <- as.character(unlist(asfs, use.names = FALSE, recursive = FALSE))
varray <- qcond_asf(unlasfs, sc, force.bool = force.bool)
if (force.bool){
relisted <- if (length(varray)){
relist1(as.vector(varray), lengths*n)
} else {
list()
}
out <- matrix(vapply(
relisted,
function(x){ rowMins(matrix(x, nrow = n)) },
numeric(n)), nrow = nrow(sc))
colnames(out) <- condstr
return(out)
} else if (!flat & !is.null(freqs) & !is.null(conCovDef)){
ctbl <- cond2condTbl(varray, freqs, conCovDef = conCovDef)
asfCons <- C_relist_Num(ctbl$con, lengths)
asfCovs<- C_relist_Num(ctbl$cov, lengths)
conCov <- data.frame(
con = vapply(asfCons, min, numeric(1)),
cov = vapply(asfCovs, min, numeric(1)))
conCov$asfCons <- asfCons
conCov$asfCovs <- asfCovs
conCov$outcome <- C_mconcat(C_relist_Char(ctbl$outcome, lengths), sep = ",")
}
if (flat){
return(structure(varray, csflengths = lengths))
}
gr <- rep(seq_along(lengths), lengths*2*n)
out <- lapply(split(as.vector(varray), gr),
function(x){
array(x, c(n, 2, length(x)/(2*n)))
})
names(out) <- condstr
if (exists("conCov", inherits = FALSE))
attr(out, "conCov") <- conCov
out
}
# Quick version of condTbl for 'complex condition'
# parametes: as above
# Value: condTbl with columns outcome, condition, con, cov
qcondTbl_csf <- function(condstr, sc, freqs, conCovDef, imposeLength2 = TRUE){
qc <- qcond_csf(condstr, sc, flat = TRUE)
ctbl <- cond2condTbl(qc, freqs, conCovDef = conCovDef, imposeLength2 = imposeLength2)
lengths <- attr(qc, "csflengths")
gr <- rep(seq_along(lengths), lengths)
conCov <- vapply(ctbl[-(1:2)], gmins, gr, FUN.VALUE = numeric(gr[[length(gr)]]))
if (!is.matrix(conCov))
conCov <- matrix(conCov, nrow = 1, dimnames = list(NULL, names(conCov)))
data.frame(
outcome = C_mconcat(split.default(ctbl$outcome, gr), sep = ","),
condition = condstr,
conCov,
stringsAsFactors = FALSE
)
}
# # Grouped version of condTbl for csf-strings
# groupedCondTbl_csf <- function(condstr, sc, freqs, conCovDef = 1:2){
# qc <- qcond_csf(condstr, sc, flat = TRUE)
# ctbl <- cond2condTbl(qc, freqs, conCovDef)
# lengths <- attr(qc, "csflengths")
# out <- split(ctbl,
# rep(seq_along(lengths), lengths))
# names(out) <- condstr
# out <- lapply(out, "rownames<-", NULL)
# out
# }
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.