Running examples in ‘RRreg-Ex.R’ failed
The error most likely occurred in:

> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: RRlin
> ### Title: Linear randomized response regression
> ### Aliases: RRlin
> 
> ### ** Examples
> 
> # generate two RR predictors
> dat <- RRgen(n=500, pi=.4, model="Warner", p=.3)
> dat2 <- RRgen(n=500, pi=c(.4,.6), model="FR", p=c(.1,.15))
> dat$FR <- dat2$response
> dat$trueFR <- dat2$true
> 
> # generate a third predictor and continuous dependent variables
> dat$nonRR <- rnorm(500, 5, 1)
> dat$depvar <- 2*dat$true - 3*dat2$true + 
+                        .5*dat$nonRR +rnorm(500, 1, 7) 
> 
> # use RRlin and compare to regression on non-RR variables
> linreg <- RRlin(depvar~response+FR+nonRR, data=dat,
+                 models=c("Warner","FR"),
+                 p.list=list(.3, c(.1,.15)), fit.n=1)
 ----------- FAILURE REPORT -------------- 
 --- failure: the condition has length > 1 ---
 --- srcref --- 
: 
 --- package (from environment) --- 
RRreg
 --- call from context --- 
RRlin(depvar ~ response + FR + nonRR, data = dat, models = c("Warner", 
    "FR"), p.list = list(0.3, c(0.1, 0.15)), fit.n = 1)
 --- call from argument --- 
if (class(group) != "matrix") {
    group <- matrix(group, ncol = 1)
}
 --- R stacktrace ---
where 1: RRlin(depvar ~ response + FR + nonRR, data = dat, models = c("Warner", 
    "FR"), p.list = list(0.3, c(0.1, 0.15)), fit.n = 1)

 --- value of length: 2 type: logical ---
[1] FALSE  TRUE
 --- function from context --- 
function (formula, data, models, p.list, group = NULL, Kukrep = 1, 
    bs.n = 0, nCPU = 1, maxit = 1000, fit.n = 3, pibeta = 0.05) 
{
    mf <- model.frame(formula = formula, data = data, na.action = na.omit)
    x <- model.matrix(attr(mf, "terms"), data = mf)
    y <- as.matrix(model.response(mf, "numeric"))
    dimnames(y) <- list(NULL, all.vars(formula)[1])
    M <- length(models)
    intercept <- ifelse(attr(attr(mf, "terms"), "intercept") == 
        1, T, F)
    if (intercept) {
        x <- x[, -1, drop = F]
    }
    w <- x[, c(1:M), drop = F]
    if (ncol(x) > M) {
        u <- x[, (M + 1):ncol(x), drop = F]
        U <- ncol(u)
    }
    else {
        u <- NULL
        U <- 0
    }
    if (missing(group)) {
        group <- matrix(1, length(y), M, dimnames = list(NULL, 
            paste0("g", 1:M)))
    }
    if (!missing(data) && class(substitute(group)) == "name") {
        try({
            data1 <- as.data.frame(data)
            gg <- as.matrix(eval(substitute(group), data1, parent.frame()), 
                dimnames = list(NULL, group))
            group <- gg
        }, silent = T)
        if (class(substitute(group)) == "name") {
            stop(paste0("'group' (", substitute(group), ") could not be found in 'data' (", 
                substitute(data), ")."))
        }
    }
    if (class(group) != "matrix") {
        group <- matrix(group, ncol = 1)
    }
    modelNames <- c("Warner", "UQTknown", "UQTunknown", "Mangat", 
        "Kuk", "FR", "Crosswise", "Triangular", "CDM", "CDMsym", 
        "SLD", "custom")
    models <- pmatch(models, modelNames, duplicates.ok = T)
    models <- modelNames[models]
    RRcheck.lin(y, w, u, models, p.list, group)
    par2 <- rep(NA, M)
    names(par2) <- models
    for (m in 1:M) {
        if (models[m] %in% c("UQTunknown", "SLD")) {
            sel <- group[, m] != 0
            ytemp <- w[sel, m]
            grouptemp <- group[sel, m]
            uni <- RRuni(response = ytemp, model = models[m], 
                p = p.list[[m]], group = grouptemp, MLest = T)
            if (models[m] == "SLD") {
                par2[m] <- uni$t
            }
            else if (models[m] == "UQTunknown") {
                par2[m] <- uni$piUQ
            }
            if (par2[m] < 1e-05) 
                par2[m] <- 1e-05
            if (par2[m] > 1 - 1e-05) 
                par2[m] <- 1 - 1e-05
        }
    }
    N <- length(y)
    gcombs <- unique(group)
    G <- nrow(gcombs)
    responses <- apply(w, 1, paste, collapse = ":")
    PWarray <- getPWarray(M, G, models, p.list, group, par2, 
        Kukrep = Kukrep)
    patterns <- rownames(PWarray[, , 1])
    J <- length(patterns)
    K <- ncol(PWarray[, , 1])
    gidx <- numeric(N)
    for (g in 1:G) {
        sel <- apply(group, 1, function(x) all.equal(x, gcombs[g, 
            ])) == T
        gidx[sel] <- g
    }
    PWpp <- t(apply(cbind(responses, gidx), 1, function(x) PWarray[match(x[1], 
        patterns), , as.numeric(x[2])]))
    if (!missing(u)) {
        x <- cbind(w, u)
    }
    else {
        x <- w
    }
    if (intercept) {
        nam <- colnames(x)
        x <- cbind(1, x)
        colnames(x) <- c("(Intercept)", nam)
    }
    startmod <- lm(y ~ x - 1)
    beta <- coef(startmod)
    names(beta) <- substr(names(beta), 2, 1000)
    if (intercept) {
        RRvariables <- names(beta)[1:M + 1]
    }
    else {
        RRvariables <- names(beta)[1:M]
    }
    rdf <- startmod$df.residual
    r <- startmod$residuals
    sigma <- sqrt(sum(r^2)/rdf)
    pi.est <- matrix(nrow = K, ncol = G, dimnames = list(colnames(PWarray[, 
        , 1]), NULL))
    n.star <- matrix(nrow = J, ncol = G, dimnames = list(patterns, 
        NULL))
    for (g in 1:G) {
        sel <- gidx == g
        for (j in 1:J) {
            n.star[j, g] <- sum(patterns[j] == responses[sel])
        }
        if ("SLD" %in% models || "UQTunknown" %in% models || 
            ("Kuk" %in% models && Kukrep > 1)) {
            pi.est[, g] <- runif(K)
        }
        else {
            pi.est[, g] <- solve(PWarray[, , g]) %*% n.star[, 
                g]/sum(sel)
            pi.est[, g] <- pi.est[, g]
        }
    }
    est <- list()
    est.new <- list()
    for (ff in 1:fit.n) {
        if (ff == 1) {
            pi.estR <- rowMeans(pi.est)
            beta1 <- beta
            sigma1 <- sigma
        }
        else {
            pi.estR <- rowMeans(pi.est) * runif(length(pi.est[, 
                1]), 0.5, 1.5)
            beta1 <- beta * runif(length(beta), 0.3, 3)
            sigma1 <- sigma * runif(1, 0.3, 3)
        }
        pi.estR[pi.estR < 0] <- 0
        pi.estR[pi.estR > 1] <- 1
        pi.estR <- pi.estR/sum(pi.estR)
        phi <- c(beta1, sigma = sigma1, pi = pi.estR)
        phi <- phi[-length(phi)]
        nbeta <- length(beta)
        npi <- length(pi.estR)
        try(est.new <- optim(par = phi, fn = RRlin.ll, method = "L-BFGS-B", 
            lower = c(rep(-Inf, nbeta), 0, rep(0, npi - 1)), 
            upper = c(rep(Inf, nbeta), Inf, rep(1, npi - 1)), 
            control = list(fnscale = -1, maxit = maxit, parscale = c(rep(1, 
                nbeta), 1, rep(pibeta/max(abs(beta)), npi - 1))), 
            hessian = T, y = y, u = u, gidx = gidx, U = U, intercept = intercept, 
            PWpp = PWpp, nbeta = nbeta, n.star = n.star, PWarray = PWarray, 
            M = M), silent = T)
        if (is.null(est$value)) {
            est <- est.new
            start <- phi
        }
        if (!is.null(est.new$value) && est.new$value > est$value) {
            est <- est.new
            start <- phi
        }
    }
    phi <- est$par
    pi <- c(phi[(nbeta + 2):length(phi)], 0)
    pi[npi] <- 1 - sum(pi)
    names(pi) <- colnames(PWarray[, , 1])
    res <- list(models = models, p.list = p.list, PWarray = PWarray, 
        par2 = par2, N = N, beta = phi[1:nbeta], sigma = phi[nbeta + 
            1], pi = pi, hessian = est$hessian, convergence = est$convergence, 
        message = est$message, counts = est$counts, RRvariables = RRvariables, 
        call = match.call(), start = start, intercept = intercept, 
        logLik = est$value, bs.n = bs.n)
    res$npar <- length(phi)
    res$vcov <- est$hessian
    try({
        res$vcov <- solve(-est$hessian)
        dimnames(res$hessian) <- list(names(phi), names(phi))
        dimnames(res$vcov) <- list(names(phi), names(phi))
    }, silent = T)
    res$df <- nrow(unique(cbind(y, x))) - length(phi)
    if (bs.n > 0) {
        npboot <- function(R) {
            bs.beta <- matrix(nrow = R, ncol = nbeta)
            bs.pi <- matrix(nrow = R, ncol = length(pi))
            bs.sigma <- rep(NA, R)
            bs.logLik <- bs.sigma
            cnt <- 1
            while (cnt <= R) {
                sel <- c()
                for (g in 1:G) {
                  sel <- c(sel, sample((1:N)[gidx == g], table(gidx)[g], 
                    T))
                }
                list(y, sel, models, y, group, w, p.list, u)
                try({
                  model.bs <- RRlin(formula = y[sel, , drop = F] ~ 
                    cbind(w[sel, , drop = F], u[sel, , drop = F]), 
                    group = group[sel, , drop = F], Kukrep = Kukrep, 
                    models = models, p.list = p.list, fit.n = 2)
                  bs.beta[cnt, ] <- model.bs$beta
                  bs.sigma[cnt] <- model.bs$sigma
                  bs.pi[cnt, ] <- model.bs$pi
                  bs.logLik[cnt] <- model.bs$logLik
                })
                if (!is.na(bs.beta[cnt, 1])) 
                  cnt <- cnt + 1
            }
            bs.res <- list(beta = bs.beta, pi = bs.pi, sigma = bs.sigma, 
                logLik = bs.logLik)
        }
        if (is.numeric(nCPU) && nCPU == 1) {
            cl.tmp <- NULL
            bs.res <- npboot(R = bs.n)
            res$bs.beta <- bs.res$beta
            res$bs.sigma <- bs.res$sigma
            res$bs.pi <- bs.res$pi
            res$bs.logLik <- bs.res$logLik
        }
        else if (is.numeric(nCPU) && nCPU > 1) {
            cl.tmp = makeCluster(nCPU)
        }
        else if (any(class(nCPU) %in% c("SOCKcluster", "cluster"))) {
            cl.tmp <- nCPU
        }
        else {
            stop("'nCPU' must be integer or a cluster (see ?parallel::makeCluster)")
        }
        if (!is.null(cl.tmp)) {
            registerDoParallel(cl.tmp)
            bs.res <- foreach(k = seq_along(cl.tmp), .packages = "RRreg") %dopar% 
                {
                  npboot(R = ceiling(bs.n/length(cl.tmp)))
                }
            for (i in seq_along(cl.tmp)) {
                res$bs.beta <- rbind(res$bs.beta, bs.res[[i]]$beta)
                res$bs.sigma <- c(res$bs.sigma, bs.res[[i]]$sigma)
                res$bs.pi <- rbind(res$bs.pi, bs.res[[i]]$pi)
                res$bs.logLik <- c(res$bs.logLik, bs.res[[i]]$logLik)
            }
            if (is.numeric(nCPU)) 
                stopCluster(cl.tmp)
        }
    }
    for (m in 1:M) {
        models[m] <- ifelse(0 %in% gcombs[, m], paste0(models[m], 
            "+DQ"), models[m])
    }
    res$models <- models
    res$call <- match.call()
    res$formula <- formula
    class(res) <- "RRlin"
    res
}
<bytecode: 0x55c5c3636408>
<environment: namespace:RRreg>
 --- function search by body ---
Function RRlin in namespace RRreg has this body.
 ----------- END OF FAILURE REPORT -------------- 
Fatal error: the condition has length > 1