CRAN packages with 'length > 1 in coercion to logical' reports
kaz-yos opened this issue · 6 comments
kaz-yos commented
Message from the CRAN maintainer:
NEWS for R-devel has
• Calling && or || with either argument of length greater than one
now gives a warning (which it is intended will become an error).
and checks with this made into a fatal error can be seen at
https://www.stats.ox.ac.uk/pub/bdr/LENGTH1/
with reproduction instructions in the 00README.txt file. (As this was made a fatal error, only the first error will be shown so please do run those instructions before re-submission.)
The problems are occurring in a different package and there is a table of which in that 00README.txt, In some cases, this is from misuse but you may need to contact the maintainer of the other package -- packages
kableExtra pracma tidygraph
have already been contacted but ignored us.
Please correct before 2022-04-04 to safely retain your package on CRAN.
kaz-yos commented
Failure report
----------- FAILURE REPORT --------------
--- failure: length > 1 in coercion to logical ---
--- srcref ---
:
--- package (from environment) ---
survey
--- call from context ---
svyCprod(estfun %*% Ainv, design$strata, design$cluster[[1]],
design$fpc, design$nPSU, design$certainty, design$postStrata)
--- call from argument ---
this.n == 1 && !this.certain
--- R stacktrace ---
where 1: svyCprod(estfun %*% Ainv, design$strata, design$cluster[[1]],
design$fpc, design$nPSU, design$certainty, design$postStrata)
where 2: svy.varcoef(m, design)
where 3: multiranktest(formula, design, test, ...)
where 4: svyranktest.svyrep.design(formula = as.formula(formulaString),
design = design)
where 5: svyranktest(formula = as.formula(formulaString), design = design)
where 6: (function (formulaString, design)
{
svyranktest(formula = as.formula(formulaString), design = design)
})("alive ~ ..strataVar..", design = list(type = "BRR", scale = 0.25,
rscales = c(1, 1, 1, 1), rho = NULL, call = svrepdesign.default(data = scd,
type = "BRR", repweights = repweights, combined.weights = FALSE),
combined.weights = FALSE, variables = list(ESA = c(1L, 1L,
2L, 2L, 3L, 3L), ambulance = c(1L, 2L, 1L, 2L, 1L, 2L), arrests = c(120,
78, 185, 228, 670, 530), alive = c(25, 24, 30, 49, 80, 70
), ..strataVar.. = c(1L, 1L, 2L, 2L, 3L, 3L)), pweights = c(1,
1, 1, 1, 1, 1), repweights = c(2, 0, 2, 0, 2, 0, 2, 0, 0,
2, 0, 2, 0, 2, 2, 0, 0, 2, 0, 2, 0, 2, 2, 0), degf = 3, mse = FALSE))
where 7: do.call(testFunction, args = c(list(obj), testArgs))
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(expr, error = function(e) e)
where 12: withCallingHandlers(tryCatch(expr, error = function(e) e), warning = w.handler)
where 13: ModuleTryCatchWE(do.call(testFunction, args = c(list(obj), testArgs))$p.value)
where 14: ModuleTestSafe(formulaString, testNonNormal, c(list(design = data),
argsNonNormal))
where 15: data.frame(pNormal = ModuleTestSafe(formulaString, testNormal,
c(list(design = data, test.terms = "..strataVar.."), argsNormal)),
pNonNormal = ModuleTestSafe(formulaString, testNonNormal,
c(list(design = data), argsNonNormal)))
where 16: FUN(X[[i]], ...)
where 17: lapply(X = X, FUN = FUN, ...)
where 18: sapply(X = vars, FUN = function(var) {
formulaString <- paste0(var, " ~ ..strataVar..")
data.frame(pNormal = ModuleTestSafe(formulaString, testNormal,
c(list(design = data, test.terms = "..strataVar.."),
argsNormal)), pNonNormal = ModuleTestSafe(formulaString,
testNonNormal, c(list(design = data), argsNonNormal)))
}, simplify = FALSE)
where 19: (function (vars, strata, data, test = TRUE, testNormal = svyTestNormal,
argsNormal = list(method = "Wald"), testNonNormal = svyTestNonNormal,
argsNonNormal = NULL, smd = TRUE, addOverall = FALSE)
{
StopIfNotSurveyDesign(data)
vars <- ModuleReturnVarsExist(vars, data$variables)
ModuleStopIfNoVarsLeft(vars)
percentMissing <- ModulePercentMissing(data$variables[vars])
test <- ModuleReturnFalseIfNoStrata(strata, test)
smd <- ModuleReturnFalseIfNoStrata(strata, smd)
strata <- ModuleReturnStrata(strata, data$variables)
data$variables$..strataVar.. <- interaction(strata, sep = ":")
strataVarLevels <- levels(data$variables$..strataVar..)
..strataVar.. <- NULL
if (any(!sapply(data$variables[vars], is.numeric))) {
vars <- vars[sapply(data$variables[vars], is.numeric)]
warning("Non-numeric variables dropped")
}
if (!all(sapply(data$variables[vars], is.numeric))) {
stop("Can only be run on numeric variables")
}
result <- sapply(strataVarLevels, function(level) {
svyContSummary(vars, subset(data, ..strataVar.. %in%
level))
}, simplify = FALSE)
class(result) <- "by"
if (length(result) > 1) {
strataVarName <- paste0(names(strata), collapse = ":")
attributes(result) <- c(attributes(result), list(strataVarName = strataVarName))
}
pValues <- NULL
if (test) {
pValues <- sapply(X = vars, FUN = function(var) {
formulaString <- paste0(var, " ~ ..strataVar..")
data.frame(pNormal = ModuleTestSafe(formulaString,
testNormal, c(list(design = data, test.terms = "..strataVar.."),
argsNormal)), pNonNormal = ModuleTestSafe(formulaString,
testNonNormal, c(list(design = data), argsNonNormal)))
}, simplify = FALSE)
pValues <- do.call(rbind, pValues)
}
smds <- NULL
if (smd) {
smds <- sapply(vars, function(var) {
svyStdDiff(varName = var, groupName = "..strataVar..",
design = data)
}, simplify = FALSE)
smds <- FormatLstSmds(smds, nStrata = length(result))
}
if (isTRUE(addOverall) & is.list(strata)) {
result <- c(ModuleCreateOverallColumn(match.call()),
result)
attributes(result)$names <- c(attributes(result)$names[1],
strataVarLevels)
attributes(result) <- c(attributes(result), list(strataVarName = strataVarName))
}
class(result) <- c("svyContTable", "ContTable", class(result))
attributes(result) <- c(attributes(result), list(pValues = pValues),
list(smd = smds), list(percentMissing = percentMissing))
return(result)
})(vars = "alive", strata = "ESA", data = list(type = "BRR",
scale = 0.25, rscales = c(1, 1, 1, 1), rho = NULL, call = svrepdesign.default(data = scd,
type = "BRR", repweights = repweights, combined.weights = FALSE),
combined.weights = FALSE, variables = list(ESA = c(1L, 1L,
2L, 2L, 3L, 3L), ambulance = c(1L, 2L, 1L, 2L, 1L, 2L), arrests = c(120,
78, 185, 228, 670, 530), alive = c(25, 24, 30, 49, 80, 70
)), pweights = c(1, 1, 1, 1, 1, 1), repweights = c(2, 0,
2, 0, 2, 0, 2, 0, 0, 2, 0, 2, 0, 2, 2, 0, 0, 2, 0, 2, 0,
2, 2, 0), degf = 3, mse = FALSE), test = TRUE, testNormal = function (formulaString,
design, test.terms, method = "Wald")
{
out <- svyGlmTermTest(formula = as.formula(formulaString),
design = design, test.terms = test.terms, method = method)
list(p.value = out$p[1, 1])
}, argsNormal = list(method = "Wald"), testNonNormal = function (formulaString,
design)
{
svyranktest(formula = as.formula(formulaString), design = design)
}, argsNonNormal = NULL, smd = TRUE, addOverall = FALSE)
where 20: do.call(svyCreateContTable, args = c(list(vars = varNumerics),
argsCreateContTable))
where 21 at test-svyCreateTableOne.R#753: svyCreateTableOne(vars = c("alive", "ambulance"), strata = c("ESA"),
factorVars = "ambulance", data = scdrep)
where 22: eval(code, test_env)
where 23: eval(code, test_env)
where 24: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 27: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 28: doTryCatch(return(expr), name, parentenv, handler)
where 29: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 30: tryCatchList(expr, classes, parentenv, handlers)
where 31: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 32: test_code(desc, code, env = parent.frame(), reporter = reporter)
where 33 at test-svyCreateTableOne.R#727: test_that("svyrep.design is allowed", {
data(scd)
scd
repweights <- 2 * cbind(c(1, 0, 1, 0, 1, 0), c(1, 0, 0, 1,
0, 1), c(0, 1, 1, 0, 0, 1), c(0, 1, 0, 1, 1, 0))
scdrep <- suppressWarnings(svrepdesign(data = scd, type = "BRR",
repweights = repweights, combined.weights = FALSE))
ans_means <- svyby(formula = ~alive, by = ~ESA, design = scdrep,
FUN = svymean)[, 2]
ans_sds <- sqrt(svyby(formula = ~alive, by = ~ESA, design = scdrep,
FUN = svyvar)[, 2])
ans_props <- svyby(formula = ~I(ambulance - 1), by = ~ESA,
design = scdrep, FUN = svymean)[, 2]
tab1 <- svyCreateTableOne(vars = c("alive", "ambulance"),
strata = c("ESA"), factorVars = "ambulance", data = scdrep)
tab1_print <- print(tab1, format = "p")
expect_equal(as.character(tab1_print[2, 1:3]), sprintf("%.2f (%.2f)",
ans_means, ans_sds))
expect_equal(as.character(gsub(" ", "", tab1_print[3, 1:3])),
sprintf("%.1f", ans_props * 100))
})
where 34: eval(code, test_env)
where 35: eval(code, test_env)
where 36: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 37: doTryCatch(return(expr), name, parentenv, handler)
where 38: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 39: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 40: doTryCatch(return(expr), name, parentenv, handler)
where 41: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 42: tryCatchList(expr, classes, parentenv, handlers)
where 43: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 44: test_code(NULL, exprs, env)
where 45: source_file(path, child_env(env), wrap = wrap)
where 46: FUN(X[[i]], ...)
where 47: lapply(test_paths, test_one_file, env = env, wrap = wrap)
where 48: doTryCatch(return(expr), name, parentenv, handler)
where 49: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 50: tryCatchList(expr, classes, parentenv, handlers)
where 51: tryCatch(code, testthat_abort_reporter = function(cnd) {
cat(conditionMessage(cnd), "\n")
NULL
})
where 52: with_reporter(reporters$multi, lapply(test_paths, test_one_file,
env = env, wrap = wrap))
where 53: test_files(test_dir = test_dir, test_package = test_package,
test_paths = test_paths, load_helpers = load_helpers, reporter = reporter,
env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap, load_package = load_package)
where 54: test_files(test_dir = path, test_paths = test_paths, test_package = package,
reporter = reporter, load_helpers = load_helpers, env = env,
stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap, load_package = load_package, parallel = parallel)
where 55: test_dir("testthat", package = package, reporter = reporter,
..., load_package = "installed")
where 56: test_check("tableone")
--- value of length: 6 type: logical ---
1 1 1 1 1 1
TRUE TRUE TRUE TRUE TRUE TRUE
--- function from context ---
function (x, strata, psu, fpc, nPSU, certainty = NULL, postStrata = NULL,
lonely.psu = getOption("survey.lonely.psu"))
{
x <- as.matrix(x)
n <- NROW(x)
if (!is.null(postStrata)) {
for (psvar in postStrata) {
if (inherits(psvar, "greg_calibration") || inherits(psvar,
"raking"))
stop("rake() and calibrate() not supported for old-style design objects")
psw <- attr(psvar, "weights")
psmeans <- rowsum(x/psw, psvar, reorder = TRUE)/as.vector(table(factor(psvar)))
x <- x - psmeans[match(psvar, sort(unique(psvar))),
] * psw
}
}
if (is.null(strata)) {
strata <- rep("1", n)
if (!is.null(nPSU))
names(nPSU) <- "1"
}
else strata <- as.character(strata)
if (is.null(certainty)) {
certainty <- rep(FALSE, length(strata))
names(certainty) <- strata
}
if (!is.null(psu)) {
x <- rowsum(x, psu, reorder = FALSE)
strata <- strata[!duplicated(psu)]
n <- NROW(x)
}
if (!is.null(nPSU)) {
obsn <- table(strata)
dropped <- nPSU[match(names(obsn), names(nPSU))] - obsn
if (sum(dropped)) {
xtra <- matrix(0, ncol = NCOL(x), nrow = sum(dropped))
strata <- c(strata, rep(names(dropped), dropped))
if (is.matrix(x))
x <- rbind(x, xtra)
else x <- c(x, xtra)
n <- NROW(x)
}
}
else obsn <- table(strata)
if (is.null(strata)) {
x <- t(t(x) - colMeans(x))
}
else {
strata.means <- drop(rowsum(x, strata, reorder = FALSE))/drop(rowsum(rep(1,
n), strata, reorder = FALSE))
if (!is.matrix(strata.means))
strata.means <- matrix(strata.means, ncol = NCOL(x))
x <- x - strata.means[match(strata, unique(strata)),
, drop = FALSE]
}
p <- NCOL(x)
v <- matrix(0, p, p)
ss <- unique(strata)
for (s in ss) {
this.stratum <- strata %in% s
this.n <- nPSU[match(s, names(nPSU))]
this.df <- this.n/(this.n - 1)
if (is.null(fpc))
this.fpc <- 1
else {
this.fpc <- fpc[, 2][fpc[, 1] == as.character(s)]
this.fpc <- (this.fpc - this.n)/this.fpc
}
xs <- x[this.stratum, , drop = FALSE]
this.certain <- certainty[names(certainty) %in% s]
lonely.psu <- match.arg(lonely.psu, c("remove", "adjust",
"fail", "certainty", "average"))
if (this.n == 1 && !this.certain) {
this.df <- 1
if (lonely.psu == "fail")
stop("Stratum ", s, " has only one sampling unit.")
else if (lonely.psu != "certainty")
warning("Stratum ", s, " has only one sampling unit.")
if (lonely.psu == "adjust")
xs <- strata.means[match(s, ss), , drop = FALSE]
}
else if (obsn[match(s, names(obsn))] == 1 && !this.certain) {
warning("Stratum ", s, " has only one PSU in this subset.")
if (lonely.psu == "adjust")
xs <- strata.means[match(s, ss), , drop = FALSE]
}
if (!this.certain)
v <- v + crossprod(xs) * this.df * this.fpc
}
if (lonely.psu == "average") {
v <- v/(1 - mean(obsn == 1 & !certainty))
}
v
}
<bytecode: 0xdc482a8>
<environment: namespace:survey>
--- function search by body ---
Function svyCprod in namespace survey has this body.
----------- END OF FAILURE REPORT --------------
kaz-yos commented
_R_CHECK_LENGTH_1_LOGIC2_="abort,verbose"; export _R_CHECK_LENGTH_1_LOGIC2_ ; make check # cran-checkR CMD check --as-cran ./tableone_0.13.2.tar.gz | tee cran-check.txt
* using log directory ‘/Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/tableone.Rcheck’
* using R version 4.2.0 beta (2022-04-10 r82135)
* using platform: x86_64-apple-darwin17.0 (64-bit)
* using session charset: UTF-8
* using option ‘--as-cran’
...
* checking tests ...
Running ‘test-all.R’ [52s/58s]
ERROR
Running the tests in ‘tests/test-all.R’ failed.
Last 13 lines of output:
}
if (!this.certain)
v <- v + crossprod(xs) * this.df * this.fpc
}
if (lonely.psu == "average") {
v <- v/(1 - mean(obsn == 1 & !certainty))
}
v
}
<bytecode: 0x7fedb7e82880>
<environment: namespace:survey>
--- function search by body ---
Function svyCprod in namespace survey has this body.
----------- END OF FAILURE REPORT --------------
kaz-yos commented
_R_CHECK_LENGTH_1_LOGIC2_="abort,verbose"; export _R_CHECK_LENGTH_1_LOGIC2_ ; make test...
Unit tests for svy* user functions : svyCprod(estfun %*% Ainv, design$strata, design$cluster[[1]],
design$fpc, design$nPSU, design$certainty, design$postStrata)
where 2: svy.varcoef(m, design)
where 3: multiranktest(formula, design, test, ...)
where 4: svyranktest.svyrep.design(formula = as.formula(formulaString),
design = design)
where 5 at /Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/R/modules-svy.R#231: svyranktest(formula = as.formula(formulaString), design = design)
where 6: (function(formulaString, design) {
## This returns an htest object that has a scalar $p.value element
svyranktest(formula = as.formula(formulaString), design = design)
})("alive ~ ..strataVar..", design = list(type = "BRR", scale = 0.25,
rscales = c(1, 1, 1, 1), rho = NULL, call = svrepdesign.default(data = scd,
type = "BRR", repweights = repweights, combined.weights = FALSE),
combined.weights = FALSE, variables = list(ESA = c(1L, 1L,
2L, 2L, 3L, 3L), ambulance = c(1L, 2L, 1L, 2L, 1L, 2L), arrests = c(120,
78, 185, 228, 670, 530), alive = c(25, 24, 30, 49, 80, 70
), ..strataVar.. = c(1L, 1L, 2L, 2L, 3L, 3L)), pweights = c(1,
1, 1, 1, 1, 1), repweights = c(2, 0, 2, 0, 2, 0, 2, 0, 0,
2, 0, 2, 0, 2, 2, 0, 0, 2, 0, 2, 0, 2, 2, 0), degf = 3, mse = FALSE))
where 7: do.call(testFunction, args = c(list(obj), testArgs))
where 8: doTryCatch(return(expr), name, parentenv, handler)
where 9: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 10: tryCatchList(expr, classes, parentenv, handlers)
where 11: tryCatch(expr, error = function(e) e)
where 12 at /Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/R/modules-constructors.R#255: withCallingHandlers(tryCatch(expr, error = function(e) e), warning = w.handler)
where 13 at /Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/R/modules-constructors.R#264: ModuleTryCatchWE(do.call(testFunction, args = c(list(obj), testArgs))$p.value)
where 14 at /Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/R/svyCreateContTable.R#127: ModuleTestSafe(formulaString, testNonNormal, c(list(design = data),
argsNonNormal))
where 15 at /Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/R/svyCreateContTable.R#127: data.frame(pNormal = ModuleTestSafe(formulaString, testNormal,
c(list(design = data, test.terms = "..strataVar.."), argsNormal)),
pNonNormal = ModuleTestSafe(formulaString, testNonNormal,
c(list(design = data), argsNonNormal)))
where 16: FUN(X[[i]], ...)
where 17: lapply(X = X, FUN = FUN, ...)
where 18 at /Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/R/svyCreateContTable.R#118: sapply(X = vars, FUN = function(var) {
formulaString <- paste0(var, " ~ ..strataVar..")
data.frame(pNormal = ModuleTestSafe(formulaString, testNormal,
c(list(design = data, test.terms = "..strataVar.."),
argsNormal)), pNonNormal = ModuleTestSafe(formulaString,
testNonNormal, c(list(design = data), argsNonNormal)))
}, simplify = FALSE)
where 19: (function(vars, # character vector of variable names
strata, # character vector of variable names
data, # survey design data
test = TRUE, # Whether to include p-values
testNormal = svyTestNormal, # test for normally distributed variables
argsNormal = list(method = "Wald"), # arguments passed to testNormal
testNonNormal = svyTestNonNormal, # test for nonnormally distributed variables
argsNonNormal = NULL, # arguments passed to testNonNormal
smd = TRUE, # whether to include standardize mean differences
addOverall = FALSE
) {
### Data check
## Check if the data given is a survey design object
StopIfNotSurveyDesign(data)
## Check if variables exist. Drop them if not.
## survey.design$variables holds original data frame
vars <- ModuleReturnVarsExist(vars, data$variables)
## Abort if no variables exist at this point
ModuleStopIfNoVarsLeft(vars)
## Get the missing percentage for each variable (no strata).
percentMissing <- ModulePercentMissing(data$variables[vars])
## Toggle test FALSE if no strata
test <- ModuleReturnFalseIfNoStrata(strata, test)
smd <- ModuleReturnFalseIfNoStrata(strata, smd)
## Create strata data frame (data frame with only strata variables)
## FIXME: This changes type of strata; not a good practice
strata <- ModuleReturnStrata(strata, data$variables)
## Create a single stratification variable
## Keeps non-existing levels
data$variables$..strataVar.. <- interaction(strata, sep = ":")
strataVarLevels <- levels(data$variables$..strataVar..)
## Dummy and dumb object to avoid CRAN check "no visible binding for global variable"
..strataVar.. <- NULL
## Handle non-numeric elements (intergers give TRUE, and pass)
if(any(!sapply(data$variables[vars], is.numeric))){
## If there is any non-numeric variables
vars <- vars[sapply(data$variables[vars], is.numeric)]
warning("Non-numeric variables dropped")
}
## Check if all the variables are continuous, and stop if not
if(!all(sapply(data$variables[vars], is.numeric))) {
stop("Can only be run on numeric variables")
}
### Actual descriptive statistics are calculated here.
## To implement
## Create a single grouping variable from strata variables
## Create a list of subgroup data by the grouping variable
## Loop over each stratum with matrix forming function
result <- sapply(strataVarLevels, function(level) {
## Create a matrix including vars X c(n,miss,...) matrix
svyContSummary(vars, subset(data, ..strataVar.. %in% level))
}, simplify = FALSE)
## Make it a by object
class(result) <- "by"
## Add stratification variable information as an attribute
if (length(result) > 1) {
## strataVarName from dimension headers
strataVarName <- paste0(names(strata), collapse = ":")
## Add an attribute for the stratifying variable name
attributes(result) <- c(attributes(result),
list(strataVarName = strataVarName))
}
### Perform tests when necessary
## Initialize to avoid error when it does not exist at the attribute assignment
pValues <- NULL
## Only when test is asked FOR
if (test) {
## Loop over variables in dat, and obtain p values for two tests
## DF = 6 when there are 8 levels (one empty), i.e., empty strata dropped by oneway.test/kruskal.test
pValues <-
sapply(X = vars,
FUN = function(var) {
## Create a formula as a string
formulaString <- paste0(var, " ~ ..strataVar..")
## Perform tests and return the result as 1x2 DF
## The test functions should take a formula string as their first argument.
data.frame(pNormal = ModuleTestSafe(formulaString, testNormal,
c(list(design = data, test.terms = "..strataVar.."),
argsNormal)),
pNonNormal = ModuleTestSafe(formulaString, testNonNormal,
c(list(design = data), argsNonNormal)))
},
simplify = FALSE)
## Create a single data frame (n x 2 (normal,nonormal))
pValues <- do.call(rbind, pValues)
} # Conditional for test == TRUE ends here.
### Perform SMD when requested
smds <- NULL
## Only when SMD is asked for
if (smd) {
## list of smds
smds <- sapply(vars, function(var) {
svyStdDiff(varName = var, groupName = "..strataVar..", design = data)
}, simplify = FALSE)
## Give name and add mean column
smds <- FormatLstSmds(smds, nStrata = length(result))
}
if (isTRUE(addOverall) & is.list(strata)) {
## Get Overall Table
result <- c(ModuleCreateOverallColumn(match.call()), result)
## Fix attributes
attributes(result)$names <- c(attributes(result)$names[1], strataVarLevels)
attributes(result) <- c(attributes(result), list(strataVarName = strataVarName))
}
## Return object
## Give an S3 class
class(result) <- c("svyContTable", "ContTable", class(result))
## Give additional attributes
attributes(result) <- c(attributes(result),
list(pValues = pValues),
list(smd = smds),
list(percentMissing = percentMissing))
## Return
return(result)
})(vars = "alive", strata = "ESA", data = list(type = "BRR",
scale = 0.25, rscales = c(1, 1, 1, 1), rho = NULL, call = svrepdesign.default(data = scd,
type = "BRR", repweights = repweights, combined.weights = FALSE),
combined.weights = FALSE, variables = list(ESA = c(1L, 1L,
2L, 2L, 3L, 3L), ambulance = c(1L, 2L, 1L, 2L, 1L, 2L), arrests = c(120,
78, 185, 228, 670, 530), alive = c(25, 24, 30, 49, 80, 70
)), pweights = c(1, 1, 1, 1, 1, 1), repweights = c(2, 0,
2, 0, 2, 0, 2, 0, 0, 2, 0, 2, 0, 2, 2, 0, 0, 2, 0, 2, 0,
2, 2, 0), degf = 3, mse = FALSE), test = TRUE, testNormal = function(formulaString, design, test.terms, method = "Wald") {
out <- svyGlmTermTest(formula = as.formula(formulaString), design = design,
test.terms = test.terms, method = method)
## Give an appropriate name for consistent extraction
list(p.value = out$p[1,1])
}, argsNormal = list(method = "Wald"), testNonNormal = function(formulaString, design) {
## This returns an htest object that has a scalar $p.value element
svyranktest(formula = as.formula(formulaString), design = design)
}, argsNonNormal = NULL, smd = TRUE, addOverall = FALSE)
where 20 at /Users/kazuki/Dropbox (Personal)/documents/programming/r/tableone/R/svyCreateTableOne.R#202: do.call(svyCreateContTable, args = c(list(vars = varNumerics),
argsCreateContTable))
where 21 at test-svyCreateTableOne.R#753: svyCreateTableOne(vars = c("alive", "ambulance"), strata = c("ESA"),
factorVars = "ambulance", data = scdrep)
where 22: eval(code, test_env)
where 23: eval(code, test_env)
where 24: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 25: doTryCatch(return(expr), name, parentenv, handler)
where 26: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 27: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 28: doTryCatch(return(expr), name, parentenv, handler)
where 29: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 30: tryCatchList(expr, classes, parentenv, handlers)
where 31: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 32: test_code(desc, code, env = parent.frame(), reporter = reporter)
where 33 at test-svyCreateTableOne.R#727: test_that("svyrep.design is allowed", {
data(scd)
scd
repweights <- 2 * cbind(c(1, 0, 1, 0, 1, 0), c(1, 0, 0, 1,
0, 1), c(0, 1, 1, 0, 0, 1), c(0, 1, 0, 1, 1, 0))
scdrep <- suppressWarnings(svrepdesign(data = scd, type = "BRR",
repweights = repweights, combined.weights = FALSE))
ans_means <- svyby(formula = ~alive, by = ~ESA, design = scdrep,
FUN = svymean)[, 2]
ans_sds <- sqrt(svyby(formula = ~alive, by = ~ESA, design = scdrep,
FUN = svyvar)[, 2])
ans_props <- svyby(formula = ~I(ambulance - 1), by = ~ESA,
design = scdrep, FUN = svymean)[, 2]
tab1 <- svyCreateTableOne(vars = c("alive", "ambulance"),
strata = c("ESA"), factorVars = "ambulance", data = scdrep)
tab1_print <- print(tab1, format = "p")
expect_equal(as.character(tab1_print[2, 1:3]), sprintf("%.2f (%.2f)",
ans_means, ans_sds))
expect_equal(as.character(gsub(" ", "", tab1_print[3, 1:3])),
sprintf("%.1f", ans_props * 100))
})
where 34: eval(code, test_env)
where 35: eval(code, test_env)
where 36: withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error)
where 37: doTryCatch(return(expr), name, parentenv, handler)
where 38: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 39: tryCatchList(expr, names[-nh], parentenv, handlers[-nh])
where 40: doTryCatch(return(expr), name, parentenv, handler)
where 41: tryCatchOne(tryCatchList(expr, names[-nh], parentenv, handlers[-nh]),
names[nh], parentenv, handlers[[nh]])
where 42: tryCatchList(expr, classes, parentenv, handlers)
where 43: tryCatch(withCallingHandlers({
eval(code, test_env)
if (!handled && !is.null(test)) {
skip_empty()
}
}, expectation = handle_expectation, skip = handle_skip, warning = handle_warning,
message = handle_message, error = handle_error), error = handle_fatal,
skip = function(e) {
})
where 44: test_code(NULL, exprs, env)
where 45: source_file(path, child_env(env), wrap = wrap)
where 46: FUN(X[[i]], ...)
where 47: lapply(test_paths, test_one_file, env = env, wrap = wrap)
where 48: doTryCatch(return(expr), name, parentenv, handler)
where 49: tryCatchOne(expr, names, parentenv, handlers[[1L]])
where 50: tryCatchList(expr, classes, parentenv, handlers)
where 51: tryCatch(code, testthat_abort_reporter = function(cnd) {
cat(conditionMessage(cnd), "\n")
NULL
})
where 52: with_reporter(reporters$multi, lapply(test_paths, test_one_file,
env = env, wrap = wrap))
where 53: test_files(test_dir = test_dir, test_package = test_package,
test_paths = test_paths, load_helpers = load_helpers, reporter = reporter,
env = env, stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap, load_package = load_package)
where 54: test_files(test_dir = path, test_paths = test_paths, test_package = package,
reporter = reporter, load_helpers = load_helpers, env = env,
stop_on_failure = stop_on_failure, stop_on_warning = stop_on_warning,
wrap = wrap, load_package = load_package, parallel = parallel)
where 55: test_dir(test_path, package = package, reporter = reporter, ...,
load_package = if (package != "testthat") "source" else "none")
where 56: testthat::test_local(pkg$path, filter = filter, stop_on_failure = stop_on_failure,
...)
where 57: devtools::test()
--- value of length: 6 type: logical ---
1 1 1 1 1 1
TRUE TRUE TRUE TRUE TRUE TRUE
--- function from context ---
function (x, strata, psu, fpc, nPSU, certainty = NULL, postStrata = NULL,
lonely.psu = getOption("survey.lonely.psu"))
{
x <- as.matrix(x)
n <- NROW(x)
if (!is.null(postStrata)) {
for (psvar in postStrata) {
if (inherits(psvar, "greg_calibration") || inherits(psvar,
"raking"))
stop("rake() and calibrate() not supported for old-style design objects")
psw <- attr(psvar, "weights")
psmeans <- rowsum(x/psw, psvar, reorder = TRUE)/as.vector(table(factor(psvar)))
x <- x - psmeans[match(psvar, sort(unique(psvar))),
] * psw
}
}
if (is.null(strata)) {
strata <- rep("1", n)
if (!is.null(nPSU))
names(nPSU) <- "1"
}
else strata <- as.character(strata)
if (is.null(certainty)) {
certainty <- rep(FALSE, length(strata))
names(certainty) <- strata
}
if (!is.null(psu)) {
x <- rowsum(x, psu, reorder = FALSE)
strata <- strata[!duplicated(psu)]
n <- NROW(x)
}
if (!is.null(nPSU)) {
obsn <- table(strata)
dropped <- nPSU[match(names(obsn), names(nPSU))] - obsn
if (sum(dropped)) {
xtra <- matrix(0, ncol = NCOL(x), nrow = sum(dropped))
strata <- c(strata, rep(names(dropped), dropped))
if (is.matrix(x))
x <- rbind(x, xtra)
else x <- c(x, xtra)
n <- NROW(x)
}
}
else obsn <- table(strata)
if (is.null(strata)) {
x <- t(t(x) - colMeans(x))
}
else {
strata.means <- drop(rowsum(x, strata, reorder = FALSE))/drop(rowsum(rep(1,
n), strata, reorder = FALSE))
if (!is.matrix(strata.means))
strata.means <- matrix(strata.means, ncol = NCOL(x))
x <- x - strata.means[match(strata, unique(strata)),
, drop = FALSE]
}
p <- NCOL(x)
v <- matrix(0, p, p)
ss <- unique(strata)
for (s in ss) {
this.stratum <- strata %in% s
this.n <- nPSU[match(s, names(nPSU))]
this.df <- this.n/(this.n - 1)
if (is.null(fpc))
this.fpc <- 1
else {
this.fpc <- fpc[, 2][fpc[, 1] == as.character(s)]
this.fpc <- (this.fpc - this.n)/this.fpc
}
xs <- x[this.stratum, , drop = FALSE]
this.certain <- certainty[names(certainty) %in% s]
lonely.psu <- match.arg(lonely.psu, c("remove", "adjust",
"fail", "certainty", "average"))
if (this.n == 1 && !this.certain) {
this.df <- 1
if (lonely.psu == "fail")
stop("Stratum ", s, " has only one sampling unit.")
else if (lonely.psu != "certainty")
warning("Stratum ", s, " has only one sampling unit.")
if (lonely.psu == "adjust")
xs <- strata.means[match(s, ss), , drop = FALSE]
}
else if (obsn[match(s, names(obsn))] == 1 && !this.certain) {
warning("Stratum ", s, " has only one PSU in this subset.")
if (lonely.psu == "adjust")
xs <- strata.means[match(s, ss), , drop = FALSE]
}
if (!this.certain)
v <- v + crossprod(xs) * this.df * this.fpc
}
if (lonely.psu == "average") {
v <- v/(1 - mean(obsn == 1 & !certainty))
}
v
}
<bytecode: 0x7ff446b3ed80>
<environment: namespace:survey>
--- function search by body ---
Function svyCprod in namespace survey has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: length > 1 in coercion to logical
kaz-yos commented
Skipping the following two test files avoids the issue.
test-modules-svy.R
test-svyCreateTableOne.R
kaz-yos commented
Will proceed with the above temporary solution (disabling tests that call survey) for now.
mm0hgw commented
What is one supposed to do if one actually want to to perform these operations on logical vectors?
This issue trips on some of my input validation. I'm subsetting an object into chunks, by index numbers. (i < 1) provides a vector which is true for all indices too low, while (i >n) provides a vector which is true for all indices too high.
What should I use instead of || since I wish to logically OR these vectors together, in order to report all the bad index numbers at once?
EDIT: found the answer in help('||') having come from C, I'm used to | being bitwise rather than logical OR.