Last updated on 2020-02-19 10:49:13 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.1 | 2.39 | 21.39 | 23.78 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 1.1 | 1.73 | 16.94 | 18.67 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 1.1 | 29.01 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 1.1 | 29.42 | ERROR | |||
| r-devel-windows-ix86+x86_64 | 1.1 | 5.00 | 43.00 | 48.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 1.1 | 9.00 | 56.00 | 65.00 | OK | |
| r-patched-linux-x86_64 | 1.1 | 1.57 | 21.09 | 22.66 | OK | |
| r-patched-solaris-x86 | 1.1 | 42.80 | OK | |||
| r-release-linux-x86_64 | 1.1 | 1.78 | 21.51 | 23.29 | OK | |
| r-release-windows-ix86+x86_64 | 1.1 | 5.00 | 41.00 | 46.00 | OK | |
| r-release-osx-x86_64 | 1.1 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 1.1 | 2.00 | 30.00 | 32.00 | OK | |
| r-oldrel-osx-x86_64 | 1.1 | OK |
Version: 1.1
Check: examples
Result: ERROR
Running examples in 'TEEReg-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: TEE.BCa
> ### Title: Compute the bias-corrected accelerated bootstrap confidence
> ### intervals.
> ### Aliases: TEE.BCa
> ### Keywords: TEE.BCa TEEReg TEE
>
> ### ** Examples
>
> data(telephone)
> fit <- TEE(formula=Y~X,data=telephone,p.trimmed=0.5,p.subsample=0.5,method="tee")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TEEReg
--- call from context ---
TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- call from argument ---
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*% ((1/Xsvd$d[Positive]) *
t(Xsvd$u[, Positive, drop = FALSE]))
}
} else if (nonsingular == "TRUE") {
hat <- solve(X)
}
--- R stacktrace ---
where 1: TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (formula, data, offset = NULL, p.trimmed = NULL, p.subsample = 1,
method = "tee")
{
if (missing(formula)) {
stop("'formula' must be provided.")
}
if (missing(data)) {
stop("'data' must be provided.")
}
if (method != "ols" & method != "tee") {
stop(gettextf("invalid 'method' argument, method = '%s' is not supported. Using 'tee' or 'ols'.",
method), domain = NA)
}
if (is.null(p.trimmed) & method == "tee") {
stop("'p.trimmed' must be provided when 'method' is 'tee'.")
}
if (!is.null(p.trimmed)) {
if (!is.numeric(p.trimmed)) {
stop("'p.trimmed' must be numeric.")
}
else if (p.trimmed >= 1 | p.trimmed < 0) {
stop("invalid 'p.trimmed' argument.")
}
}
if (!is.numeric(p.subsample)) {
stop("'p.subsample' must be numeric.")
}
else if (p.subsample > 1 | p.subsample <= 0) {
stop("invalid 'p.subsample' argument.")
}
mcall <- match.call(expand.dots = FALSE)
mat <- match(c("formula", "data", "offset"), names(mcall),
0L)
mcall <- mcall[c(1L, mat)]
mcall$drop.unused.levels <- TRUE
mcall[[1L]] <- quote(stats::model.frame)
mcall <- eval(mcall, parent.frame())
mcallt <- attr(mcall, "terms")
if (!is.null(offset)) {
if (length(offset) != nrow(data)) {
stop(gettextf("number of offsets is %d, should equal %d (number of observations).",
length(offset), nrow(data)), domain = NA)
}
else {
offset <- as.vector(model.offset(mcall))
}
}
Yall <- model.response(mcall, "any")
if (is.empty.model(mcallt)) {
Xall <- NULL
output <- list(coefficients = if (is.matrix(Yall)) matrix(,
0, 3) else numeric(), residuals = Yall, fitted.values = 0 *
Yall, rank = 0L)
if (is.null(offset)) {
output$fitted.values <- offset
output$residuals <- Yall - offset
}
print(list(output))
stop("no parameters need to be estimated.")
}
else {
Xall <- model.matrix(mcallt, mcall)
names <- colnames(Xall)
}
if (method == "ols") {
callt <- match.call()
c <- match(c("formula", "data", "offset", "method"),
names(callt), 0L)
callt <- callt[c(1L, c)]
nonsingular <- class(try(solve(t(Xall) %*% Xall), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
warning("Matrix is singular, generalized inverse is used.")
tol = sqrt(.Machine$double.eps)
XpXsvd <- svd(t(Xall) %*% Xall)
Positive <- XpXsvd$d > max(tol * XpXsvd$d[1L], 0)
if (all(Positive)) {
hat <- XpXsvd$v %*% (1/XpXsvd$d * t(XpXsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(Xall)[2L:1L])
}
else {
hat <- XpXsvd$v[, Positive, drop = FALSE] %*%
((1/XpXsvd$d[Positive]) * t(XpXsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(t(Xall) %*% Xall)
}
if (!is.null(offset)) {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% (Yall -
offset)))
}
else {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% Yall))
}
}
else if (method == "tee") {
samplesize <- length(Yall)
p <- ncol(Xall)
index <- combn(samplesize, p)
k <- ncol(index)
set.seed(23211342)
s <- ceiling(p.subsample * k)
subset <- as.matrix(index[, sample(1:k, s, replace = FALSE)])
beta.h <- matrix(NA, nrow = p, ncol = s)
det.XhXh <- c()
sum.abse <- c()
r <- round((1 - p.trimmed) * s)
for (i in 1:s) {
Y <- Yall[subset[, i]]
X <- Xall[subset[, i], ]
nonsingular <- class(try(solve(X), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*%
((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(X)
}
if (!is.null(offset)) {
beta.h[, i] <- hat %*% (Y - offset[subset[, i]])
}
else {
beta.h[, i] <- hat %*% Y
}
det.XhXh[i] <- det(t(X) %*% X)
sum.abse[i] <- sum(abs(Yall - Xall %*% beta.h[, i]))
}
callt <- match.call()
pho <- c()
rank.err <- rank(sum.abse)
for (j in 1:s) {
if (rank.err[j] <= r) {
pho[j] <- 1
}
else {
pho[j] <- 0
}
}
TEE.est <- as.matrix(t(rowSums(t(matrix(c(det.XhXh *
pho), nrow = s, ncol = p)) * beta.h)/sum(det.XhXh *
pho)))
}
colnames(TEE.est) <- c(names)
rownames(TEE.est) <- ""
resid <- if (is.null(offset)) {
Yall - Xall %*% t(TEE.est)
}
else {
Yall - (Xall %*% t(TEE.est) + offset)
}
fitted <- if (is.null(offset)) {
Xall %*% t(TEE.est)
}
else {
Xall %*% t(TEE.est) + offset
}
output <- list(call = callt, formula = formula, coefficients = TEE.est,
residuals = t(resid), fitted.values = t(fitted))
return(output)
}
<bytecode: 0x394fb78>
<environment: namespace:TEEReg>
--- function search by body ---
Function TEE in namespace TEEReg has this body.
----------- END OF FAILURE REPORT --------------
Error in if (nonsingular == "FALSE") { : the condition has length > 1
Calls: TEE
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.1
Check: examples
Result: ERROR
Running examples in ‘TEEReg-Ex.R’ failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: TEE.BCa
> ### Title: Compute the bias-corrected accelerated bootstrap confidence
> ### intervals.
> ### Aliases: TEE.BCa
> ### Keywords: TEE.BCa TEEReg TEE
>
> ### ** Examples
>
> data(telephone)
> fit <- TEE(formula=Y~X,data=telephone,p.trimmed=0.5,p.subsample=0.5,method="tee")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TEEReg
--- call from context ---
TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- call from argument ---
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*% ((1/Xsvd$d[Positive]) *
t(Xsvd$u[, Positive, drop = FALSE]))
}
} else if (nonsingular == "TRUE") {
hat <- solve(X)
}
--- R stacktrace ---
where 1: TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (formula, data, offset = NULL, p.trimmed = NULL, p.subsample = 1,
method = "tee")
{
if (missing(formula)) {
stop("'formula' must be provided.")
}
if (missing(data)) {
stop("'data' must be provided.")
}
if (method != "ols" & method != "tee") {
stop(gettextf("invalid 'method' argument, method = '%s' is not supported. Using 'tee' or 'ols'.",
method), domain = NA)
}
if (is.null(p.trimmed) & method == "tee") {
stop("'p.trimmed' must be provided when 'method' is 'tee'.")
}
if (!is.null(p.trimmed)) {
if (!is.numeric(p.trimmed)) {
stop("'p.trimmed' must be numeric.")
}
else if (p.trimmed >= 1 | p.trimmed < 0) {
stop("invalid 'p.trimmed' argument.")
}
}
if (!is.numeric(p.subsample)) {
stop("'p.subsample' must be numeric.")
}
else if (p.subsample > 1 | p.subsample <= 0) {
stop("invalid 'p.subsample' argument.")
}
mcall <- match.call(expand.dots = FALSE)
mat <- match(c("formula", "data", "offset"), names(mcall),
0L)
mcall <- mcall[c(1L, mat)]
mcall$drop.unused.levels <- TRUE
mcall[[1L]] <- quote(stats::model.frame)
mcall <- eval(mcall, parent.frame())
mcallt <- attr(mcall, "terms")
if (!is.null(offset)) {
if (length(offset) != nrow(data)) {
stop(gettextf("number of offsets is %d, should equal %d (number of observations).",
length(offset), nrow(data)), domain = NA)
}
else {
offset <- as.vector(model.offset(mcall))
}
}
Yall <- model.response(mcall, "any")
if (is.empty.model(mcallt)) {
Xall <- NULL
output <- list(coefficients = if (is.matrix(Yall)) matrix(,
0, 3) else numeric(), residuals = Yall, fitted.values = 0 *
Yall, rank = 0L)
if (is.null(offset)) {
output$fitted.values <- offset
output$residuals <- Yall - offset
}
print(list(output))
stop("no parameters need to be estimated.")
}
else {
Xall <- model.matrix(mcallt, mcall)
names <- colnames(Xall)
}
if (method == "ols") {
callt <- match.call()
c <- match(c("formula", "data", "offset", "method"),
names(callt), 0L)
callt <- callt[c(1L, c)]
nonsingular <- class(try(solve(t(Xall) %*% Xall), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
warning("Matrix is singular, generalized inverse is used.")
tol = sqrt(.Machine$double.eps)
XpXsvd <- svd(t(Xall) %*% Xall)
Positive <- XpXsvd$d > max(tol * XpXsvd$d[1L], 0)
if (all(Positive)) {
hat <- XpXsvd$v %*% (1/XpXsvd$d * t(XpXsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(Xall)[2L:1L])
}
else {
hat <- XpXsvd$v[, Positive, drop = FALSE] %*%
((1/XpXsvd$d[Positive]) * t(XpXsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(t(Xall) %*% Xall)
}
if (!is.null(offset)) {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% (Yall -
offset)))
}
else {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% Yall))
}
}
else if (method == "tee") {
samplesize <- length(Yall)
p <- ncol(Xall)
index <- combn(samplesize, p)
k <- ncol(index)
set.seed(23211342)
s <- ceiling(p.subsample * k)
subset <- as.matrix(index[, sample(1:k, s, replace = FALSE)])
beta.h <- matrix(NA, nrow = p, ncol = s)
det.XhXh <- c()
sum.abse <- c()
r <- round((1 - p.trimmed) * s)
for (i in 1:s) {
Y <- Yall[subset[, i]]
X <- Xall[subset[, i], ]
nonsingular <- class(try(solve(X), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*%
((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(X)
}
if (!is.null(offset)) {
beta.h[, i] <- hat %*% (Y - offset[subset[, i]])
}
else {
beta.h[, i] <- hat %*% Y
}
det.XhXh[i] <- det(t(X) %*% X)
sum.abse[i] <- sum(abs(Yall - Xall %*% beta.h[, i]))
}
callt <- match.call()
pho <- c()
rank.err <- rank(sum.abse)
for (j in 1:s) {
if (rank.err[j] <= r) {
pho[j] <- 1
}
else {
pho[j] <- 0
}
}
TEE.est <- as.matrix(t(rowSums(t(matrix(c(det.XhXh *
pho), nrow = s, ncol = p)) * beta.h)/sum(det.XhXh *
pho)))
}
colnames(TEE.est) <- c(names)
rownames(TEE.est) <- ""
resid <- if (is.null(offset)) {
Yall - Xall %*% t(TEE.est)
}
else {
Yall - (Xall %*% t(TEE.est) + offset)
}
fitted <- if (is.null(offset)) {
Xall %*% t(TEE.est)
}
else {
Xall %*% t(TEE.est) + offset
}
output <- list(call = callt, formula = formula, coefficients = TEE.est,
residuals = t(resid), fitted.values = t(fitted))
return(output)
}
<bytecode: 0x559cc5479fd8>
<environment: namespace:TEEReg>
--- function search by body ---
Function TEE in namespace TEEReg has this body.
----------- END OF FAILURE REPORT --------------
Error in if (nonsingular == "FALSE") { : the condition has length > 1
Calls: TEE
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 1.1
Check: examples
Result: ERROR
Running examples in ‘TEEReg-Ex.R’ failed
The error most likely occurred in:
> ### Name: TEE.BCa
> ### Title: Compute the bias-corrected accelerated bootstrap confidence
> ### intervals.
> ### Aliases: TEE.BCa
> ### Keywords: TEE.BCa TEEReg TEE
>
> ### ** Examples
>
> data(telephone)
> fit <- TEE(formula=Y~X,data=telephone,p.trimmed=0.5,p.subsample=0.5,method="tee")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TEEReg
--- call from context ---
TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- call from argument ---
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*% ((1/Xsvd$d[Positive]) *
t(Xsvd$u[, Positive, drop = FALSE]))
}
} else if (nonsingular == "TRUE") {
hat <- solve(X)
}
--- R stacktrace ---
where 1: TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (formula, data, offset = NULL, p.trimmed = NULL, p.subsample = 1,
method = "tee")
{
if (missing(formula)) {
stop("'formula' must be provided.")
}
if (missing(data)) {
stop("'data' must be provided.")
}
if (method != "ols" & method != "tee") {
stop(gettextf("invalid 'method' argument, method = '%s' is not supported. Using 'tee' or 'ols'.",
method), domain = NA)
}
if (is.null(p.trimmed) & method == "tee") {
stop("'p.trimmed' must be provided when 'method' is 'tee'.")
}
if (!is.null(p.trimmed)) {
if (!is.numeric(p.trimmed)) {
stop("'p.trimmed' must be numeric.")
}
else if (p.trimmed >= 1 | p.trimmed < 0) {
stop("invalid 'p.trimmed' argument.")
}
}
if (!is.numeric(p.subsample)) {
stop("'p.subsample' must be numeric.")
}
else if (p.subsample > 1 | p.subsample <= 0) {
stop("invalid 'p.subsample' argument.")
}
mcall <- match.call(expand.dots = FALSE)
mat <- match(c("formula", "data", "offset"), names(mcall),
0L)
mcall <- mcall[c(1L, mat)]
mcall$drop.unused.levels <- TRUE
mcall[[1L]] <- quote(stats::model.frame)
mcall <- eval(mcall, parent.frame())
mcallt <- attr(mcall, "terms")
if (!is.null(offset)) {
if (length(offset) != nrow(data)) {
stop(gettextf("number of offsets is %d, should equal %d (number of observations).",
length(offset), nrow(data)), domain = NA)
}
else {
offset <- as.vector(model.offset(mcall))
}
}
Yall <- model.response(mcall, "any")
if (is.empty.model(mcallt)) {
Xall <- NULL
output <- list(coefficients = if (is.matrix(Yall)) matrix(,
0, 3) else numeric(), residuals = Yall, fitted.values = 0 *
Yall, rank = 0L)
if (is.null(offset)) {
output$fitted.values <- offset
output$residuals <- Yall - offset
}
print(list(output))
stop("no parameters need to be estimated.")
}
else {
Xall <- model.matrix(mcallt, mcall)
names <- colnames(Xall)
}
if (method == "ols") {
callt <- match.call()
c <- match(c("formula", "data", "offset", "method"),
names(callt), 0L)
callt <- callt[c(1L, c)]
nonsingular <- class(try(solve(t(Xall) %*% Xall), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
warning("Matrix is singular, generalized inverse is used.")
tol = sqrt(.Machine$double.eps)
XpXsvd <- svd(t(Xall) %*% Xall)
Positive <- XpXsvd$d > max(tol * XpXsvd$d[1L], 0)
if (all(Positive)) {
hat <- XpXsvd$v %*% (1/XpXsvd$d * t(XpXsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(Xall)[2L:1L])
}
else {
hat <- XpXsvd$v[, Positive, drop = FALSE] %*%
((1/XpXsvd$d[Positive]) * t(XpXsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(t(Xall) %*% Xall)
}
if (!is.null(offset)) {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% (Yall -
offset)))
}
else {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% Yall))
}
}
else if (method == "tee") {
samplesize <- length(Yall)
p <- ncol(Xall)
index <- combn(samplesize, p)
k <- ncol(index)
set.seed(23211342)
s <- ceiling(p.subsample * k)
subset <- as.matrix(index[, sample(1:k, s, replace = FALSE)])
beta.h <- matrix(NA, nrow = p, ncol = s)
det.XhXh <- c()
sum.abse <- c()
r <- round((1 - p.trimmed) * s)
for (i in 1:s) {
Y <- Yall[subset[, i]]
X <- Xall[subset[, i], ]
nonsingular <- class(try(solve(X), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*%
((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(X)
}
if (!is.null(offset)) {
beta.h[, i] <- hat %*% (Y - offset[subset[, i]])
}
else {
beta.h[, i] <- hat %*% Y
}
det.XhXh[i] <- det(t(X) %*% X)
sum.abse[i] <- sum(abs(Yall - Xall %*% beta.h[, i]))
}
callt <- match.call()
pho <- c()
rank.err <- rank(sum.abse)
for (j in 1:s) {
if (rank.err[j] <= r) {
pho[j] <- 1
}
else {
pho[j] <- 0
}
}
TEE.est <- as.matrix(t(rowSums(t(matrix(c(det.XhXh *
pho), nrow = s, ncol = p)) * beta.h)/sum(det.XhXh *
pho)))
}
colnames(TEE.est) <- c(names)
rownames(TEE.est) <- ""
resid <- if (is.null(offset)) {
Yall - Xall %*% t(TEE.est)
}
else {
Yall - (Xall %*% t(TEE.est) + offset)
}
fitted <- if (is.null(offset)) {
Xall %*% t(TEE.est)
}
else {
Xall %*% t(TEE.est) + offset
}
output <- list(call = callt, formula = formula, coefficients = TEE.est,
residuals = t(resid), fitted.values = t(fitted))
return(output)
}
<bytecode: 0x22faf40>
<environment: namespace:TEEReg>
--- function search by body ---
Function TEE in namespace TEEReg has this body.
----------- END OF FAILURE REPORT --------------
Error in if (nonsingular == "FALSE") { : the condition has length > 1
Calls: TEE
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 1.1
Check: examples
Result: ERROR
Running examples in ‘TEEReg-Ex.R’ failed
The error most likely occurred in:
> ### Name: TEE.BCa
> ### Title: Compute the bias-corrected accelerated bootstrap confidence
> ### intervals.
> ### Aliases: TEE.BCa
> ### Keywords: TEE.BCa TEEReg TEE
>
> ### ** Examples
>
> data(telephone)
> fit <- TEE(formula=Y~X,data=telephone,p.trimmed=0.5,p.subsample=0.5,method="tee")
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
TEEReg
--- call from context ---
TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- call from argument ---
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*% ((1/Xsvd$d[Positive]) *
t(Xsvd$u[, Positive, drop = FALSE]))
}
} else if (nonsingular == "TRUE") {
hat <- solve(X)
}
--- R stacktrace ---
where 1: TEE(formula = Y ~ X, data = telephone, p.trimmed = 0.5, p.subsample = 0.5,
method = "tee")
--- value of length: 2 type: logical ---
[1] FALSE TRUE
--- function from context ---
function (formula, data, offset = NULL, p.trimmed = NULL, p.subsample = 1,
method = "tee")
{
if (missing(formula)) {
stop("'formula' must be provided.")
}
if (missing(data)) {
stop("'data' must be provided.")
}
if (method != "ols" & method != "tee") {
stop(gettextf("invalid 'method' argument, method = '%s' is not supported. Using 'tee' or 'ols'.",
method), domain = NA)
}
if (is.null(p.trimmed) & method == "tee") {
stop("'p.trimmed' must be provided when 'method' is 'tee'.")
}
if (!is.null(p.trimmed)) {
if (!is.numeric(p.trimmed)) {
stop("'p.trimmed' must be numeric.")
}
else if (p.trimmed >= 1 | p.trimmed < 0) {
stop("invalid 'p.trimmed' argument.")
}
}
if (!is.numeric(p.subsample)) {
stop("'p.subsample' must be numeric.")
}
else if (p.subsample > 1 | p.subsample <= 0) {
stop("invalid 'p.subsample' argument.")
}
mcall <- match.call(expand.dots = FALSE)
mat <- match(c("formula", "data", "offset"), names(mcall),
0L)
mcall <- mcall[c(1L, mat)]
mcall$drop.unused.levels <- TRUE
mcall[[1L]] <- quote(stats::model.frame)
mcall <- eval(mcall, parent.frame())
mcallt <- attr(mcall, "terms")
if (!is.null(offset)) {
if (length(offset) != nrow(data)) {
stop(gettextf("number of offsets is %d, should equal %d (number of observations).",
length(offset), nrow(data)), domain = NA)
}
else {
offset <- as.vector(model.offset(mcall))
}
}
Yall <- model.response(mcall, "any")
if (is.empty.model(mcallt)) {
Xall <- NULL
output <- list(coefficients = if (is.matrix(Yall)) matrix(,
0, 3) else numeric(), residuals = Yall, fitted.values = 0 *
Yall, rank = 0L)
if (is.null(offset)) {
output$fitted.values <- offset
output$residuals <- Yall - offset
}
print(list(output))
stop("no parameters need to be estimated.")
}
else {
Xall <- model.matrix(mcallt, mcall)
names <- colnames(Xall)
}
if (method == "ols") {
callt <- match.call()
c <- match(c("formula", "data", "offset", "method"),
names(callt), 0L)
callt <- callt[c(1L, c)]
nonsingular <- class(try(solve(t(Xall) %*% Xall), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
warning("Matrix is singular, generalized inverse is used.")
tol = sqrt(.Machine$double.eps)
XpXsvd <- svd(t(Xall) %*% Xall)
Positive <- XpXsvd$d > max(tol * XpXsvd$d[1L], 0)
if (all(Positive)) {
hat <- XpXsvd$v %*% (1/XpXsvd$d * t(XpXsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(Xall)[2L:1L])
}
else {
hat <- XpXsvd$v[, Positive, drop = FALSE] %*%
((1/XpXsvd$d[Positive]) * t(XpXsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(t(Xall) %*% Xall)
}
if (!is.null(offset)) {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% (Yall -
offset)))
}
else {
TEE.est <- as.matrix(t(hat %*% t(Xall) %*% Yall))
}
}
else if (method == "tee") {
samplesize <- length(Yall)
p <- ncol(Xall)
index <- combn(samplesize, p)
k <- ncol(index)
set.seed(23211342)
s <- ceiling(p.subsample * k)
subset <- as.matrix(index[, sample(1:k, s, replace = FALSE)])
beta.h <- matrix(NA, nrow = p, ncol = s)
det.XhXh <- c()
sum.abse <- c()
r <- round((1 - p.trimmed) * s)
for (i in 1:s) {
Y <- Yall[subset[, i]]
X <- Xall[subset[, i], ]
nonsingular <- class(try(solve(X), silent = T)) ==
"matrix"
if (nonsingular == "FALSE") {
tol = sqrt(.Machine$double.eps)
Xsvd <- svd(X)
Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
if (all(Positive)) {
hat <- Xsvd$v %*% (1/Xsvd$d * t(Xsvd$u))
}
else if (!any(Positive)) {
hat <- array(0, dim(X)[2L:1L])
}
else {
hat <- Xsvd$v[, Positive, drop = FALSE] %*%
((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive,
drop = FALSE]))
}
}
else if (nonsingular == "TRUE") {
hat <- solve(X)
}
if (!is.null(offset)) {
beta.h[, i] <- hat %*% (Y - offset[subset[, i]])
}
else {
beta.h[, i] <- hat %*% Y
}
det.XhXh[i] <- det(t(X) %*% X)
sum.abse[i] <- sum(abs(Yall - Xall %*% beta.h[, i]))
}
callt <- match.call()
pho <- c()
rank.err <- rank(sum.abse)
for (j in 1:s) {
if (rank.err[j] <= r) {
pho[j] <- 1
}
else {
pho[j] <- 0
}
}
TEE.est <- as.matrix(t(rowSums(t(matrix(c(det.XhXh *
pho), nrow = s, ncol = p)) * beta.h)/sum(det.XhXh *
pho)))
}
colnames(TEE.est) <- c(names)
rownames(TEE.est) <- ""
resid <- if (is.null(offset)) {
Yall - Xall %*% t(TEE.est)
}
else {
Yall - (Xall %*% t(TEE.est) + offset)
}
fitted <- if (is.null(offset)) {
Xall %*% t(TEE.est)
}
else {
Xall %*% t(TEE.est) + offset
}
output <- list(call = callt, formula = formula, coefficients = TEE.est,
residuals = t(resid), fitted.values = t(fitted))
return(output)
}
<bytecode: 0x1784098>
<environment: namespace:TEEReg>
--- function search by body ---
Function TEE in namespace TEEReg has this body.
----------- END OF FAILURE REPORT --------------
Error in if (nonsingular == "FALSE") { : the condition has length > 1
Calls: TEE
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc