Running ‘test.R’ [2s/3s]
Running the tests in ‘tests/test.R’ failed.
Complete output:
  > library("psychomix")
  Loading required package: flexmix
  Loading required package: lattice
  Loading required package: psychotools
  > suppressWarnings(RNGversion("3.5.0"))
  > set.seed(1)
  > 
  > ### Rost
  > r <- simRaschmix(design = "rost2", extremes = FALSE)
  > re <- simRaschmix(design = "rost2", extremes = TRUE)
  > 
  > mr <- raschmix(r, k = 2, nrep = 1, scores = "saturated")
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  psychomix
   --- call from context --- 
  raschmix(r, k = 2, nrep = 1, scores = "saturated")
   --- call from argument --- 
  if (class(d$.response) == "itemresp") {
      missing.obs <- is.na(d$.response)
  } else {
      missing.obs <- apply(is.na(d$.response), 1, all)
  }
   --- R stacktrace ---
  where 1: raschmix(r, k = 2, nrep = 1, scores = "saturated")
  
   --- value of length: 2 type: logical ---
  [1] FALSE FALSE
   --- function from context --- 
  function (formula, data, k, subset, weights, scores = c("saturated", 
      "meanvar"), restricted = FALSE, nrep = 3, cluster = NULL, 
      control = NULL, verbose = TRUE, drop = TRUE, unique = FALSE, 
      which = NULL, reltol = 1e-10, deriv = "sum", hessian = FALSE, 
      restart = TRUE, model = NULL, gradtol = reltol, ...) 
  {
      cl <- match.call()
      has_subset <- !missing(subset)
      has_weights <- !missing(weights)
      scores <- match.arg(head(tolower(scores), 1L), c("saturated", 
          "meanvar", "constant"))
      misRes <- missing(restricted)
      if (missing(reltol) && !missing(gradtol) && !is.null(gradtol)) 
          reltol <- gradtol
      if (missing(formula)) {
          d <- as.data.frame(matrix(0, nrow = nrow(data), ncol = 0L))
          d$.response <- data
          conc <- NULL
      }
      else if (!inherits(formula, "formula") & missing(data)) {
          d <- as.data.frame(matrix(0, nrow = nrow(formula), ncol = 0L))
          d$.response <- formula
          conc <- NULL
      }
      else {
          if (missing(data)) 
              data <- environment(formula)
          aux <- match.call(expand.dots = FALSE)
          aux <- aux[c(1L, match(c("formula", "data", "subset", 
              "weights"), names(aux), 0L))]
          ff <- Formula(formula)
          auxc <- aux
          auxc[[1]] <- as.name("get_all_vars")
          auxc$formula <- formula(ff, lhs = 0, rhs = NULL)
          if (has_subset) 
              names(auxc)[names(auxc) == "subset"] <- ".subset"
          if (has_weights) 
              names(auxc)[names(auxc) == "weights"] <- ".weights"
          d <- eval(auxc, parent.frame())
          if (has_subset) 
              d <- d[d$.subset, , drop = FALSE]
          d$.subset <- NULL
          conc <- ncol(d) > has_weights
          conc <- if (conc) {
              f <- formula(ff, lhs = 0, rhs = NULL, collapse = TRUE)
              FLXPmultinom(f)
          }
          else {
              NULL
          }
          auxr <- aux
          auxr[[1]] <- as.name("model.frame")
          auxr$formula <- ff
          auxr$lhs <- NULL
          auxr$rhs <- 0
          auxr$na.action <- na.pass
          auxr$weights <- NULL
          mf <- eval(auxr, parent.frame())
          mp <- model.part(ff, lhs = NULL, rhs = 0, data = mf)
          if (all(sapply(mp, is.itemresp))) {
              d$.response <- mp[[1]]
              if (length(mp) > 1) 
                  for (i in 2:length(mp)) d$.response <- merge(d$.response, 
                    mp[[i]])
          }
          else {
              d$.response <- as.matrix(mp)
          }
      }
      if (class(d$.response) == "itemresp") {
          missing.obs <- is.na(d$.response)
      }
      else {
          missing.obs <- apply(is.na(d$.response), 1, all)
      }
      d <- d[!missing.obs, , drop = FALSE]
      conc.cc <- complete.cases(d[-which(".response" == names(d))])
      d <- d[conc.cc, , drop = FALSE]
      n.total <- nrow(d$.response)
      cm <- colMeans(d$.response, na.rm = TRUE)
      status <- as.character(cut(cm, c(-Inf, 1/(2 * n.total), 1 - 
          1/(2 * n.total), Inf), labels = c("0", "0/1", "1")))
      status[is.na(status)] <- "NA"
      status <- factor(status, levels = c("0/1", "0", "1", "NA"))
      if (is.null(colnames(d$.response))) 
          colnames(d$.response) <- paste("Item", gsub(" ", "0", 
              format(1:ncol(d$.response))), sep = "")
      names(status) <- colnames(d$.response)
      ident <- status == "0/1"
      d$.response <- d$.response[, ident, drop = FALSE]
      score.0 <- rowSums(d$.response, na.rm = TRUE) == 0
      n.0 <- sum(score.0)
      d <- d[!score.0, , drop = FALSE]
      if (class(d$.response) == "itemresp") {
          score.m <- (rowSums(d$.response, na.rm = TRUE) + rowSums(is.na(as.matrix(d$.response)))) == 
              ncol(d$.response)
      }
      else {
          score.m <- (rowSums(d$.response, na.rm = TRUE) + rowSums(is.na(d$.response))) == 
              ncol(d$.response)
      }
      n.m <- sum(score.m)
      d <- d[!score.m, , drop = FALSE]
      pi.0 <- n.0/n.total
      pi.m <- n.m/n.total
      pi.nonex <- nrow(d$.response)/n.total
      rs <- factor(rowSums(d$.response, na.rm = TRUE), levels = 1:(ncol(d$.response) - 
          1L))
      rs <- table(rs)
      ref <- min(which(rs > 0))
      if (scores == "constant" & !restricted) {
          if (!misRes) 
              warning("Constant score model only available with restricted components.")
          restricted <- TRUE
      }
      if (restricted == TRUE) {
          scoreMod <- scoreModel(y = d$.response, w = rep(1, nrow(d$.response)), 
              ref = ref, scores = scores)
          delta <- scoreMod$score
          dfScore <- scoreMod$df
      }
      else {
          delta <- NULL
          dfScore <- 0
      }
      if (is.null(model)) 
          model <- FLXMCrasch(scores = scores, delta = delta, ref = ref, 
              nonExtremeProb = pi.nonex, reltol = reltol, deriv = deriv, 
              hessian = hessian, restart = restart)
      ctrl <- as(control, "FLXcontrol")
      if (identical(cluster, "mrm")) {
          if (length(k) > 1L) 
              warning("starting values from mrm() can only be used with a single 'k', first used")
          k <- k[1L]
          cluster <- if (nrep > 1L) {
              fits <- lapply(1:nrep, function(i) mRm::mrm(d$.response, 
                  k))
              ix <- which.max(sapply(fits, "[[", "logLik"))
              mrm_clusters(d$.response, k, fits[[ix]])
          }
          else {
              mrm_clusters(d$.response, k)
          }
          nrep <- 1L
      }
      z <- if (has_weights) {
          stepFlexmix(.response ~ 1, data = d, k = k, nrep = nrep, 
              cluster = cluster, model = model, concomitant = conc, 
              control = ctrl, verbose = verbose, drop = drop, unique = unique, 
              weights = d$.weights, ...)
      }
      else {
          stepFlexmix(.response ~ 1, data = d, k = k, nrep = nrep, 
              cluster = cluster, model = model, concomitant = conc, 
              control = ctrl, verbose = verbose, drop = drop, unique = unique, 
              ...)
      }
      if (!is.null(which) & class(z) == "stepFlexmix") {
          z <- getModel(z, which = which)
      }
      if (class(z) == "flexmix") {
          z@df <- z@df + (pi.0 != 0) + (pi.m != 0)
          if (restricted) 
              z@df <- z@df + dfScore
          if (pi.0 != 0) 
              z@logLik <- z@logLik + n.0 * log(pi.0)
          if (pi.m != 0) 
              z@logLik <- z@logLik + n.m * log(pi.m)
          z <- as(z, "raschmix")
          z@scores <- scores
          z@restricted <- restricted
          z@deriv <- deriv
          z@extremeScoreProbs <- c(pi.0, pi.m)
          z@rawScoresData <- rs
          z@flx.call <- z@call
          z@call <- cl
          z@nobs <- n.total - n.0 - n.m
          z@identified.items <- status
      }
      else {
          if (pi.0 != 0) 
              z@logLiks <- z@logLiks + n.0 * log(pi.0)
          if (pi.m != 0) 
              z@logLiks <- z@logLiks + n.m * log(pi.m)
          z@models <- lapply(z@models, function(model) {
              model@df <- model@df + (pi.0 != 0) + (pi.m != 0)
              if (restricted) 
                  model@df <- model@df + dfScore
              if (pi.0 != 0) 
                  model@logLik <- model@logLik + n.0 * log(pi.0)
              if (pi.m != 0) 
                  model@logLik <- model@logLik + n.m * log(pi.m)
              model <- as(model, "raschmix")
              model@scores <- scores
              model@restricted <- restricted
              model@deriv <- deriv
              model@extremeScoreProbs <- c(pi.0, pi.m)
              model@rawScoresData <- rs
              model@flx.call <- model@call
              model@call <- cl
              model@call$k <- model@flx.call$k
              model@nobs <- n.total - n.0 - n.m
              model@identified.items <- status
              return(model)
          })
          z <- as(z, "stepRaschmix")
          z@flx.call <- z@call
          z@call <- cl
      }
      return(z)
  }
  <bytecode: 0x55b1e414ba08>
  <environment: namespace:psychomix>
   --- function search by body ---
  Function raschmix in namespace psychomix has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Fatal error: the condition has length > 1