Fix critical CI issues and optimize test performance

.github/workflows/check-standard.yaml

@@ -22,7 +22,6 @@ jobs:
           - {os: windows-latest, r: 'release'}
           - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
           - {os: ubuntu-latest,   r: 'release'}
-          - {os: ubuntu-latest,   r: 'oldrel-1'}
 
     env:
       GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}

DESCRIPTION

@@ -39,7 +39,10 @@ Imports:
     xtable
 biocViews:
 Suggests:
+    doSNOW,
+    foreach,
     mlbench,
     RhpcBLASctl,
+    snow,
     testthat
-RoxygenNote: 7.1.2
+RoxygenNote: 7.3.2

NAMESPACE

@@ -2,6 +2,7 @@
 
 S3method(print,varimpact)
 export(.bound)
+export(cleanup_latex_files)
 export(estimate_tmle2)
 export(exportLatex)
 export(factors_to_indicators)
@@ -17,7 +18,6 @@ import(ggplot2)
 importFrom(SuperLearner,All)
 importFrom(cvTools,cvFolds)
 importFrom(dplyr,first)
-importFrom(dplyr,funs)
 importFrom(dplyr,group_by)
 importFrom(dplyr,mutate)
 importFrom(dplyr,select)

R/apply_tmle_to_validation.R

