Last updated on 2020-02-19 10:49:14 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.0-2 | 21.26 | 112.87 | 134.13 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 1.0-2 | 17.11 | 87.68 | 104.79 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 1.0-2 | 155.84 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 1.0-2 | 145.27 | ERROR | |||
| r-devel-windows-ix86+x86_64 | 1.0-2 | 36.00 | 181.00 | 217.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 1.0-2 | 48.00 | 160.00 | 208.00 | OK | |
| r-patched-linux-x86_64 | 1.0-2 | 17.48 | 108.71 | 126.19 | OK | |
| r-patched-solaris-x86 | 1.0-2 | 231.50 | OK | |||
| r-release-linux-x86_64 | 1.0-2 | 17.48 | 110.65 | 128.13 | OK | |
| r-release-windows-ix86+x86_64 | 1.0-2 | 33.00 | 155.00 | 188.00 | OK | |
| r-release-osx-x86_64 | 1.0-2 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 1.0-2 | 24.00 | 138.00 | 162.00 | OK | |
| r-oldrel-osx-x86_64 | 1.0-2 | OK |
Version: 1.0-2
Check: examples
Result: ERROR
Running examples in 'vcrpart-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: fvcm-methods
> ### Title: Methods for 'fvcm' objects
> ### Aliases: fvcm-methods fitted.fvcm print.fvcm oobloss.fvcm plot.fvcm
> ### predict.fvcm print.fvcm ranef.fvcm
> ### Keywords: methods hplot
>
> ### ** Examples
>
>
> ## ------------------------------------------------------------------- #
> ## Dummy example 1:
> ##
> ## Fitting a random forest tvcm on artificially generated ordinal
> ## longitudinal data. The parameters 'maxstep = 1' and 'K = 2' are
> ## chosen to restrict the computations.
> ## ------------------------------------------------------------------- #
>
> ## load the data
>
> data(vcrpart_1)
>
> ## fit and analyse the model
>
> control <-
+ fvcolmm_control(mtry = 2, maxstep = 1,
+ folds = folds_control(type = "subsampling", K = 2, prob = 0.75))
>
> model.1 <-
+ fvcolmm(y ~ -1 + wave + vc(z3, z4, by = treat, intercept = TRUE) + re(1|id),
+ family = cumulative(), subset = 1:100,
+ data = vcrpart_1, control = control)
* fitting an initial tree ... OK
[ 1 ][ 2 ]
>
> ## estimating the out of bag loss
> suppressWarnings(oobloss(model.1))
[1] Inf
>
> ## predicting responses and varying coefficients for subject '27'
> subs <- vcrpart_1$id == "27"
>
> ## predict coefficients
> predict(model.1, newdata = vcrpart_1[subs,], type = "coef")
Eta1:(Intercept) Eta2:(Intercept) treat wave ranefCholFac1
105 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
106 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
107 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
108 -2.812295 0.1968348 1.481318 0.2515896 1.617485
>
> ## marginal response prediction
> predict(model.1, vcrpart_1[subs,], "response", ranef = FALSE)
1 2 3
105 0.64487105 0.3030852 0.05204376
106 0.05173905 0.3021793 0.64608161
107 0.05963581 0.3241881 0.61617604
108 0.08089282 0.4062962 0.51281095
>
> ## conditional response prediction
> re <- matrix(5, 1, 1, dimnames = list("27", "(Intercept)"))
> predict(model.1, vcrpart_1[subs,], "response", ranef = re)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
vcrpart
--- call from context ---
predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- call from argument ---
if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.")
--- R stacktrace ---
where 1: predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
where 2: predict(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (object, newdata = NULL, type = c("link", "response",
"prob", "class", "coef", "ranef"), ranef = FALSE, na.action = na.pass,
verbose = FALSE, ...)
{
type <- match.arg(type)
if (type == "prob")
type = "response"
if (!is.null(newdata) && !is.data.frame(newdata))
stop("'newdata' must be a 'data.frame'.")
if (!class(ranef) %in% c("logical", "matrix"))
stop("'ranef' must be a 'logical' or a 'matrix'.")
if (!is.null(newdata) && is.logical(ranef) && ranef)
stop("'ranef' should be 'FALSE' or a 'matrix' if 'newdata' is ",
"not 'NULL'.")
if (type == "ranef" & (!is.logical(ranef) | is.logical(ranef) &&
ranef))
stop("for 'type = 'ranef'' the argument 'ranef' must be 'FALSE'.")
if (type == "ranef" & !is.null(newdata))
stop("prediction for random effects for 'newdata' is not ",
"implemented.")
oob <- if (!is.null(list(...)$oob))
list(...)$oob
else FALSE
if (oob && !is.null(newdata))
stop("'oob' should be 'FALSE' if 'newdata' is not 'NULL'")
class(object) <- class(object)[-1L]
md <- object$info$data
dummymodel <- object$info$model
if (is.null(newdata))
newdata <- md
folds <- if (oob) {
object$info$folds
}
else {
matrix(1L, nrow(newdata), length(object$info$forest))
}
formList <- object$info$formula
rootForm <- tvcm_formula(formList, rep(TRUE, length(formList$vc)),
object$info$family)$full
formList <- vcrpart_formula(rootForm, object$info$family)
yName <- all.vars(lhs(formList$original))
yLevs <- if (object$info$fit == "olmm")
levels(md[, yName])
else yName
nYLevs <- length(yLevs)
if (type != "coef") {
if (!yName %in% colnames(newdata))
newdata[, yName] <- sample(md[, yName], nrow(newdata),
replace = TRUE)
feVars <- unlist(lapply(formList$fe$eta, all.vars))
if (!all(subs <- feVars %in% colnames(newdata)))
stop("variable(s) ", paste("'", feVars[!subs], "'",
collapse = ", "), " are not available in 'newdata'.")
reVars <- unlist(lapply(unlist(formList$re[c("eta", "cond")]),
all.vars))
if (length(reVars) > 0L) {
if (is.logical(ranef) && ranef | is.matrix(ranef)) {
if (!all(subs <- reVars %in% colnames(newdata)))
stop("variables ", feVars[!subs], " are not available in 'newdata'.")
}
else {
for (var in reVars) newdata[, var] <- sample(md[,
var], nrow(newdata), replace = TRUE)
}
}
Terms <- attr(md, "terms")
xlevels <- .getXlevels(attr(md, "terms"), md)
if (is.matrix(ranef)) {
subjectName <- dummymodel$subjectName
xlevels <- xlevels[names(xlevels) != subjectName]
}
newdata <- as.data.frame(model.frame(Terms, newdata,
na.action = na.pass, xlev = xlevels))
attr(newdata, "terms") <- NULL
}
if (verbose)
cat("* predicting the coefficient functions ... ")
nEta <- if (object$info$fit == "olmm")
nYLevs - 1L
else 1L
etaLabs <- paste("Eta", 1L:nEta, sep = "")
coef <- count <- 0 * predict(object, newdata, type = "coef")
rownames(coef) <- rownames(newdata)
subs <- matrix(TRUE, nrow(coef), ncol(coef), dimnames = list(rownames(coef),
colnames(coef)))
for (i in seq_along(object$info$forest)) {
if (verbose)
cat(".")
object$info$node <- object$info$forest[[i]]
object$info$model$coefficients <- object$info$coefficients[[i]]
object$info$model$contrasts <- object$info$contrasts[[i]]
coefi <- predict(object, newdata = newdata, type = "coef",
ranef = FALSE, na.action = na.pass, ...)
if (!is.matrix(coefi))
coefi <- matrix(coefi, nrow = nrow(newdata))
if (object$info$fit == "olmm" && ncol(coefi) < ncol(coef)) {
subsiCols <- table(md[folds[, i] > 0, yName]) > 0L
subsiCols <- subsiCols[-length(subsiCols)]
etaLabsShould <- etaLabs[subsiCols]
colnamesi <- colnames(coefi)
etaLabsIs <- grep("Eta[1-9]+:", colnamesi, value = TRUE)
etaLabsIs <- unique(sapply(strsplit(etaLabsIs, ":"),
function(x) x[1]))
colnamesi <- strsplit(colnamesi, ":")
for (j in rev(seq_along(etaLabsIs))) {
colnamesi <- lapply(colnamesi, function(x) {
if (x[1L] == etaLabsIs[j])
x[1L] <- etaLabsShould[j]
return(x)
})
}
colnamesi <- sapply(colnamesi, function(x) paste(x,
collapse = ":"))
colnames(coefi) <- colnamesi
}
coefi <- coefi[, intersect(colnames(coef), colnames(coefi)),
drop = FALSE]
subsi <- subs
if (oob)
subsi[folds[, i] > 0L, ] <- FALSE
subsi[is.na(coefi)] <- FALSE
coef[subsi] <- coef[subsi] + coefi[subsi]
count <- count + 1 * subsi
}
if (verbose)
cat(" OK\n")
coef <- coef/count
coef[apply(count, 1, function(x) any(x == 0)), ] <- NA
if (length(setdiff(names(coef(dummymodel)), colnames(coef))) >
0 | length(setdiff(colnames(coef), names(coef(dummymodel)))) >
0)
stop("ups. This shouldn't happen. Please contact the author of this package and ",
"indicate to have problems with 'fvcm.predict'.")
coef <- coef[, match(names(coef(dummymodel)), colnames(coef)),
drop = FALSE]
if (type == "coef")
return(na.action(coef))
if (object$info$fit == "olmm") {
X <- olmm_merge_mm(model.matrix(terms(formList$fe$eta$ce,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), model.matrix(terms(formList$fe$eta$ge,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), TRUE)
}
else {
X <- model.matrix(terms(rootForm), newdata, dummymodel$contrasts)
}
if (object$info$fit == "olmm") {
coef <- coef[, substr(colnames(coef), 1, 12) != "ranefCholFac",
drop = FALSE]
dims <- dummymodel$dims
fixefMat <- function(fixef) {
return(rbind(matrix(fixef[1:(dims["pCe"] * dims["nEta"])],
dims["pCe"], dims["nEta"], byrow = FALSE), if (dims["pGe"] >
0) matrix(rep(fixef[(dims["pCe"] * dims["nEta"] +
1):dims["p"]], each = dims["nEta"]), dims["pGe"],
dims["nEta"], byrow = TRUE) else NULL))
}
eta <- sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% fixefMat(coef[i, ])
})
if (dims["nEta"] == 1)
eta <- matrix(eta, ncol = 1)
else eta <- t(eta)
colnames(eta) <- etaLabs
rownames(eta) <- rownames(newdata)
}
else {
eta <- t(sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% coef[i, ]
}))
eta <- matrix(eta, ncol = 1L)
}
if (type == "link") {
if (object$info$fit != "olmm")
eta <- c(eta)
return(na.action(eta))
}
start <- NULL
if (object$info$fit == "olmm") {
terms <- "fe(intercept=FALSE)"
mTerms <- terms(object$info$formula$original, specials = "re")
if (length(subs <- attr(mTerms, "specials")$re) > 0L) {
terms <- c(terms, rownames(attr(mTerms, "factors"))[subs])
reTerms <- grep("ranefCholFac", names(object$info$coefficients[[1L]]),
value = TRUE)
start <- sapply(seq_along(object$info$coefficients),
function(i) object$info$coefficients[[i]][reTerms])
start <- apply(matrix(start, ncol = length(reTerms)),
2L, mean)
names(start) <- reTerms
}
}
else {
terms <- "-1"
}
form <- as.formula(paste(yName, "~", paste(terms, collapse = "+")))
if (is.factor(newdata[, yName]) && length(unique(newdata[,
yName])) < nYLevs) {
subs <- nrow(newdata) + 1L:nYLevs
newdata <- rbind(newdata, newdata[rep(1L, nYLevs), ,
drop = FALSE])
newdata[subs, yName] <- yLevs
if (object$info$fit == "olmm") {
sN <- object$info$model$subjectName
levs <- c(levels(newdata[, sN]), "RetoBuergin")
newdata[sN] <- factor(newdata[, sN], levels = levs)
newdata[subs, sN] <- "RetoBuergin"
}
eta <- rbind(eta, matrix(0, nYLevs, ncol(eta)))
folds <- rbind(folds, matrix(-1L, nYLevs, length(object$info$forest)))
}
offset <- eta
offset[is.na(offset)] <- 0
oobCall <- call(name = object$info$fit, form = quote(form),
data = quote(newdata), offset = quote(offset), family = quote(object$info$family),
start = quote(start), na.action = na.pass)
for (arg in names(object$info$dotargs)) oobCall[[arg]] <- object$info$dotargs[[arg]]
oobCall <- oobCall[!duplicated(names(oobCall))]
if (object$info$fit == "olmm")
oobCall$doFit <- FALSE
model <- suppressWarnings(eval(oobCall))
if (type == "ranef") {
ranef <- ranef(model)
ranef <- ranef[rownames(ranef) != "RetoBuergin", , drop = FALSE]
return(na.action(ranef))
}
else {
if (is.matrix(ranef)) {
ranefMat <- ranef(model)
ranefMat[rownames(ranef), ] <- ranef
ranef <- ranefMat
}
pred <- predict(model, type = type, ranef = ranef, ...)
if (!is.matrix(pred))
pred <- matrix(pred, nrow = nrow(newdata))
pred[apply(eta, 1, function(x) any(is.na(x))), ] <- NA
pred <- pred[folds[, 1] >= 0L, , drop = FALSE]
}
folds <- folds[folds[, 1] >= 0L, , drop = FALSE]
if (oob)
pred[apply(folds, 1L, function(x) all(x == 0L)), ] <- NA
if (object$info$fit != "olmm")
pred <- c(pred)
return(na.action(pred))
}
<bytecode: 0xd9ae7b8>
<environment: namespace:vcrpart>
--- function search by body ---
Function predict.fvcm in namespace vcrpart has this body.
----------- END OF FAILURE REPORT --------------
Error in if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.") :
the condition has length > 1
Calls: predict -> predict.fvcm
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.0-2
Check: examples
Result: ERROR
Running examples in ‘vcrpart-Ex.R’ failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: fvcm-methods
> ### Title: Methods for 'fvcm' objects
> ### Aliases: fvcm-methods fitted.fvcm print.fvcm oobloss.fvcm plot.fvcm
> ### predict.fvcm print.fvcm ranef.fvcm
> ### Keywords: methods hplot
>
> ### ** Examples
>
>
> ## ------------------------------------------------------------------- #
> ## Dummy example 1:
> ##
> ## Fitting a random forest tvcm on artificially generated ordinal
> ## longitudinal data. The parameters 'maxstep = 1' and 'K = 2' are
> ## chosen to restrict the computations.
> ## ------------------------------------------------------------------- #
>
> ## load the data
>
> data(vcrpart_1)
>
> ## fit and analyse the model
>
> control <-
+ fvcolmm_control(mtry = 2, maxstep = 1,
+ folds = folds_control(type = "subsampling", K = 2, prob = 0.75))
>
> model.1 <-
+ fvcolmm(y ~ -1 + wave + vc(z3, z4, by = treat, intercept = TRUE) + re(1|id),
+ family = cumulative(), subset = 1:100,
+ data = vcrpart_1, control = control)
* fitting an initial tree ... OK
[ 1 ][ 2 ]
>
> ## estimating the out of bag loss
> suppressWarnings(oobloss(model.1))
[1] Inf
>
> ## predicting responses and varying coefficients for subject '27'
> subs <- vcrpart_1$id == "27"
>
> ## predict coefficients
> predict(model.1, newdata = vcrpart_1[subs,], type = "coef")
Eta1:(Intercept) Eta2:(Intercept) treat wave ranefCholFac1
105 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
106 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
107 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
108 -2.812295 0.1968348 1.481318 0.2515896 1.617485
>
> ## marginal response prediction
> predict(model.1, vcrpart_1[subs,], "response", ranef = FALSE)
1 2 3
105 0.64487105 0.3030852 0.05204376
106 0.05173905 0.3021793 0.64608161
107 0.05963581 0.3241881 0.61617604
108 0.08089282 0.4062962 0.51281095
>
> ## conditional response prediction
> re <- matrix(5, 1, 1, dimnames = list("27", "(Intercept)"))
> predict(model.1, vcrpart_1[subs,], "response", ranef = re)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
vcrpart
--- call from context ---
predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- call from argument ---
if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.")
--- R stacktrace ---
where 1: predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
where 2: predict(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (object, newdata = NULL, type = c("link", "response",
"prob", "class", "coef", "ranef"), ranef = FALSE, na.action = na.pass,
verbose = FALSE, ...)
{
type <- match.arg(type)
if (type == "prob")
type = "response"
if (!is.null(newdata) && !is.data.frame(newdata))
stop("'newdata' must be a 'data.frame'.")
if (!class(ranef) %in% c("logical", "matrix"))
stop("'ranef' must be a 'logical' or a 'matrix'.")
if (!is.null(newdata) && is.logical(ranef) && ranef)
stop("'ranef' should be 'FALSE' or a 'matrix' if 'newdata' is ",
"not 'NULL'.")
if (type == "ranef" & (!is.logical(ranef) | is.logical(ranef) &&
ranef))
stop("for 'type = 'ranef'' the argument 'ranef' must be 'FALSE'.")
if (type == "ranef" & !is.null(newdata))
stop("prediction for random effects for 'newdata' is not ",
"implemented.")
oob <- if (!is.null(list(...)$oob))
list(...)$oob
else FALSE
if (oob && !is.null(newdata))
stop("'oob' should be 'FALSE' if 'newdata' is not 'NULL'")
class(object) <- class(object)[-1L]
md <- object$info$data
dummymodel <- object$info$model
if (is.null(newdata))
newdata <- md
folds <- if (oob) {
object$info$folds
}
else {
matrix(1L, nrow(newdata), length(object$info$forest))
}
formList <- object$info$formula
rootForm <- tvcm_formula(formList, rep(TRUE, length(formList$vc)),
object$info$family)$full
formList <- vcrpart_formula(rootForm, object$info$family)
yName <- all.vars(lhs(formList$original))
yLevs <- if (object$info$fit == "olmm")
levels(md[, yName])
else yName
nYLevs <- length(yLevs)
if (type != "coef") {
if (!yName %in% colnames(newdata))
newdata[, yName] <- sample(md[, yName], nrow(newdata),
replace = TRUE)
feVars <- unlist(lapply(formList$fe$eta, all.vars))
if (!all(subs <- feVars %in% colnames(newdata)))
stop("variable(s) ", paste("'", feVars[!subs], "'",
collapse = ", "), " are not available in 'newdata'.")
reVars <- unlist(lapply(unlist(formList$re[c("eta", "cond")]),
all.vars))
if (length(reVars) > 0L) {
if (is.logical(ranef) && ranef | is.matrix(ranef)) {
if (!all(subs <- reVars %in% colnames(newdata)))
stop("variables ", feVars[!subs], " are not available in 'newdata'.")
}
else {
for (var in reVars) newdata[, var] <- sample(md[,
var], nrow(newdata), replace = TRUE)
}
}
Terms <- attr(md, "terms")
xlevels <- .getXlevels(attr(md, "terms"), md)
if (is.matrix(ranef)) {
subjectName <- dummymodel$subjectName
xlevels <- xlevels[names(xlevels) != subjectName]
}
newdata <- as.data.frame(model.frame(Terms, newdata,
na.action = na.pass, xlev = xlevels))
attr(newdata, "terms") <- NULL
}
if (verbose)
cat("* predicting the coefficient functions ... ")
nEta <- if (object$info$fit == "olmm")
nYLevs - 1L
else 1L
etaLabs <- paste("Eta", 1L:nEta, sep = "")
coef <- count <- 0 * predict(object, newdata, type = "coef")
rownames(coef) <- rownames(newdata)
subs <- matrix(TRUE, nrow(coef), ncol(coef), dimnames = list(rownames(coef),
colnames(coef)))
for (i in seq_along(object$info$forest)) {
if (verbose)
cat(".")
object$info$node <- object$info$forest[[i]]
object$info$model$coefficients <- object$info$coefficients[[i]]
object$info$model$contrasts <- object$info$contrasts[[i]]
coefi <- predict(object, newdata = newdata, type = "coef",
ranef = FALSE, na.action = na.pass, ...)
if (!is.matrix(coefi))
coefi <- matrix(coefi, nrow = nrow(newdata))
if (object$info$fit == "olmm" && ncol(coefi) < ncol(coef)) {
subsiCols <- table(md[folds[, i] > 0, yName]) > 0L
subsiCols <- subsiCols[-length(subsiCols)]
etaLabsShould <- etaLabs[subsiCols]
colnamesi <- colnames(coefi)
etaLabsIs <- grep("Eta[1-9]+:", colnamesi, value = TRUE)
etaLabsIs <- unique(sapply(strsplit(etaLabsIs, ":"),
function(x) x[1]))
colnamesi <- strsplit(colnamesi, ":")
for (j in rev(seq_along(etaLabsIs))) {
colnamesi <- lapply(colnamesi, function(x) {
if (x[1L] == etaLabsIs[j])
x[1L] <- etaLabsShould[j]
return(x)
})
}
colnamesi <- sapply(colnamesi, function(x) paste(x,
collapse = ":"))
colnames(coefi) <- colnamesi
}
coefi <- coefi[, intersect(colnames(coef), colnames(coefi)),
drop = FALSE]
subsi <- subs
if (oob)
subsi[folds[, i] > 0L, ] <- FALSE
subsi[is.na(coefi)] <- FALSE
coef[subsi] <- coef[subsi] + coefi[subsi]
count <- count + 1 * subsi
}
if (verbose)
cat(" OK\n")
coef <- coef/count
coef[apply(count, 1, function(x) any(x == 0)), ] <- NA
if (length(setdiff(names(coef(dummymodel)), colnames(coef))) >
0 | length(setdiff(colnames(coef), names(coef(dummymodel)))) >
0)
stop("ups. This shouldn't happen. Please contact the author of this package and ",
"indicate to have problems with 'fvcm.predict'.")
coef <- coef[, match(names(coef(dummymodel)), colnames(coef)),
drop = FALSE]
if (type == "coef")
return(na.action(coef))
if (object$info$fit == "olmm") {
X <- olmm_merge_mm(model.matrix(terms(formList$fe$eta$ce,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), model.matrix(terms(formList$fe$eta$ge,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), TRUE)
}
else {
X <- model.matrix(terms(rootForm), newdata, dummymodel$contrasts)
}
if (object$info$fit == "olmm") {
coef <- coef[, substr(colnames(coef), 1, 12) != "ranefCholFac",
drop = FALSE]
dims <- dummymodel$dims
fixefMat <- function(fixef) {
return(rbind(matrix(fixef[1:(dims["pCe"] * dims["nEta"])],
dims["pCe"], dims["nEta"], byrow = FALSE), if (dims["pGe"] >
0) matrix(rep(fixef[(dims["pCe"] * dims["nEta"] +
1):dims["p"]], each = dims["nEta"]), dims["pGe"],
dims["nEta"], byrow = TRUE) else NULL))
}
eta <- sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% fixefMat(coef[i, ])
})
if (dims["nEta"] == 1)
eta <- matrix(eta, ncol = 1)
else eta <- t(eta)
colnames(eta) <- etaLabs
rownames(eta) <- rownames(newdata)
}
else {
eta <- t(sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% coef[i, ]
}))
eta <- matrix(eta, ncol = 1L)
}
if (type == "link") {
if (object$info$fit != "olmm")
eta <- c(eta)
return(na.action(eta))
}
start <- NULL
if (object$info$fit == "olmm") {
terms <- "fe(intercept=FALSE)"
mTerms <- terms(object$info$formula$original, specials = "re")
if (length(subs <- attr(mTerms, "specials")$re) > 0L) {
terms <- c(terms, rownames(attr(mTerms, "factors"))[subs])
reTerms <- grep("ranefCholFac", names(object$info$coefficients[[1L]]),
value = TRUE)
start <- sapply(seq_along(object$info$coefficients),
function(i) object$info$coefficients[[i]][reTerms])
start <- apply(matrix(start, ncol = length(reTerms)),
2L, mean)
names(start) <- reTerms
}
}
else {
terms <- "-1"
}
form <- as.formula(paste(yName, "~", paste(terms, collapse = "+")))
if (is.factor(newdata[, yName]) && length(unique(newdata[,
yName])) < nYLevs) {
subs <- nrow(newdata) + 1L:nYLevs
newdata <- rbind(newdata, newdata[rep(1L, nYLevs), ,
drop = FALSE])
newdata[subs, yName] <- yLevs
if (object$info$fit == "olmm") {
sN <- object$info$model$subjectName
levs <- c(levels(newdata[, sN]), "RetoBuergin")
newdata[sN] <- factor(newdata[, sN], levels = levs)
newdata[subs, sN] <- "RetoBuergin"
}
eta <- rbind(eta, matrix(0, nYLevs, ncol(eta)))
folds <- rbind(folds, matrix(-1L, nYLevs, length(object$info$forest)))
}
offset <- eta
offset[is.na(offset)] <- 0
oobCall <- call(name = object$info$fit, form = quote(form),
data = quote(newdata), offset = quote(offset), family = quote(object$info$family),
start = quote(start), na.action = na.pass)
for (arg in names(object$info$dotargs)) oobCall[[arg]] <- object$info$dotargs[[arg]]
oobCall <- oobCall[!duplicated(names(oobCall))]
if (object$info$fit == "olmm")
oobCall$doFit <- FALSE
model <- suppressWarnings(eval(oobCall))
if (type == "ranef") {
ranef <- ranef(model)
ranef <- ranef[rownames(ranef) != "RetoBuergin", , drop = FALSE]
return(na.action(ranef))
}
else {
if (is.matrix(ranef)) {
ranefMat <- ranef(model)
ranefMat[rownames(ranef), ] <- ranef
ranef <- ranefMat
}
pred <- predict(model, type = type, ranef = ranef, ...)
if (!is.matrix(pred))
pred <- matrix(pred, nrow = nrow(newdata))
pred[apply(eta, 1, function(x) any(is.na(x))), ] <- NA
pred <- pred[folds[, 1] >= 0L, , drop = FALSE]
}
folds <- folds[folds[, 1] >= 0L, , drop = FALSE]
if (oob)
pred[apply(folds, 1L, function(x) all(x == 0L)), ] <- NA
if (object$info$fit != "olmm")
pred <- c(pred)
return(na.action(pred))
}
<bytecode: 0x5560ad042640>
<environment: namespace:vcrpart>
--- function search by body ---
Function predict.fvcm in namespace vcrpart has this body.
----------- END OF FAILURE REPORT --------------
Error in if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.") :
the condition has length > 1
Calls: predict -> predict.fvcm
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 1.0-2
Check: examples
Result: ERROR
Running examples in ‘vcrpart-Ex.R’ failed
The error most likely occurred in:
> ### Name: fvcm-methods
> ### Title: Methods for 'fvcm' objects
> ### Aliases: fvcm-methods fitted.fvcm print.fvcm oobloss.fvcm plot.fvcm
> ### predict.fvcm print.fvcm ranef.fvcm
> ### Keywords: methods hplot
>
> ### ** Examples
>
>
> ## ------------------------------------------------------------------- #
> ## Dummy example 1:
> ##
> ## Fitting a random forest tvcm on artificially generated ordinal
> ## longitudinal data. The parameters 'maxstep = 1' and 'K = 2' are
> ## chosen to restrict the computations.
> ## ------------------------------------------------------------------- #
>
> ## load the data
>
> data(vcrpart_1)
>
> ## fit and analyse the model
>
> control <-
+ fvcolmm_control(mtry = 2, maxstep = 1,
+ folds = folds_control(type = "subsampling", K = 2, prob = 0.75))
>
> model.1 <-
+ fvcolmm(y ~ -1 + wave + vc(z3, z4, by = treat, intercept = TRUE) + re(1|id),
+ family = cumulative(), subset = 1:100,
+ data = vcrpart_1, control = control)
* fitting an initial tree ... OK
[ 1 ][ 2 ]
>
> ## estimating the out of bag loss
> suppressWarnings(oobloss(model.1))
[1] Inf
>
> ## predicting responses and varying coefficients for subject '27'
> subs <- vcrpart_1$id == "27"
>
> ## predict coefficients
> predict(model.1, newdata = vcrpart_1[subs,], type = "coef")
Eta1:(Intercept) Eta2:(Intercept) treat wave ranefCholFac1
105 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
106 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
107 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
108 -2.812295 0.1968348 1.481318 0.2515896 1.617485
>
> ## marginal response prediction
> predict(model.1, vcrpart_1[subs,], "response", ranef = FALSE)
1 2 3
105 0.64487105 0.3030852 0.05204376
106 0.05173905 0.3021793 0.64608161
107 0.05963581 0.3241881 0.61617604
108 0.08089282 0.4062962 0.51281095
>
> ## conditional response prediction
> re <- matrix(5, 1, 1, dimnames = list("27", "(Intercept)"))
> predict(model.1, vcrpart_1[subs,], "response", ranef = re)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
vcrpart
--- call from context ---
predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- call from argument ---
if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.")
--- R stacktrace ---
where 1: predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
where 2: predict(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (object, newdata = NULL, type = c("link", "response",
"prob", "class", "coef", "ranef"), ranef = FALSE, na.action = na.pass,
verbose = FALSE, ...)
{
type <- match.arg(type)
if (type == "prob")
type = "response"
if (!is.null(newdata) && !is.data.frame(newdata))
stop("'newdata' must be a 'data.frame'.")
if (!class(ranef) %in% c("logical", "matrix"))
stop("'ranef' must be a 'logical' or a 'matrix'.")
if (!is.null(newdata) && is.logical(ranef) && ranef)
stop("'ranef' should be 'FALSE' or a 'matrix' if 'newdata' is ",
"not 'NULL'.")
if (type == "ranef" & (!is.logical(ranef) | is.logical(ranef) &&
ranef))
stop("for 'type = 'ranef'' the argument 'ranef' must be 'FALSE'.")
if (type == "ranef" & !is.null(newdata))
stop("prediction for random effects for 'newdata' is not ",
"implemented.")
oob <- if (!is.null(list(...)$oob))
list(...)$oob
else FALSE
if (oob && !is.null(newdata))
stop("'oob' should be 'FALSE' if 'newdata' is not 'NULL'")
class(object) <- class(object)[-1L]
md <- object$info$data
dummymodel <- object$info$model
if (is.null(newdata))
newdata <- md
folds <- if (oob) {
object$info$folds
}
else {
matrix(1L, nrow(newdata), length(object$info$forest))
}
formList <- object$info$formula
rootForm <- tvcm_formula(formList, rep(TRUE, length(formList$vc)),
object$info$family)$full
formList <- vcrpart_formula(rootForm, object$info$family)
yName <- all.vars(lhs(formList$original))
yLevs <- if (object$info$fit == "olmm")
levels(md[, yName])
else yName
nYLevs <- length(yLevs)
if (type != "coef") {
if (!yName %in% colnames(newdata))
newdata[, yName] <- sample(md[, yName], nrow(newdata),
replace = TRUE)
feVars <- unlist(lapply(formList$fe$eta, all.vars))
if (!all(subs <- feVars %in% colnames(newdata)))
stop("variable(s) ", paste("'", feVars[!subs], "'",
collapse = ", "), " are not available in 'newdata'.")
reVars <- unlist(lapply(unlist(formList$re[c("eta", "cond")]),
all.vars))
if (length(reVars) > 0L) {
if (is.logical(ranef) && ranef | is.matrix(ranef)) {
if (!all(subs <- reVars %in% colnames(newdata)))
stop("variables ", feVars[!subs], " are not available in 'newdata'.")
}
else {
for (var in reVars) newdata[, var] <- sample(md[,
var], nrow(newdata), replace = TRUE)
}
}
Terms <- attr(md, "terms")
xlevels <- .getXlevels(attr(md, "terms"), md)
if (is.matrix(ranef)) {
subjectName <- dummymodel$subjectName
xlevels <- xlevels[names(xlevels) != subjectName]
}
newdata <- as.data.frame(model.frame(Terms, newdata,
na.action = na.pass, xlev = xlevels))
attr(newdata, "terms") <- NULL
}
if (verbose)
cat("* predicting the coefficient functions ... ")
nEta <- if (object$info$fit == "olmm")
nYLevs - 1L
else 1L
etaLabs <- paste("Eta", 1L:nEta, sep = "")
coef <- count <- 0 * predict(object, newdata, type = "coef")
rownames(coef) <- rownames(newdata)
subs <- matrix(TRUE, nrow(coef), ncol(coef), dimnames = list(rownames(coef),
colnames(coef)))
for (i in seq_along(object$info$forest)) {
if (verbose)
cat(".")
object$info$node <- object$info$forest[[i]]
object$info$model$coefficients <- object$info$coefficients[[i]]
object$info$model$contrasts <- object$info$contrasts[[i]]
coefi <- predict(object, newdata = newdata, type = "coef",
ranef = FALSE, na.action = na.pass, ...)
if (!is.matrix(coefi))
coefi <- matrix(coefi, nrow = nrow(newdata))
if (object$info$fit == "olmm" && ncol(coefi) < ncol(coef)) {
subsiCols <- table(md[folds[, i] > 0, yName]) > 0L
subsiCols <- subsiCols[-length(subsiCols)]
etaLabsShould <- etaLabs[subsiCols]
colnamesi <- colnames(coefi)
etaLabsIs <- grep("Eta[1-9]+:", colnamesi, value = TRUE)
etaLabsIs <- unique(sapply(strsplit(etaLabsIs, ":"),
function(x) x[1]))
colnamesi <- strsplit(colnamesi, ":")
for (j in rev(seq_along(etaLabsIs))) {
colnamesi <- lapply(colnamesi, function(x) {
if (x[1L] == etaLabsIs[j])
x[1L] <- etaLabsShould[j]
return(x)
})
}
colnamesi <- sapply(colnamesi, function(x) paste(x,
collapse = ":"))
colnames(coefi) <- colnamesi
}
coefi <- coefi[, intersect(colnames(coef), colnames(coefi)),
drop = FALSE]
subsi <- subs
if (oob)
subsi[folds[, i] > 0L, ] <- FALSE
subsi[is.na(coefi)] <- FALSE
coef[subsi] <- coef[subsi] + coefi[subsi]
count <- count + 1 * subsi
}
if (verbose)
cat(" OK\n")
coef <- coef/count
coef[apply(count, 1, function(x) any(x == 0)), ] <- NA
if (length(setdiff(names(coef(dummymodel)), colnames(coef))) >
0 | length(setdiff(colnames(coef), names(coef(dummymodel)))) >
0)
stop("ups. This shouldn't happen. Please contact the author of this package and ",
"indicate to have problems with 'fvcm.predict'.")
coef <- coef[, match(names(coef(dummymodel)), colnames(coef)),
drop = FALSE]
if (type == "coef")
return(na.action(coef))
if (object$info$fit == "olmm") {
X <- olmm_merge_mm(model.matrix(terms(formList$fe$eta$ce,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), model.matrix(terms(formList$fe$eta$ge,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), TRUE)
}
else {
X <- model.matrix(terms(rootForm), newdata, dummymodel$contrasts)
}
if (object$info$fit == "olmm") {
coef <- coef[, substr(colnames(coef), 1, 12) != "ranefCholFac",
drop = FALSE]
dims <- dummymodel$dims
fixefMat <- function(fixef) {
return(rbind(matrix(fixef[1:(dims["pCe"] * dims["nEta"])],
dims["pCe"], dims["nEta"], byrow = FALSE), if (dims["pGe"] >
0) matrix(rep(fixef[(dims["pCe"] * dims["nEta"] +
1):dims["p"]], each = dims["nEta"]), dims["pGe"],
dims["nEta"], byrow = TRUE) else NULL))
}
eta <- sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% fixefMat(coef[i, ])
})
if (dims["nEta"] == 1)
eta <- matrix(eta, ncol = 1)
else eta <- t(eta)
colnames(eta) <- etaLabs
rownames(eta) <- rownames(newdata)
}
else {
eta <- t(sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% coef[i, ]
}))
eta <- matrix(eta, ncol = 1L)
}
if (type == "link") {
if (object$info$fit != "olmm")
eta <- c(eta)
return(na.action(eta))
}
start <- NULL
if (object$info$fit == "olmm") {
terms <- "fe(intercept=FALSE)"
mTerms <- terms(object$info$formula$original, specials = "re")
if (length(subs <- attr(mTerms, "specials")$re) > 0L) {
terms <- c(terms, rownames(attr(mTerms, "factors"))[subs])
reTerms <- grep("ranefCholFac", names(object$info$coefficients[[1L]]),
value = TRUE)
start <- sapply(seq_along(object$info$coefficients),
function(i) object$info$coefficients[[i]][reTerms])
start <- apply(matrix(start, ncol = length(reTerms)),
2L, mean)
names(start) <- reTerms
}
}
else {
terms <- "-1"
}
form <- as.formula(paste(yName, "~", paste(terms, collapse = "+")))
if (is.factor(newdata[, yName]) && length(unique(newdata[,
yName])) < nYLevs) {
subs <- nrow(newdata) + 1L:nYLevs
newdata <- rbind(newdata, newdata[rep(1L, nYLevs), ,
drop = FALSE])
newdata[subs, yName] <- yLevs
if (object$info$fit == "olmm") {
sN <- object$info$model$subjectName
levs <- c(levels(newdata[, sN]), "RetoBuergin")
newdata[sN] <- factor(newdata[, sN], levels = levs)
newdata[subs, sN] <- "RetoBuergin"
}
eta <- rbind(eta, matrix(0, nYLevs, ncol(eta)))
folds <- rbind(folds, matrix(-1L, nYLevs, length(object$info$forest)))
}
offset <- eta
offset[is.na(offset)] <- 0
oobCall <- call(name = object$info$fit, form = quote(form),
data = quote(newdata), offset = quote(offset), family = quote(object$info$family),
start = quote(start), na.action = na.pass)
for (arg in names(object$info$dotargs)) oobCall[[arg]] <- object$info$dotargs[[arg]]
oobCall <- oobCall[!duplicated(names(oobCall))]
if (object$info$fit == "olmm")
oobCall$doFit <- FALSE
model <- suppressWarnings(eval(oobCall))
if (type == "ranef") {
ranef <- ranef(model)
ranef <- ranef[rownames(ranef) != "RetoBuergin", , drop = FALSE]
return(na.action(ranef))
}
else {
if (is.matrix(ranef)) {
ranefMat <- ranef(model)
ranefMat[rownames(ranef), ] <- ranef
ranef <- ranefMat
}
pred <- predict(model, type = type, ranef = ranef, ...)
if (!is.matrix(pred))
pred <- matrix(pred, nrow = nrow(newdata))
pred[apply(eta, 1, function(x) any(is.na(x))), ] <- NA
pred <- pred[folds[, 1] >= 0L, , drop = FALSE]
}
folds <- folds[folds[, 1] >= 0L, , drop = FALSE]
if (oob)
pred[apply(folds, 1L, function(x) all(x == 0L)), ] <- NA
if (object$info$fit != "olmm")
pred <- c(pred)
return(na.action(pred))
}
<bytecode: 0xc5c70e8>
<environment: namespace:vcrpart>
--- function search by body ---
Function predict.fvcm in namespace vcrpart has this body.
----------- END OF FAILURE REPORT --------------
Error in if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.") :
the condition has length > 1
Calls: predict -> predict.fvcm
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 1.0-2
Check: examples
Result: ERROR
Running examples in ‘vcrpart-Ex.R’ failed
The error most likely occurred in:
> ### Name: fvcm-methods
> ### Title: Methods for 'fvcm' objects
> ### Aliases: fvcm-methods fitted.fvcm print.fvcm oobloss.fvcm plot.fvcm
> ### predict.fvcm print.fvcm ranef.fvcm
> ### Keywords: methods hplot
>
> ### ** Examples
>
>
> ## ------------------------------------------------------------------- #
> ## Dummy example 1:
> ##
> ## Fitting a random forest tvcm on artificially generated ordinal
> ## longitudinal data. The parameters 'maxstep = 1' and 'K = 2' are
> ## chosen to restrict the computations.
> ## ------------------------------------------------------------------- #
>
> ## load the data
>
> data(vcrpart_1)
>
> ## fit and analyse the model
>
> control <-
+ fvcolmm_control(mtry = 2, maxstep = 1,
+ folds = folds_control(type = "subsampling", K = 2, prob = 0.75))
>
> model.1 <-
+ fvcolmm(y ~ -1 + wave + vc(z3, z4, by = treat, intercept = TRUE) + re(1|id),
+ family = cumulative(), subset = 1:100,
+ data = vcrpart_1, control = control)
* fitting an initial tree ... OK
[ 1 ][ 2 ]
>
> ## estimating the out of bag loss
> suppressWarnings(oobloss(model.1))
[1] Inf
>
> ## predicting responses and varying coefficients for subject '27'
> subs <- vcrpart_1$id == "27"
>
> ## predict coefficients
> predict(model.1, newdata = vcrpart_1[subs,], type = "coef")
Eta1:(Intercept) Eta2:(Intercept) treat wave ranefCholFac1
105 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
106 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
107 -3.209406 -0.3906967 2.835036 0.2515896 1.617485
108 -2.812295 0.1968348 1.481318 0.2515896 1.617485
>
> ## marginal response prediction
> predict(model.1, vcrpart_1[subs,], "response", ranef = FALSE)
1 2 3
105 0.64487105 0.3030852 0.05204376
106 0.05173905 0.3021793 0.64608161
107 0.05963581 0.3241881 0.61617604
108 0.08089282 0.4062962 0.51281095
>
> ## conditional response prediction
> re <- matrix(5, 1, 1, dimnames = list("27", "(Intercept)"))
> predict(model.1, vcrpart_1[subs,], "response", ranef = re)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
vcrpart
--- call from context ---
predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- call from argument ---
if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.")
--- R stacktrace ---
where 1: predict.fvcm(model.1, vcrpart_1[subs, ], "response", ranef = re)
where 2: predict(model.1, vcrpart_1[subs, ], "response", ranef = re)
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (object, newdata = NULL, type = c("link", "response",
"prob", "class", "coef", "ranef"), ranef = FALSE, na.action = na.pass,
verbose = FALSE, ...)
{
type <- match.arg(type)
if (type == "prob")
type = "response"
if (!is.null(newdata) && !is.data.frame(newdata))
stop("'newdata' must be a 'data.frame'.")
if (!class(ranef) %in% c("logical", "matrix"))
stop("'ranef' must be a 'logical' or a 'matrix'.")
if (!is.null(newdata) && is.logical(ranef) && ranef)
stop("'ranef' should be 'FALSE' or a 'matrix' if 'newdata' is ",
"not 'NULL'.")
if (type == "ranef" & (!is.logical(ranef) | is.logical(ranef) &&
ranef))
stop("for 'type = 'ranef'' the argument 'ranef' must be 'FALSE'.")
if (type == "ranef" & !is.null(newdata))
stop("prediction for random effects for 'newdata' is not ",
"implemented.")
oob <- if (!is.null(list(...)$oob))
list(...)$oob
else FALSE
if (oob && !is.null(newdata))
stop("'oob' should be 'FALSE' if 'newdata' is not 'NULL'")
class(object) <- class(object)[-1L]
md <- object$info$data
dummymodel <- object$info$model
if (is.null(newdata))
newdata <- md
folds <- if (oob) {
object$info$folds
}
else {
matrix(1L, nrow(newdata), length(object$info$forest))
}
formList <- object$info$formula
rootForm <- tvcm_formula(formList, rep(TRUE, length(formList$vc)),
object$info$family)$full
formList <- vcrpart_formula(rootForm, object$info$family)
yName <- all.vars(lhs(formList$original))
yLevs <- if (object$info$fit == "olmm")
levels(md[, yName])
else yName
nYLevs <- length(yLevs)
if (type != "coef") {
if (!yName %in% colnames(newdata))
newdata[, yName] <- sample(md[, yName], nrow(newdata),
replace = TRUE)
feVars <- unlist(lapply(formList$fe$eta, all.vars))
if (!all(subs <- feVars %in% colnames(newdata)))
stop("variable(s) ", paste("'", feVars[!subs], "'",
collapse = ", "), " are not available in 'newdata'.")
reVars <- unlist(lapply(unlist(formList$re[c("eta", "cond")]),
all.vars))
if (length(reVars) > 0L) {
if (is.logical(ranef) && ranef | is.matrix(ranef)) {
if (!all(subs <- reVars %in% colnames(newdata)))
stop("variables ", feVars[!subs], " are not available in 'newdata'.")
}
else {
for (var in reVars) newdata[, var] <- sample(md[,
var], nrow(newdata), replace = TRUE)
}
}
Terms <- attr(md, "terms")
xlevels <- .getXlevels(attr(md, "terms"), md)
if (is.matrix(ranef)) {
subjectName <- dummymodel$subjectName
xlevels <- xlevels[names(xlevels) != subjectName]
}
newdata <- as.data.frame(model.frame(Terms, newdata,
na.action = na.pass, xlev = xlevels))
attr(newdata, "terms") <- NULL
}
if (verbose)
cat("* predicting the coefficient functions ... ")
nEta <- if (object$info$fit == "olmm")
nYLevs - 1L
else 1L
etaLabs <- paste("Eta", 1L:nEta, sep = "")
coef <- count <- 0 * predict(object, newdata, type = "coef")
rownames(coef) <- rownames(newdata)
subs <- matrix(TRUE, nrow(coef), ncol(coef), dimnames = list(rownames(coef),
colnames(coef)))
for (i in seq_along(object$info$forest)) {
if (verbose)
cat(".")
object$info$node <- object$info$forest[[i]]
object$info$model$coefficients <- object$info$coefficients[[i]]
object$info$model$contrasts <- object$info$contrasts[[i]]
coefi <- predict(object, newdata = newdata, type = "coef",
ranef = FALSE, na.action = na.pass, ...)
if (!is.matrix(coefi))
coefi <- matrix(coefi, nrow = nrow(newdata))
if (object$info$fit == "olmm" && ncol(coefi) < ncol(coef)) {
subsiCols <- table(md[folds[, i] > 0, yName]) > 0L
subsiCols <- subsiCols[-length(subsiCols)]
etaLabsShould <- etaLabs[subsiCols]
colnamesi <- colnames(coefi)
etaLabsIs <- grep("Eta[1-9]+:", colnamesi, value = TRUE)
etaLabsIs <- unique(sapply(strsplit(etaLabsIs, ":"),
function(x) x[1]))
colnamesi <- strsplit(colnamesi, ":")
for (j in rev(seq_along(etaLabsIs))) {
colnamesi <- lapply(colnamesi, function(x) {
if (x[1L] == etaLabsIs[j])
x[1L] <- etaLabsShould[j]
return(x)
})
}
colnamesi <- sapply(colnamesi, function(x) paste(x,
collapse = ":"))
colnames(coefi) <- colnamesi
}
coefi <- coefi[, intersect(colnames(coef), colnames(coefi)),
drop = FALSE]
subsi <- subs
if (oob)
subsi[folds[, i] > 0L, ] <- FALSE
subsi[is.na(coefi)] <- FALSE
coef[subsi] <- coef[subsi] + coefi[subsi]
count <- count + 1 * subsi
}
if (verbose)
cat(" OK\n")
coef <- coef/count
coef[apply(count, 1, function(x) any(x == 0)), ] <- NA
if (length(setdiff(names(coef(dummymodel)), colnames(coef))) >
0 | length(setdiff(colnames(coef), names(coef(dummymodel)))) >
0)
stop("ups. This shouldn't happen. Please contact the author of this package and ",
"indicate to have problems with 'fvcm.predict'.")
coef <- coef[, match(names(coef(dummymodel)), colnames(coef)),
drop = FALSE]
if (type == "coef")
return(na.action(coef))
if (object$info$fit == "olmm") {
X <- olmm_merge_mm(model.matrix(terms(formList$fe$eta$ce,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), model.matrix(terms(formList$fe$eta$ge,
keep.order = TRUE), newdata, attr(object$info$model$X,
"contrasts")), TRUE)
}
else {
X <- model.matrix(terms(rootForm), newdata, dummymodel$contrasts)
}
if (object$info$fit == "olmm") {
coef <- coef[, substr(colnames(coef), 1, 12) != "ranefCholFac",
drop = FALSE]
dims <- dummymodel$dims
fixefMat <- function(fixef) {
return(rbind(matrix(fixef[1:(dims["pCe"] * dims["nEta"])],
dims["pCe"], dims["nEta"], byrow = FALSE), if (dims["pGe"] >
0) matrix(rep(fixef[(dims["pCe"] * dims["nEta"] +
1):dims["p"]], each = dims["nEta"]), dims["pGe"],
dims["nEta"], byrow = TRUE) else NULL))
}
eta <- sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% fixefMat(coef[i, ])
})
if (dims["nEta"] == 1)
eta <- matrix(eta, ncol = 1)
else eta <- t(eta)
colnames(eta) <- etaLabs
rownames(eta) <- rownames(newdata)
}
else {
eta <- t(sapply(1:nrow(newdata), function(i) {
X[i, , drop = FALSE] %*% coef[i, ]
}))
eta <- matrix(eta, ncol = 1L)
}
if (type == "link") {
if (object$info$fit != "olmm")
eta <- c(eta)
return(na.action(eta))
}
start <- NULL
if (object$info$fit == "olmm") {
terms <- "fe(intercept=FALSE)"
mTerms <- terms(object$info$formula$original, specials = "re")
if (length(subs <- attr(mTerms, "specials")$re) > 0L) {
terms <- c(terms, rownames(attr(mTerms, "factors"))[subs])
reTerms <- grep("ranefCholFac", names(object$info$coefficients[[1L]]),
value = TRUE)
start <- sapply(seq_along(object$info$coefficients),
function(i) object$info$coefficients[[i]][reTerms])
start <- apply(matrix(start, ncol = length(reTerms)),
2L, mean)
names(start) <- reTerms
}
}
else {
terms <- "-1"
}
form <- as.formula(paste(yName, "~", paste(terms, collapse = "+")))
if (is.factor(newdata[, yName]) && length(unique(newdata[,
yName])) < nYLevs) {
subs <- nrow(newdata) + 1L:nYLevs
newdata <- rbind(newdata, newdata[rep(1L, nYLevs), ,
drop = FALSE])
newdata[subs, yName] <- yLevs
if (object$info$fit == "olmm") {
sN <- object$info$model$subjectName
levs <- c(levels(newdata[, sN]), "RetoBuergin")
newdata[sN] <- factor(newdata[, sN], levels = levs)
newdata[subs, sN] <- "RetoBuergin"
}
eta <- rbind(eta, matrix(0, nYLevs, ncol(eta)))
folds <- rbind(folds, matrix(-1L, nYLevs, length(object$info$forest)))
}
offset <- eta
offset[is.na(offset)] <- 0
oobCall <- call(name = object$info$fit, form = quote(form),
data = quote(newdata), offset = quote(offset), family = quote(object$info$family),
start = quote(start), na.action = na.pass)
for (arg in names(object$info$dotargs)) oobCall[[arg]] <- object$info$dotargs[[arg]]
oobCall <- oobCall[!duplicated(names(oobCall))]
if (object$info$fit == "olmm")
oobCall$doFit <- FALSE
model <- suppressWarnings(eval(oobCall))
if (type == "ranef") {
ranef <- ranef(model)
ranef <- ranef[rownames(ranef) != "RetoBuergin", , drop = FALSE]
return(na.action(ranef))
}
else {
if (is.matrix(ranef)) {
ranefMat <- ranef(model)
ranefMat[rownames(ranef), ] <- ranef
ranef <- ranefMat
}
pred <- predict(model, type = type, ranef = ranef, ...)
if (!is.matrix(pred))
pred <- matrix(pred, nrow = nrow(newdata))
pred[apply(eta, 1, function(x) any(is.na(x))), ] <- NA
pred <- pred[folds[, 1] >= 0L, , drop = FALSE]
}
folds <- folds[folds[, 1] >= 0L, , drop = FALSE]
if (oob)
pred[apply(folds, 1L, function(x) all(x == 0L)), ] <- NA
if (object$info$fit != "olmm")
pred <- c(pred)
return(na.action(pred))
}
<bytecode: 0xd347220>
<environment: namespace:vcrpart>
--- function search by body ---
Function predict.fvcm in namespace vcrpart has this body.
----------- END OF FAILURE REPORT --------------
Error in if (!class(ranef) %in% c("logical", "matrix")) stop("'ranef' must be a 'logical' or a 'matrix'.") :
the condition has length > 1
Calls: predict -> predict.fvcm
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc