kaz-yos
commented
2 years ago 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 -------------- 
mm0hgw
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
have already been contacted but ignored us.
Please correct before 2022-04-04 to safely retain your package on CRAN.