@@ -62,7 +62,7 @@ apply_tmle_to_validation =
   # Predict g
   tryCatch({
     # Check specifically for a g_model that doesn't exist.
-    if (class(tmle$g_model) == "NULL") {
+    if (is.null(tmle$g_model)) {
       stop("tmle$g_model has class = NULL")
     }
     sl_pred = predict(tmle$g_model, W, type = "response", onlySL = TRUE)

R/cleanup-latex.R

@@ -0,0 +1,59 @@
+#' Clean up LaTeX files created by exportLatex
+#'
+#' This function removes LaTeX files that are typically created by the exportLatex() function.
+#' It's designed to be used after exportLatex() calls to clean up temporary files.
+#'
+#' @param dir Directory where LaTeX files are located (default: current directory)
+#' @param outname Prefix for the LaTeX files (default: empty string)
+#' @param verbose If TRUE, print messages about which files were removed
+#'
+#' @return Invisibly returns a logical vector indicating which files were successfully removed
+#'
+#' @examples
+#' \dontrun{
+#' # After calling exportLatex()
+#' exportLatex(vim)
+#' cleanup_latex_files()
+#' 
+#' # With custom directory and prefix
+#' exportLatex(vim, outname = "myresults_", dir = "output/")
+#' cleanup_latex_files(dir = "output/", outname = "myresults_")
+#' }
+#'
+#' @export
+cleanup_latex_files <- function(dir = ".", outname = "", verbose = FALSE) {
+
+  # Define the standard LaTeX file names that exportLatex() creates
+  latex_files <- c(
+    paste0(dir, "/", outname, "varimpByFold.tex"),
+    paste0(dir, "/", outname, "varimpAll.tex"),
+    paste0(dir, "/", outname, "varimpConsistent.tex")
+  )
+
+  # Check which files exist
+  existing_files <- latex_files[file.exists(latex_files)]
+
+  if (length(existing_files) == 0) {
+    if (verbose) {
+      cat("No LaTeX files found to clean up.\n")
+    }
+    return(invisible(logical(0)))
+  }
+
+  if (verbose) {
+    cat("Cleaning up LaTeX files:\n")
+    cat(paste("  -", basename(existing_files), collapse = "\n"), "\n")
+  }
+
+  # Remove the files
+  removal_success <- suppressWarnings({
+    file.remove(existing_files)
+  })
+
+  if (verbose) {
+    successful_removals <- sum(removal_success)
+    cat("Successfully removed", successful_removals, "of", length(existing_files), "files.\n")
+  }
+
+  return(invisible(removal_success))
+}

R/estimate_pooled_results.R

@@ -72,7 +72,7 @@ estimate_pooled_results = function(fold_results,
     # If Q is binary or continuous we still want to take logit of predicted values.
     # See tmle::estimateQ where it does this after predicting Q.
     data$logit_Q_hat = try(stats::qlogis(data$Q_hat))
-    if (class(data$logit_Q_hat) == "try-error") {
+    if (inherits(data$logit_Q_hat, "try-error")) {
       cat("Error in estimate_pooled_results() with qlogis()\n")
       print(summary(data$Q_hat))
       browser()

R/estimate_tmle2.R

@@ -237,7 +237,8 @@ estimate_tmle2 =
 
   if (verbose) cat("tmle::calcParameters\n")
   res <- tmle::calcParameters(Ystar, A, I.Z=rep(1, length(Ystar)), delta, g1W.total, g0W.total, Qstar,
-                        mu1=mean(Qstar[,"Q1W"]), mu0=mean(Qstar[,"Q0W"]), id, family)
+                        mu1=mean(Qstar[,"Q1W"]), mu0=mean(Qstar[,"Q0W"]), id, family, 
+                        obsWeights=rep(1, length(Ystar)))
 
   #returnVal <- list(estimates=res, Qinit=Q, g=g, g.Z=g.z, g.Delta=g.Delta, Qstar=Qstar[,-1], epsilon=epsilon)
   #class(returnVal) <- "tmle"

R/exportLatex.R

@@ -24,6 +24,12 @@
 # TODO: document return object.
 exportLatex = function(impact_results, outname = "", dir = ".", digits = 4, ...) {
 
+  # Check if results are valid
+  if (is.null(impact_results$results_by_fold) || is.null(impact_results$results_all)) {
+    warning("Cannot export LaTeX: varimpact results are NULL or incomplete")
+    return(invisible(NULL))
+  }
+
   table_byfold = cbind("Variable" = rownames(impact_results$results_by_fold),
                     impact_results$results_by_fold)
 
@@ -101,5 +107,7 @@ exportLatex = function(impact_results, outname = "", dir = ".", digits = 4, ...)
                    byfold = xtable_byfold
                  ))
 
+
+
   return(invisible(results))
 }

R/globals.R

@@ -0,0 +1,13 @@
+# Global variable declarations to avoid R CMD check NOTEs
+# These variables are used in dplyr operations and ggplot2
+
+# Variables used in dplyr operations
+utils::globalVariables(c(
+  "name", "level", "level_label", "test_msg", "train_msg", 
+  "cv_fold", "train_cell_size", "test_cell_size",
+  "rawp", "BH", "AvePsi", "Consistent",
+  "test_theta_tmle", "color"
+))
+
+# Function used in dplyr operations
+utils::globalVariables("desc")

R/quantiles_equivalent.R

@@ -13,7 +13,7 @@ quantiles_equivalent = function(x, quantile_probs = c(0.1, 0.9)) {
   if (length(quantile_probs) != 2) {
     warning("Quantiles_equivalent() expects quantile_probs to be a 2-element vector.")
   }
-  if (class(x) == "factor") {
+  if (is.factor(x)) {
     x = unclass(x)
   }
   quantiles = quantile(x, probs = quantile_probs, na.rm = T)

R/reduce_dimensions.R

@@ -54,7 +54,7 @@ reduce_dimensions = function(data, newX = NULL, max_variables, verbose = FALSE)
     # We transpose Wt because we want to cluster columns rather than rows.
     mydist = try(hopach::distancematrix(t(data), d = "cosangle", na.rm = T),
                  silent = !verbose)
-    if (class(mydist) == "try-error") {
+    if (inherits(mydist, "try-error")) {
       cat("Error in HOPACH clustering: failed to calculate distance matrix.\n")
     }
 
@@ -68,7 +68,7 @@ reduce_dimensions = function(data, newX = NULL, max_variables, verbose = FALSE)
                                   K = max_variables, kmax = 3, khigh = 3),
                    silent = !verbose)
     })
-    if (class(hopach.1) == "try-error") {
+    if (inherits(hopach.1, "try-error")) {
       if (verbose) {
         cat("Hopach attempt 1 fail.\n")
         print(hopach.1)
@@ -83,7 +83,7 @@ reduce_dimensions = function(data, newX = NULL, max_variables, verbose = FALSE)
                       silent = !verbose)
       })
     }
-    if (class(hopach.1) == "try-error") {
+    if (inherits(hopach.1, "try-error")) {
       if (verbose) {
         cat("Attempt 2 fail.")# Reverting to original W dataframe.\n")
         print(hopach.1)
@@ -99,7 +99,7 @@ reduce_dimensions = function(data, newX = NULL, max_variables, verbose = FALSE)
                       silent = !verbose)
       })
     }
