Running ‘test.R’
Running the tests in ‘tests/test.R’ failed.
Complete output:
  > rm(list = ls())
  > library(TVsMiss)
  > n <- 50
  > p <- 8
  > beta <- c(3,0,1.5,0,2,rep(0,p-5))
  > xm <- matrix(rnorm(n*p),ncol = p, nrow = n)
  > y <- xm %*% beta + rnorm(n)
  > colnames(xm) <- paste0("Var_",1:p)
  > 
  > fit01 <- tvsmiss(x=xm,y=y)
   ----------- FAILURE REPORT -------------- 
   --- failure: the condition has length > 1 ---
   --- srcref --- 
  : 
   --- package (from environment) --- 
  TVsMiss
   --- call from context --- 
  tvsmiss(x = xm, y = y)
   --- call from argument --- 
  if (class(x) != "matrix") {
      tmp <- try(x <- model.matrix(~0 + ., data = x), silent = TRUE)
      if (class(tmp)[1] == "try-error") 
          stop("x must be a matrix or able to be coerced to a matrix")
  }
   --- R stacktrace ---
  where 1: tvsmiss(x = xm, y = y)
  
   --- value of length: 2 type: logical ---
  [1] FALSE  TRUE
   --- function from context --- 
  function (x, y, penalty = c("lasso", "MCP", "SCAD"), method = c("CV", 
      "BIC", "BIC1", "BIC2", "sBIC", "sBIC1", "sBIC2", "sVS", "sEST"), 
      lambda = NULL, fold = 5, cv.ind = NULL, repeat_b = 20, alpha_n = 0.1, 
      refit = F, gamma = switch(penalty, SCAD = 3.7, MCP = 3, lasso = NA), 
      use.penalty = T) 
  {
      penalty <- match.arg(penalty)
      method <- match.arg(method)
      this.call = match.call()
      if (class(x) != "matrix") {
          tmp <- try(x <- model.matrix(~0 + ., data = x), silent = TRUE)
          if (class(tmp)[1] == "try-error") 
              stop("x must be a matrix or able to be coerced to a matrix")
      }
      if (storage.mode(x) == "integer") 
          storage.mode(x) <- "double"
      if (class(y) != "numeric") {
          tmp <- try(y <- as.numeric(y), silent = TRUE)
          if (class(tmp)[1] == "try-error") 
              stop("y must numeric or able to be coerced to numeric")
      }
      if (length(y) != nrow(x)) 
          stop("x and y do not have the same number of observations")
      colnames(x) <- if (is.null(colnames(x))) 
          paste("V", 1:ncol(x), sep = "")
      else colnames(x)
      data <- cbind(y, x)
      complete_idx <- c(1:length(y))[complete.cases(data)]
      y_complete <- y[complete_idx]
      x_complete <- x[complete_idx, ]
      sample_no_missing <- cbind(y_complete, x_complete)
      logistic_sample <- pairdata(sample_no_missing)
      if (use.penalty) {
          if (is.null(cv.ind)) {
              if (fold < 2 | fold > nrow(sample_no_missing)) 
                  stop("fold should be greater than 1 and less than the rows in the complete data(after deleting missing)")
              cv.ind <- ceiling(sample(1:nrow(sample_no_missing))/(nrow(sample_no_missing) + 
                  sqrt(.Machine$double.eps)) * fold)
          }
          else {
              if (length(cv.ind) != nrow(sample_no_missing) | max(cv.ind) > 
                  nrow(sample_no_missing)) 
                  stop("cv.ind is not match to the complete data")
          }
          sample_no_missing_list <- list()
          for (i in 1:max(cv.ind)) {
              sample_no_missing_list[[i]] <- sample_no_missing[cv.ind == 
                  i, ]
          }
          logistic_list_estimation <- cv_logistic_prepare(complete_data = sample_no_missing, 
              cv.ind = cv.ind)
          current_model <- model_est_path(logistic_sample = logistic_sample, 
              lambda = lambda, penalty = penalty, gamma = gamma)
          beta_matrix <- t(as.matrix(coef(current_model)))[, -1]
          lambda <- current_model$lambda
          if (method == "CV") {
              begin_time <- proc.time()
              selection_res <- cv_sel(logistic_list = logistic_list_estimation, 
                  complete_data_list = sample_no_missing_list, 
                  cv.fold = fold, cv.ind = cv.ind, penalty = penalty, 
                  lambda = lambda, gamma = gamma)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- selection_res$cv.ind
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
          else if (method == "BIC") {
              begin_time <- proc.time()
              selection_res <- BIC_log_cal(complete_dataset = sample_no_missing, 
                  beta_matrix = beta_matrix)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- NULL
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
          else if (method == "sBIC") {
              begin_time <- proc.time()
              selection_res <- sBIC(complete_data = sample_no_missing, 
                  cv.fold = fold, cv.ind = cv.ind, penalty = penalty, 
                  lambda = lambda, gamma = gamma)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- selection_res$cv.ind
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
          else if (method == "sBIC1") {
              begin_time <- proc.time()
              selection_res <- sBIChigh(complete_data = sample_no_missing, 
                  cv.fold = fold, cv.ind = cv.ind, penalty = penalty, 
                  lambda = lambda, gamma = gamma)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- selection_res$cv.ind
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
          else if (method == "sBIC2") {
              begin_time <- proc.time()
              selection_res <- sBICultrahigh(complete_data = sample_no_missing, 
                  cv.fold = fold, cv.ind = cv.ind, penalty = penalty, 
                  lambda = lambda, gamma = gamma)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- selection_res$cv.ind
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
          else if (method == "sVS") {
              if (fold == 2) {
                  begin_time <- proc.time()
                  selection_res <- VSS(complete_data = sample_no_missing, 
                    lambda = lambda, repeat_b = repeat_b, alpha_n = alpha_n, 
                    penalty = penalty, gamma = gamma)
                  selection_idx <- which(lambda == selection_res$selection_lambda_value)
                  selection_lambda <- selection_res$selection_lambda_value
                  selection_path <- selection_res$selection_path
                  selection_cv.ind <- NULL
                  selection_beta <- beta_matrix[selection_idx, 
                    ]
                  final_time <- proc.time() - begin_time
              }
              else {
                  begin_time <- proc.time()
                  selection_res <- fleiss(complete_data = sample_no_missing, 
                    cv.fold = fold, cv.ind = cv.ind, penalty = penalty, 
                    lambda = lambda, alpha_n = alpha_n, gamma = gamma)
                  selection_idx <- which(lambda == selection_res$selection_lambda_value)
                  selection_lambda <- selection_res$selection_lambda_value
                  selection_path <- selection_res$selection_path
                  selection_cv.ind <- selection_res$cv.ind
                  selection_beta <- beta_matrix[selection_idx, 
                    ]
                  final_time <- proc.time() - begin_time
              }
          }
          else if (method == "sEST") {
              begin_time <- proc.time()
              selection_res <- sEST(complete_data = sample_no_missing, 
                  cv.fold = fold, cv.ind = cv.ind, penalty = penalty, 
                  lambda = lambda, gamma = gamma)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- selection_res$cv.ind
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
          else if (method == "BIC1") {
              begin_time <- proc.time()
              selection_res <- BIC_high(complete_dataset = sample_no_missing, 
                  beta_matrix = beta_matrix)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- NULL
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
          else if (method == "BIC2") {
              begin_time <- proc.time()
              selection_res <- BIC_ultrahigh(complete_dataset = sample_no_missing, 
                  beta_matrix = beta_matrix)
              selection_idx <- selection_res$lambda_idx
              selection_lambda <- lambda[selection_res$lambda_idx]
              selection_path <- selection_res$selection_path
              selection_cv.ind <- NULL
              selection_beta <- beta_matrix[selection_idx, ]
              final_time <- proc.time() - begin_time
          }
      }
      else {
          begin_time <- proc.time()
          glm_model <- glm(logistic_sample[, 1] ~ -1 + logistic_sample[, 
              -1], family = binomial(link = "logit"))
          current_model = glm_model
          beta_matrix = NULL
          lambda = NULL
          cv.ind = NULL
          selection_idx = NULL
          selection_lambda = NULL
          selection_path = NULL
          selection_cv.ind = NULL
          selection_beta = current_model$coefficients
          names(selection_beta) <- colnames(logistic_sample)[-1]
          final_time <- proc.time() - begin_time
      }
      deviance.ratio = 1 + loglikelihood_r(c(0, selection_beta), 
          sample_no_missing)/log(2)
      if (refit & use.penalty) {
          if (sum(selection_beta != 0) == 0) {
              refit_beta = selection_beta
          }
          else {
              refit_model <- glm(logistic_sample[, 1] ~ -1 + logistic_sample[, 
                  -1][, which(selection_beta != 0)], family = binomial(link = "logit"))
              refit_beta <- rep(0, ncol(logistic_sample) - 1)
              refit_beta[which(selection_beta != 0)] <- refit_model$coefficients
              names(refit_beta) <- colnames(logistic_sample)[-1]
          }
      }
      else {
          refit_beta = NULL
      }
      res <- list(ls = logistic_sample, c_idx = complete_idx, model = current_model, 
          beta_matrix = beta_matrix, lambda = lambda, cv.ind = cv.ind, 
          fold = fold, selection_idx = selection_idx, selection_lambda = selection_lambda, 
          selection_path = selection_path, selection_cv.ind = selection_cv.ind, 
          selection_beta = selection_beta, refit_beta = refit_beta, 
          null.deviance = 2 * log(2), deviance.ratio = deviance.ratio, 
          gamma = gamma, call = this.call, running_time = final_time)
      class(res) = "TVsMiss"
      return(res)
  }
  <bytecode: 0xa40bb40>
  <environment: namespace:TVsMiss>
   --- function search by body ---
  Function tvsmiss in namespace TVsMiss has this body.
   ----------- END OF FAILURE REPORT -------------- 
  Error in if (class(x) != "matrix") { : the condition has length > 1
  Calls: tvsmiss
  Execution halted