make test suite quiet

R/ass_0d_spec.R

@@ -16,7 +16,8 @@ AssSpec0d <- function(
         "metric" = metric,
         "pivot_time_cutoff" = pivot_time_cutoff,
         "lambda" = lambda,
-        "benchmark" = benchmark
+        "benchmark" = benchmark,
+        "file" = file
     )
     return(structure(ass_spec_0d, class = "AssSpec0d"))
 }

R/assess_0d.R

@@ -3,7 +3,7 @@ assess_0d <- function(
     pheno_tbl,
     data_spec,
     model_spec,
-    ass_0d_spec,
+    ass_spec_0d,
     quiet = FALSE,
     msg_prefix = ""
 ){
@@ -12,17 +12,17 @@ assess_0d <- function(
         pheno_tbl = pheno_tbl,
         data_spec = data_spec,
         model_spec = model_spec,
-        lambda = ass_0d_spec$lambda,
-        pivot_time_cutoff = ass_0d_spec$pivot_time_cutoff,
-        benchmark_col = ass_0d_spec$benchmark
+        lambda = ass_spec_0d$lambda,
+        pivot_time_cutoff = ass_spec_0d$pivot_time_cutoff,
+        benchmark_col = ass_spec_0d$benchmark
     )
     core <- function(i){
         predicted <- prep[["predicted"]][[i]]
         actual <- prep[["actual"]][[i]]
-        available <- !is.na(predicted) & !is.na(actual)
-        do.call(ass_0d_spec$metric, list(
-            "predicted" =  predicted[available],
-            "actual" = actual[available]
+        pa <- intersect_by_names(predicted, actual, rm_na = TRUE)
+        do.call(ass_spec_0d$metric, list(
+            "predicted" =  pa[[1]],
+            "actual" = pa[[2]]
             )
         )
     }
@@ -32,7 +32,7 @@ assess_0d <- function(
 
 
 get_auc <- function(
-    predicted, 
+    predicted,
     actual
 ){
     pred_obj <- ROCR::prediction(predictions = predicted, labels = actual)

R/assess_2d_center.R

@@ -42,7 +42,7 @@ assess_2d_center <- function(
     pheno_tbl <- data[["pheno_tbl"]]
     ass_spec_2d$model_tree_mirror <- model_tree_mirror
 
-    message("\nASSESSING ON ", data_spec$name)
+    if(!quiet) message("\nASSESSING ON ", data_spec$name)
     for(cohort in cohorts){
         if(!quiet) message("# On ", cohort, " cohort")
         data_spec$cohort <- cohort

R/asssess_2d.R

@@ -92,6 +92,7 @@ assess_2d <- function(
             predicted = prep[["predicted"]],
             actual = prep[["actual"]],
             ass_spec_2d = pps_scores,
+            quiet = quiet,
             ncol = model_spec$plot_ncols,
             msg_prefix = msg_prefix
         )

R/ensures.R

@@ -10,7 +10,7 @@
 #' the patient identifiers.
 #' @param gene_id_col string. The name of the column in `expr` that holds the
 #' gene identifiers.
-#' @param verbose logical. Whether to print messages. Default is `FALSE`.
+#' @param quiet logical. Whether to print messages. Default is `FALSE`.
 #' @return A list with two tibbles named `expr` and `pheno`. Matching and sorted
 #' expression and pheno data, i.e. the vectors of patient identifiers are 
 #' identical.
@@ -20,7 +20,7 @@ ensure_patients_match <- function(
     pheno_tbl,
     patient_id_col = "patient_id",
     gene_id_col = "gene_id",
-    verbose = TRUE
+    quiet = FALSE
 ){
     if(!is.data.frame(expr_tbl)){
         stop("expr_tbl must inherit from `data.frame`.")
@@ -32,14 +32,14 @@ ensure_patients_match <- function(
     check_tbl_columns_exist(expr_tbl, "expr_tbl", gene_id_col)
 
     if(colnames(expr_tbl)[1] != gene_id_col){
-        if(verbose){
+        if(!quiet){
         message("Moving ", gene_id_col, " column to first column")
         }
         expr_tbl <- expr_tbl |> 
             dplyr::relocate(dplyr::all_of(gene_id_col))
     }
 
-    if(verbose){
+    if(!quiet){
         message(nrow(pheno_tbl), " samples in pheno before matching.\n",
             ncol(expr_tbl) - 1, " samples in expr before matching.")
     }
@@ -54,7 +54,7 @@ ensure_patients_match <- function(
     pheno_tbl <- pheno_tbl[pheno_tbl[[patient_id_col]] %in% intersect_ids, ]
     pheno_tbl <- pheno_tbl[order(pheno_tbl[[patient_id_col]]), ]
 
-    if(verbose){
+    if(!quiet){
         message(nrow(pheno_tbl), " samples after matching.")
     }
     res <- list(

R/plot.R

@@ -107,8 +107,8 @@ plot_risk_scores <- function(
     predicted,
     actual,
     ass_spec_2d,
+    quiet,
     ncol = 2,
-    quiet = FALSE,
     msg_prefix = ""
 ){
     # Get rid of NAs

R/prepare_and_fit.R

@@ -33,8 +33,9 @@ prepare_and_fit <- function(
     directory <- model_spec$directory
     # Ensure model directory exists
     if(!dir.exists(directory)){
-        message(msg_prefix, "Creating ", directory)
         dir.create(directory, recursive = TRUE)
+        if(!quiet)
+            message(msg_prefix, "Creating ", directory)
     }
     if(is.null(data_spec$cohort))
         data_spec$cohort <- "train"

tests/testthat/test-assess_2d.R

@@ -61,7 +61,8 @@ test_that("assess_2d() works", {
       expr_mat = expr_mat,
       pheno_tbl = pheno_tbl,
       data_spec = data_spec,
-      model_spec = model_spec
+      model_spec = model_spec,
+      quiet = TRUE
     )
   }
 
@@ -70,7 +71,8 @@ test_that("assess_2d() works", {
     pheno_tbl = pheno_tbl,
     data_spec = data_spec,
     model_spec = model_spec_1,
-    ass_spec_2d = ass_spec_2d
+    ass_spec_2d = ass_spec_2d,
+    quiet = TRUE
   )$data
   expect_s3_class(tbl, "tbl_df")
 
@@ -84,7 +86,8 @@ test_that("assess_2d() works", {
     pheno_tbl = pheno_tbl,
     data_spec = data_spec,
     model_spec = model_spec_2,
-    ass_spec_2d = ass_spec_2d
+    ass_spec_2d = ass_spec_2d,
+    quiet = TRUE
   )$data
   expect_equal(names(tbl), c("rpp", "logrank", "cutoff", "split", "model"))
 
@@ -99,7 +102,8 @@ test_that("assess_2d() works", {
     pheno_tbl = pheno_tbl,
     data_spec = data_spec,
     model_spec = model_spec_2,
-    ass_spec_2d = ass_spec_2d
+    ass_spec_2d = ass_spec_2d,
+    quiet = TRUE
   )$data
   expect_equal(names(tbl), c("rpp", "precision_ci", "cutoff", "split", "model"))
 })

tests/testthat/test-assess_2d_center.R

@@ -54,7 +54,8 @@ test_that("assess_2d_center() works", {
 
   training_camp(
     data_spec = data_spec,
-    model_spec_list = model_spec_list
+    model_spec_list = model_spec_list,
+    quiet = TRUE
   )
 
   res_dir <- file.path(base_dir, "results")
@@ -75,7 +76,8 @@ test_that("assess_2d_center() works", {
     model_spec_list = model_spec_list,
     data_spec = data_spec,
     ass_spec_2d = ass_spec_2d,
-    cohort = c("train", "test")
+    cohort = c("train", "test"),
+    quiet = TRUE
   )
   expect_true(file.exists(ass_spec_2d$file))
   expect_true(file.exists(file.path(res_dir, "logistic/2/scores.pdf")))
@@ -93,7 +95,8 @@ test_that("assess_2d_center() works", {
     data_spec = data_spec,
     ass_spec_2d = ass_spec_2d,
     comparison_plot = FALSE,
-    cohorts = "test"
+    cohorts = "test",
+    quiet = TRUE
   )
 
   model_spec_2$time_cutoffs <- 1.5
@@ -106,7 +109,8 @@ test_that("assess_2d_center() works", {
     data_spec = data_spec,
     ass_spec_2d = ass_spec_2d,
     comparison_plot = TRUE,
-    cohorts = "train"
+    cohorts = "train",
+    quiet = TRUE
   )
   expect_true(file.exists(file.path(model_dir, "logistic/1-5/rpp_vs_precision_ci.pdf")))
 })

tests/testthat/test-ensures.R

@@ -10,30 +10,22 @@ test_that("ensure_patients_match function works correctly", {
   patient_id_col <- "patient_id"
   gene_id_col <- "gene_id"
 
-  expect_message(
-    result <- ensure_patients_match(expr_tbl, pheno_tbl, patient_id_col, gene_id_col)
-  )
+  result <- ensure_patients_match(expr_tbl, pheno_tbl, patient_id_col, gene_id_col, quiet = TRUE)
   expect_equal(result[["expr_tbl"]], expr_tbl)
   expect_equal(result[["pheno_tbl"]], pheno_tbl)
 
   # less benign input
   # need to move gene_id column to first column
   short_expr_tbl <- expr_tbl |> dplyr::relocate(patient2)
-  expect_message(
-    result <- ensure_patients_match(short_expr_tbl, pheno_tbl, patient_id_col, gene_id_col)
-  )
+  result <- ensure_patients_match(short_expr_tbl, pheno_tbl, patient_id_col, gene_id_col, quiet = TRUE)
   expect_equal(result[["expr_tbl"]][[1]], expr_tbl[[gene_id_col]])
   # need to subset pheno_tbl
   expr_tbl <- expr_tbl |> dplyr::select(!patient2)
-  expect_message(
-    result <- ensure_patients_match(expr_tbl, pheno_tbl, patient_id_col, gene_id_col)
-  )
+  result <- ensure_patients_match(expr_tbl, pheno_tbl, patient_id_col, gene_id_col, quiet = TRUE)
   expect_equal(dim(result[["pheno_tbl"]]), c(1L, 2L))
   # need to subset expr_tbl
   short_pheno_tbl <- pheno_tbl |> dplyr::filter(patient_id == "patient1")
-  expect_message(
-    result <- ensure_patients_match(expr_tbl, short_pheno_tbl, patient_id_col, gene_id_col)
-  )
+  result <- ensure_patients_match(expr_tbl, short_pheno_tbl, patient_id_col, gene_id_col, quiet = TRUE)
   expect_equal(dim(result[["expr_tbl"]]), c(2L, 2L))
   # wrong input
   expect_error(ensure_patients_match(expr_tbl, pheno_tbl, "wrong_patient_id_col", gene_id_col))

tests/testthat/test-prepare_and_fit.R

@@ -40,26 +40,22 @@ test_that("prepare_and_fit() works", {
     include_from_discrete_pheno = NULL
   )
 
-  expect_message(
-    fits <- prepare_and_fit(
-      expr_mat = expr_mat,
-      pheno_tbl = pheno_tbl,
-      data_spec = data_spec,
-      model_spec = model_spec
-    ),
-    regexp = "Creating"
+  fits <- prepare_and_fit(
+    expr_mat = expr_mat,
+    pheno_tbl = pheno_tbl,
+    data_spec = data_spec,
+    model_spec = model_spec,
+    quiet = TRUE
   )
   expect_equal(length(fits), 2)
 
   model_spec$split_index <- split_index
-  expect_message(
-    fits <- prepare_and_fit(
-      expr_mat = expr_mat,
-      pheno_tbl = pheno_tbl,
-      data_spec = data_spec,
-      model_spec = model_spec
-    ),
-    regexp = "Found stored"
+  fits <- prepare_and_fit(
+    expr_mat = expr_mat,
+    pheno_tbl = pheno_tbl,
+    data_spec = data_spec,
+    model_spec = model_spec,
+    quiet = TRUE
   )
   expect_equal(length(fits), length(split_index)+1)
 })

tests/testthat/test-prepare_and_predict.R

@@ -49,7 +49,8 @@ test_that("prepare_and_fit", {
       expr_mat = expr_mat,
       pheno_tbl = pheno_tbl,
       data_spec = data_spec,
-      model_spec = model_spec
+      model_spec = model_spec,
+      quiet = TRUE
   )
 
   data_spec$cohort <- "test"

tests/testthat/test-training_camp.R

@@ -38,7 +38,8 @@ test_that("training_camp() works", {
   expect_no_error(
     training_camp(
       data_spec = data_spec,
-      model_spec_list = list(model_spec_1, model_spec_2)
+      model_spec_list = list(model_spec_1, model_spec_2),
+      quiet = TRUE
     )
   )
 })