-    if (class(hopach.1) == "try-error") {
+    if (inherits(hopach.1, "try-error")) {
       if (verbose) {
         cat("Attempt 3 fail. Reverting to original W dataframe.\n")
         # Now try to debug this.

R/results-by-level.R

@@ -4,7 +4,7 @@
 #' all levels of each variable across all CV folds.
 #' @param verbose If true, display extra output.
 #' @importFrom magrittr %>%
-#' @importFrom dplyr group_by summarize_all select funs mutate first
+#' @importFrom dplyr group_by summarize_all select mutate first
 #' @importFrom modeest mlv
 results_by_level =
   function(results_by_fold_and_level,
@@ -25,7 +25,7 @@ results_by_level =
     # TODO: take mode of test_msg or first value, rather than mean.
     select(-c(test_msg, train_msg)) %>%
     # this generates a warning in mean() because test_msg is a character not a numeric.
-    summarize_all(funs(mean)) %>%
+    summarize_all(list(mean = mean)) %>%
     select(-c(cv_fold, train_cell_size, test_cell_size))
 
     # Don't keep this as a tibble.

R/tmle_estimate_g.R

@@ -95,9 +95,9 @@ tmle_estimate_g <-
         }
       } else {
         form <- try(as.formula(gform))
-        if(class(form)== "formula") {
+        if(inherits(form, "formula")) {
           m <- try(glm(form,  data=d, family="binomial"))
-          if (class(m)[1]=="try-error"){
+          if (inherits(m, "try-error")){
             if(verbose){cat("\tInvalid formula supplied. Running glm using main terms\n")}
             form <- paste(colnames(d)[1],"~1 + ", paste(colnames(d)[-1], collapse = "+"), sep="")
             m <- glm(form, data=d, family="binomial")

R/varimpact.R

@@ -141,6 +141,7 @@
 #' vim
 #' vim$results_all
 #' exportLatex(vim)
+#' cleanup_latex_files()
 #'
 #' # Impute by median rather than knn.
 #' \dontrun{

R/vim-factors.R

@@ -345,13 +345,13 @@ vim_factors =
                                     g.lib = g.library, verbose = verbose_tmle),
                       silent = !verbose)
 
-            if (class(tmle_result) == "try-error") {
+            if (inherits(tmle_result, "try-error")) {
               # TMLE estimation failed.
               if (verbose) cat("X")
               error_count = error_count + 1
 
-              # TODO: not sure if this will be handled appropriately.
-              training_estimates[[bin_j]] = NA
+              # Initialize to NULL so validation code doesn't get subscript error
+              training_estimates[[bin_j]] = NULL
             } else {
               # TMLE estimation successed.
 
@@ -395,7 +395,7 @@ vim_factors =
               preds = try(apply_tmle_to_validation(Yv, IA, Wvsht, family,
                                                    deltav, training_estimates[[bin_j]],
                                                    verbose = verbose))
-              if (class(preds) == "try-error") {
+              if (inherits(preds, "try-error")) {
                 bin_result$test_msg = paste("CV-TMLE prediction on validation failed")
               } else {
                 # Save the result.
@@ -448,7 +448,11 @@ vim_factors =
           # Extract theta estimates.
           theta_estimates = sapply(training_estimates, function(result) {
             # Handle errors in the tmle estimation by returning NA.
-            ifelse("theta" %in% names(result), result$theta, NA)
+            if (is.null(result)) {
+              NA
+            } else {
+              ifelse("theta" %in% names(result), result$theta, NA)
+            }
           })
 
           if (!all(is.na(theta_estimates))) {
@@ -470,15 +474,18 @@ vim_factors =
 
           # This fold failed if we got an error for each category
           # Or if the minimum and maximum bin is the same.
+          # Or if the min/max training estimates are NULL.
           if (error_count == num.cat ||
               (is.na(minj) && is.na(maxj)) ||
-              minj == maxj) {
+              minj == maxj ||
+              is.null(training_estimates[[minj]]) || is.null(training_estimates[[maxj]])) {
             message = paste("Fold", fold_k, "failed,")
             if (length(theta_estimates) == 0 || error_count == num.cat) {
               message = paste(message, "all", num.cat, "levels had errors.")
+            } else if (minj == maxj) {
+              message = paste(message, "min and max level are the same. (j = ", minj, ")")
             } else {
-              message = paste(message, "min and max level are the same. (j = ", minj,
-                              "label = ", training_estimates[[minj]]$label, ")")
+              message = paste(message, "min or max training estimate is NULL.")
             }
             fold_result$message = message
 
@@ -555,7 +562,7 @@ vim_factors =
             #                        g.lib = g.library, verbose = verbose),
             #          silent = T)
 
-            if (class(min_preds) == "try-error") {
+            if (inherits(min_preds, "try-error")) {
               message = paste("CV-TMLE prediction on validation failed during",
                             "low/control level.")
               fold_result$message = message
@@ -585,7 +592,7 @@ vim_factors =
               #           silent = !verbose)
 
 
-              if (class(max_preds) == "try-error") {
+              if (inherits(max_preds, "try-error")) {
                 message = paste("CV-TMLE prediction on validation failed",
                       "during high/treatment level.")
                 fold_result$message = message
@@ -640,7 +647,7 @@ vim_factors =
         bin_df = do.call(rbind, compile_rows)
         if (verbose) cat("\n")
 
-        if (class(bin_df) != "data.frame" || nrow(bin_df) == 0L) {
+        if (!inherits(bin_df, "data.frame") || nrow(bin_df) == 0L) {
           if (verbose) {
             cat("Skipping bin", bin, "- no rows are available.\n")
           }