From 95d24784d8f1bfd5f4853486b137b63cb5cef496 Mon Sep 17 00:00:00 2001 From: Lukas Gessl Date: Wed, 7 Feb 2024 13:55:48 +0000 Subject: [PATCH] make test suite quiet --- R/ass_0d_spec.R | 3 ++- R/assess_0d.R | 18 +++++++-------- R/assess_2d_center.R | 2 +- R/asssess_2d.R | 1 + R/ensures.R | 10 ++++---- R/plot.R | 2 +- R/prepare_and_fit.R | 3 ++- man/ensure_patients_match.Rd | 4 ++-- tests/testthat/test-assess_2d.R | 12 ++++++---- tests/testthat/test-assess_2d_center.R | 12 ++++++---- tests/testthat/test-ensures.R | 16 ++++--------- tests/testthat/test-prepare_and_fit.R | 28 ++++++++++------------- tests/testthat/test-prepare_and_predict.R | 3 ++- tests/testthat/test-training_camp.R | 3 ++- 14 files changed, 59 insertions(+), 58 deletions(-) diff --git a/R/ass_0d_spec.R b/R/ass_0d_spec.R index 851c569..f22d2cb 100644 --- a/R/ass_0d_spec.R +++ b/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")) } \ No newline at end of file diff --git a/R/assess_0d.R b/R/assess_0d.R index 80927fc..afda5ac 100644 --- a/R/assess_0d.R +++ b/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) diff --git a/R/assess_2d_center.R b/R/assess_2d_center.R index d87c1ef..3a3462f 100644 --- a/R/assess_2d_center.R +++ b/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 diff --git a/R/asssess_2d.R b/R/asssess_2d.R index 243cbd2..5f1bb88 100644 --- a/R/asssess_2d.R +++ b/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 ) diff --git a/R/ensures.R b/R/ensures.R index 5b66a87..2c841c6 100644 --- a/R/ensures.R +++ b/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( diff --git a/R/plot.R b/R/plot.R index 4c8bc99..e1e2ef7 100644 --- a/R/plot.R +++ b/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 diff --git a/R/prepare_and_fit.R b/R/prepare_and_fit.R index 293f989..c4f6594 100644 --- a/R/prepare_and_fit.R +++ b/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" diff --git a/man/ensure_patients_match.Rd b/man/ensure_patients_match.Rd index 3337272..fcddbec 100644 --- a/man/ensure_patients_match.Rd +++ b/man/ensure_patients_match.Rd @@ -9,7 +9,7 @@ ensure_patients_match( pheno_tbl, patient_id_col = "patient_id", gene_id_col = "gene_id", - verbose = TRUE + quiet = FALSE ) } \arguments{ @@ -26,7 +26,7 @@ the patient identifiers.} \item{gene_id_col}{string. The name of the column in \code{expr} that holds the gene identifiers.} -\item{verbose}{logical. Whether to print messages. Default is \code{FALSE}.} +\item{quiet}{logical. Whether to print messages. Default is \code{FALSE}.} } \value{ A list with two tibbles named \code{expr} and \code{pheno}. Matching and sorted diff --git a/tests/testthat/test-assess_2d.R b/tests/testthat/test-assess_2d.R index a6463e6..401984f 100644 --- a/tests/testthat/test-assess_2d.R +++ b/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")) }) diff --git a/tests/testthat/test-assess_2d_center.R b/tests/testthat/test-assess_2d_center.R index 484e596..e95ccea 100644 --- a/tests/testthat/test-assess_2d_center.R +++ b/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"))) }) diff --git a/tests/testthat/test-ensures.R b/tests/testthat/test-ensures.R index a2f3355..54fce42 100644 --- a/tests/testthat/test-ensures.R +++ b/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)) diff --git a/tests/testthat/test-prepare_and_fit.R b/tests/testthat/test-prepare_and_fit.R index 1623ca2..071e465 100644 --- a/tests/testthat/test-prepare_and_fit.R +++ b/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) }) \ No newline at end of file diff --git a/tests/testthat/test-prepare_and_predict.R b/tests/testthat/test-prepare_and_predict.R index 5ee990d..6d1681c 100644 --- a/tests/testthat/test-prepare_and_predict.R +++ b/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" diff --git a/tests/testthat/test-training_camp.R b/tests/testthat/test-training_camp.R index 7688595..2428f8e 100644 --- a/tests/testthat/test-training_camp.R +++ b/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 ) ) })