From 60c5d80c978e3895b0aaf1f63604758f9f533a1b Mon Sep 17 00:00:00 2001 From: Glen Martin Date: Mon, 24 Apr 2023 16:47:44 +0100 Subject: [PATCH] add test coverage --- .github/workflows/R-CMD-check.yaml | 4 +- .github/workflows/test-coverage.yaml | 50 +++++ DESCRIPTION | 4 +- NAMESPACE | 1 + R/map_newdata.R | 4 + R/predRupdate-package.R | 7 + R/pred_validate.R | 18 +- README.Rmd | 1 + README.md | 2 + codecov.yml | 14 ++ man/predRupdate-package.Rd | 32 ++++ tests/testthat/_snaps/pm_input_info.md | 19 -- .../_snaps/pred_stacked_regression.md | 16 ++ .../testthat/_snaps/pred_validate_logistic.md | 32 ++++ .../testthat/_snaps/pred_validate_survival.md | 25 +++ tests/testthat/test-map_newdata.R | 173 ++++++++++++++++++ tests/testthat/test-pred_predict.R | 130 +++++++++++++ tests/testthat/test-pred_stacked_regression.R | 54 ++++++ tests/testthat/test-pred_update.R | 85 +++++++++ tests/testthat/test-pred_validate_logistic.R | 44 +++++ tests/testthat/test-pred_validate_survival.R | 42 +++++ 21 files changed, 723 insertions(+), 34 deletions(-) create mode 100644 .github/workflows/test-coverage.yaml create mode 100644 R/predRupdate-package.R create mode 100644 codecov.yml create mode 100644 man/predRupdate-package.Rd delete mode 100644 tests/testthat/_snaps/pm_input_info.md create mode 100644 tests/testthat/_snaps/pred_stacked_regression.md create mode 100644 tests/testthat/_snaps/pred_validate_logistic.md create mode 100644 tests/testthat/_snaps/pred_validate_survival.md create mode 100644 tests/testthat/test-map_newdata.R create mode 100644 tests/testthat/test-pred_predict.R create mode 100644 tests/testthat/test-pred_stacked_regression.R create mode 100644 tests/testthat/test-pred_update.R create mode 100644 tests/testthat/test-pred_validate_logistic.R create mode 100644 tests/testthat/test-pred_validate_survival.R diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index d042c21..f4b17a4 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -2,9 +2,9 @@ # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: - branches: [main, master, develop] + branches: [main, master] pull_request: - branches: [main, master, develop] + branches: [main, master] name: R-CMD-check diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..2c5bb50 --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,50 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v3 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr + needs: coverage + + - name: Test coverage + run: | + covr::codecov( + quiet = FALSE, + clean = FALSE, + install_path = file.path(Sys.getenv("RUNNER_TEMP"), "package") + ) + shell: Rscript {0} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v3 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/DESCRIPTION b/DESCRIPTION index f370e47..e55c85f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,6 +21,7 @@ URL: https://github.com/GlenMartin31/predRupdate, https://glenmartin31.github.io/predRupdate/ BugReports: https://github.com/GlenMartin31/predRupdate/issues Suggests: + covr, knitr, rmarkdown, testthat (>= 3.0.0) @@ -30,7 +31,8 @@ Imports: survival, pROC, ggplot2, - ggExtra + ggExtra, + rlang Depends: R (>= 2.10) VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 718516f..21164d5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,3 +27,4 @@ export(pred_predict) export(pred_stacked_regression) export(pred_update) export(pred_validate) +importFrom(rlang,.data) diff --git a/R/map_newdata.R b/R/map_newdata.R index 1414fdd..607b524 100644 --- a/R/map_newdata.R +++ b/R/map_newdata.R @@ -182,6 +182,10 @@ map_newdata.predinfo_survival <- function(x, stop("'new_data' contains factor variables - convert to dummy/indicator variables first \n dummayvar() can help with this") } + if (any(sapply(new_data, function(x) is.character(x)))) { + warning("'new_data' contains character variables - should these be indicator variables (see dummy_vars())?") + } + if (!is.null(binary_outcome)) { stop("'binary_outcome' should be set to NULL if model_type=survival") } diff --git a/R/predRupdate-package.R b/R/predRupdate-package.R new file mode 100644 index 0000000..52c0c07 --- /dev/null +++ b/R/predRupdate-package.R @@ -0,0 +1,7 @@ +#' @keywords internal +"_PACKAGE" + +## usethis namespace: start +#' @importFrom rlang .data +## usethis namespace: end +NULL diff --git a/R/pred_validate.R b/R/pred_validate.R index dd1ccbb..958a9c6 100644 --- a/R/pred_validate.R +++ b/R/pred_validate.R @@ -330,12 +330,6 @@ print.predvalidate_survival <- function(x, ...) { round((x$harrell_C - (stats::qnorm(0.975)*x$harrell_C_SE)), 4), round((x$harrell_C + (stats::qnorm(0.975)*x$harrell_C_SE)), 4)) print(results) - # cat("\n") - # cat("\nOverall Performance Measures \n", - # "================================= \n", sep = "") - # cat("Cox-Snell R-squared: ", round(x$R2_CoxSnell, 4), "\n", sep = "") - # cat("Nagelkerke R-squared: ", round(x$R2_Nagelkerke, 4), "\n", sep = "") - # cat("Brier Score: ", round(x$BrierScore, 4), "\n", sep = "") cat("\n Also examine the histogram of predicted risks. \n") } @@ -409,7 +403,7 @@ validate_logistic <- function(ObservedOutcome, if (cal_plot == FALSE){ plot_df <- data.frame("Prob" = Prob) print(ggplot2::ggplot(plot_df, - ggplot2::aes_string(x = "Prob")) + + ggplot2::aes(x = .data$Prob)) + ggplot2::geom_histogram(bins = 30, colour = "black") + ggplot2::ggtitle("Histogram of the Probability Distribution") + @@ -506,7 +500,7 @@ validate_survival <- function(ObservedOutcome, if (cal_plot == FALSE){ plot_df <- data.frame("Prob" = Prob) print(ggplot2::ggplot(plot_df, - ggplot2::aes_string(x = "Prob")) + + ggplot2::aes(x = .data$Prob)) + ggplot2::geom_histogram(bins = 30, colour = "black") + ggplot2::ggtitle("Histogram of the Probability Distribution") + @@ -571,8 +565,8 @@ flex_calplot <- function(model_type = c("logistic", "survival"), "o" = spline_preds$fit) print(ggExtra::ggMarginal(ggplot2::ggplot(plot_df, - ggplot2::aes_string(x = "p", - y = "o")) + + ggplot2::aes(x = .data$p, + y = .data$o)) + ggplot2::geom_line(ggplot2::aes(linetype = "Calibration Curve", colour = "Calibration Curve")) + ggplot2::xlim(xlim) + @@ -613,8 +607,8 @@ flex_calplot <- function(model_type = c("logistic", "survival"), plot_df$observed_risk <- 1 - (exp(-bh[(max(which(bh[,2] <= time_horizon))),1])^(exp(stats::predict(vcal, type = "lp")))) print(ggExtra::ggMarginal(ggplot2::ggplot(plot_df, - ggplot2::aes_string(x = "Prob", - y = "observed_risk")) + + ggplot2::aes(x = .data$Prob, + y = .data$observed_risk)) + ggplot2::geom_line(ggplot2::aes(linetype = "Calibration Curve", colour = "Calibration Curve")) + ggplot2::xlim(xlim) + diff --git a/README.Rmd b/README.Rmd index 58e9eeb..b975a7f 100644 --- a/README.Rmd +++ b/README.Rmd @@ -17,6 +17,7 @@ knitr::opts_chunk$set( [![R-CMD-check](https://github.com/GlenMartin31/predRupdate/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/GlenMartin31/predRupdate/actions/workflows/R-CMD-check.yaml) +[![Codecov test coverage](https://codecov.io/gh/GlenMartin31/predRupdate/branch/master/graph/badge.svg)](https://app.codecov.io/gh/GlenMartin31/predRupdate?branch=master) The goal of predRupdate is to provide a suite of functions for validating a existing (i.e. previously developed) prediction/ prognostic model, and for applying model updating methods to said model, according to an available dataset. diff --git a/README.md b/README.md index d4cbc0c..0c52ff6 100644 --- a/README.md +++ b/README.md @@ -6,6 +6,8 @@ [![R-CMD-check](https://github.com/GlenMartin31/predRupdate/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/GlenMartin31/predRupdate/actions/workflows/R-CMD-check.yaml) +[![Codecov test +coverage](https://codecov.io/gh/GlenMartin31/predRupdate/branch/master/graph/badge.svg)](https://app.codecov.io/gh/GlenMartin31/predRupdate?branch=master) The goal of predRupdate is to provide a suite of functions for diff --git a/codecov.yml b/codecov.yml new file mode 100644 index 0000000..04c5585 --- /dev/null +++ b/codecov.yml @@ -0,0 +1,14 @@ +comment: false + +coverage: + status: + project: + default: + target: auto + threshold: 1% + informational: true + patch: + default: + target: auto + threshold: 1% + informational: true diff --git a/man/predRupdate-package.Rd b/man/predRupdate-package.Rd new file mode 100644 index 0000000..4ace59f --- /dev/null +++ b/man/predRupdate-package.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predRupdate-package.R +\docType{package} +\name{predRupdate-package} +\alias{predRupdate} +\alias{predRupdate-package} +\title{predRupdate: Prediction Model Validation and Updating} +\description{ +\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} + +Evaluate the predictive performance of an existing (i.e. previously developed) prediction/ prognostic model given relevant information about the existing prediction model (e.g. coefficients) and a new dataset. Provides a range of model updating methods that help tailor the existing model to the new dataset; see Su et al. (2018) \doi{10.1177/0962280215626466}. Techniques to aggregate multiple existing prediction models on the new data are also provided; see Debray et al. (2014) \doi{10.1002/sim.6080} and Martin et al. (2018) \doi{10.1002/sim.7586}). +} +\seealso{ +Useful links: +\itemize{ + \item \url{https://github.com/GlenMartin31/predRupdate} + \item \url{https://glenmartin31.github.io/predRupdate/} + \item Report bugs at \url{https://github.com/GlenMartin31/predRupdate/issues} +} + +} +\author{ +\strong{Maintainer}: Glen P. Martin \email{glen.martin31@gmail.com} (\href{https://orcid.org/0000-0002-3410-9472}{ORCID}) [copyright holder] + +Authors: +\itemize{ + \item David Jenkins \email{david.jenkins-5@manchester.ac.uk} [copyright holder] + \item Matthew Sperrin \email{matthew.sperrin@manchester.ac.uk} [copyright holder] +} + +} +\keyword{internal} diff --git a/tests/testthat/_snaps/pm_input_info.md b/tests/testthat/_snaps/pm_input_info.md deleted file mode 100644 index 9479af4..0000000 --- a/tests/testthat/_snaps/pm_input_info.md +++ /dev/null @@ -1,19 +0,0 @@ -# pm_input_info() outputs required info for model implementation - - Code - pminfo_test1 - Output - Existing Prediction Model of type 'logistic' - - Coefficients = -2, 5, 0.05, 0.06 - Predictors = (Intercept), Age, Age_squared, Age_logged - - Data on which predictions will be made has dimension 4 by 4 : - (Intercept) Age Age_squared Age_logged - 1 1 25 625 3.218876 - 2 1 27 729 3.295837 - 3 1 33 1089 3.496508 - 4 1 21 441 3.044522 - attr(,"assign") - [1] 0 1 2 3 - diff --git a/tests/testthat/_snaps/pred_stacked_regression.md b/tests/testthat/_snaps/pred_stacked_regression.md new file mode 100644 index 0000000..42656a1 --- /dev/null +++ b/tests/testthat/_snaps/pred_stacked_regression.md @@ -0,0 +1,16 @@ +# pred_stacked_regression has expected output + + Code + summary(SR) + Output + Information about 1 existing model(s) of type 'logistic' + + Model Coefficients + ================================= + Intercept Age SexM Smoking_Status Diabetes Creatine + 1 -2.67512 0.005346913 0.1589209 0.5232909 0.2542794 0.4553747 + + Model Functional Form + ================================= + Age + SexM + Smoking_Status + Diabetes + Creatine + diff --git a/tests/testthat/_snaps/pred_validate_logistic.md b/tests/testthat/_snaps/pred_validate_logistic.md new file mode 100644 index 0000000..5270962 --- /dev/null +++ b/tests/testthat/_snaps/pred_validate_logistic.md @@ -0,0 +1,32 @@ +# output of pred_validate is as expected - single models + + Code + print(val_results) + Output + Calibration Measures + ================================= + Estimate Std. Err Lower 95% Confidence Interval + Calibration-in-the-large 0.7323 0.0206 0.6921 + Calibration Slope 0.6484 0.0463 0.5576 + Upper 95% Confidence Interval + Calibration-in-the-large 0.7726 + Calibration Slope 0.7392 + + Also examine the calibration plot, if produced. + + Discrimination Measures + ================================= + Estimate Std. Err Lower 95% Confidence Interval + AUC 0.5814 0.0057 0.5702 + Upper 95% Confidence Interval + AUC 0.5927 + + + Overall Performance Measures + ================================= + Cox-Snell R-squared: -0.0481 + Nagelkerke R-squared: -0.0863 + Brier Score: 0.1249 + + Also examine the histogram of predicted risks. + diff --git a/tests/testthat/_snaps/pred_validate_survival.md b/tests/testthat/_snaps/pred_validate_survival.md new file mode 100644 index 0000000..c74db14 --- /dev/null +++ b/tests/testthat/_snaps/pred_validate_survival.md @@ -0,0 +1,25 @@ +# output of pred_validate is as expected - single models + + Code + print(val_results) + Output + Calibration Measures + ================================= + Estimate Std. Err Lower 95% Confidence Interval + Observed:Expected Ratio 0.6319 0.0113 0.6181 + Calibration Slope 1.0757 0.0389 0.9994 + Upper 95% Confidence Interval + Observed:Expected Ratio 0.6461 + Calibration Slope 1.1519 + + Also examine the calibration plot, if produced. + + Discrimination Measures + ================================= + Estimate Std. Err Lower 95% Confidence Interval + Harrell C 0.5869 0.0032 0.5806 + Upper 95% Confidence Interval + Harrell C 0.5932 + + Also examine the histogram of predicted risks. + diff --git a/tests/testthat/test-map_newdata.R b/tests/testthat/test-map_newdata.R new file mode 100644 index 0000000..431829e --- /dev/null +++ b/tests/testthat/test-map_newdata.R @@ -0,0 +1,173 @@ +test_that("test error messages on checks of map_newdata(), + logistic input", { + + expect_error(map_newdata(x = data.frame("test S3"), + new_data = SYNPM$ValidationData[1:10,], + binary_outcome = "Y")) + + model1 <- pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models[1,]) + + #newdata is not a data.frame + expect_error(map_newdata(x = model1, + new_data = list(SYNPM$ValidationData), + binary_outcome = "Y")) + + #newdata contains factor variables + expect_error(map_newdata(x = model1, + new_data = data.frame(SYNPM$ValidationData, + "X" = factor(sample(c("a", "c", "d"), + size = nrow(SYNPM$ValidationData), + replace = TRUE))), + binary_outcome = "Y")) + + #newdata contains character var + expect_warning(map_newdata(x = model1, + new_data = data.frame(SYNPM$ValidationData, + "X" = (sample(c("a", "c", "d"), + size = nrow(SYNPM$ValidationData), + replace = TRUE))), + binary_outcome = "Y")) + + #specify survival_time for logistic input + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = "Y", + survival_time = "ETime")) + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = "Y", + event_indicator = "Status")) + + #incorrect specification of binary outcome variable + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = factor("Y"))) + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = 3)) + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = c("Y", "Age"))) + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = "Outcome")) + + #not all predictor variables in newdata: + coefs_table <- data.frame("Intercept" = -3.4, + "Sex_M" = 0.306, + "Test_Error" = 0.628) + existing_Logistic_Model <- pred_input_info(model_type = "logistic", + model_info = coefs_table) + expect_error(map_newdata(x = existing_Logistic_Model, + new_data = SYNPM$ValidationData, + binary_outcome = "Y")) + + #intercept not first column: + coefs_table <- data.frame( "SexM" = 0.306, + "Intercept" = -3.4) + expect_error(pred_input_info(model_type = "logistic", + model_info = coefs_table)) + + +}) + + +test_that("test error messages on checks of map_newdata(), + survival input", { + expect_error(map_newdata(x = data.frame("test S3"), + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status")) + + model1 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models[1,]) + + #newdata is not a data.frame + expect_error(map_newdata(x = model1, + new_data = list(SYNPM$ValidationData), + survival_time = "ETime", + event_indicator = "Status")) + + #newdata contains factor variables + expect_error(map_newdata(x = model1, + new_data = data.frame(SYNPM$ValidationData, + "X" = factor(sample(c("a", "c", "d"), + size = nrow(SYNPM$ValidationData), + replace = TRUE))), + survival_time = "ETime", + event_indicator = "Status")) + + #newdata contains character var + expect_warning(map_newdata(x = model1, + new_data = data.frame(SYNPM$ValidationData, + "X" = (sample(c("a", "c", "d"), + size = nrow(SYNPM$ValidationData), + replace = TRUE))), + survival_time = "ETime", + event_indicator = "Status")) + + #specify binary_outcome for survival input + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = "Y", + survival_time = "ETime", + event_indicator = "Status")) + + #incorrect specification of time-to-event outcome variables + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + survival_time = "ETime",#should be both NULL or supplied + event_indicator = NULL)) + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + survival_time = NULL, #should be both NULL or supplied + event_indicator = "Status")) + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + survival_time = factor("ETime"),#should be character var + event_indicator = "Status")) + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = c("Test", "Status"))) #should be length 1 + expect_error(map_newdata(x = model1, + new_data = SYNPM$ValidationData, + survival_time = "T", #not found in newdata + event_indicator = "Status")) + + #not all predictor variables in newdata: + coefs_table <- data.frame("Intercept" = -3.4, + "Sex_M" = 0.306, + "Test_Error" = 0.628) + existing_surv_Model <- pred_input_info(model_type = "survival", + model_info = coefs_table) + expect_error(map_newdata(x = existing_surv_Model, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status")) + + }) + + +test_that("test output format of map_newdata()", { + model1 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models[1,]) + mapped_data <- map_newdata(x = model1, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status") + expect_type(mapped_data, type = "list") + expect_equal(length(mapped_data), 3) + expect_equal(names(mapped_data), c("modelinfo", "PredictionData", "Outcomes")) + + + model2 <- pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models[1,]) + mapped_data <- map_newdata(x = model2, + new_data = SYNPM$ValidationData, + binary_outcome = "Y") + expect_type(mapped_data, type = "list") + expect_equal(length(mapped_data), 3) + expect_equal(names(mapped_data), c("modelinfo", "PredictionData", "Outcomes")) +}) diff --git a/tests/testthat/test-pred_predict.R b/tests/testthat/test-pred_predict.R new file mode 100644 index 0000000..f129be0 --- /dev/null +++ b/tests/testthat/test-pred_predict.R @@ -0,0 +1,130 @@ +test_that("output of pred_predict for logistic model is correct", { + coefs_table <- data.frame("Intercept" = -3.4, + "Sex_M" = 0.306, + "Smoking_Status" = 0.628) + existing_Logistic_Model <- pred_input_info(model_type = "logistic", + model_info = coefs_table) + new_df <- data.frame("Sex" = as.factor(c("M", "F", "M", "M", "F", "F", "M")), + "Smoking_Status" = c(1, 0, 0, 1, 1, 0, 1)) + + expect_error(pred_predict(x = existing_Logistic_Model, + new_data = new_df)) + + #new_df has a factor variable, so needs indicator variables creating before pred_predict: + new_df_indicators <- dummy_vars(new_df) + predout <- pred_predict(x = existing_Logistic_Model, + new_data = new_df_indicators) + + expect_type(predout, type = "list") + expect_equal(length(predout), 3) + expect_equal(names(predout), c("LinearPredictor", "PredictedRisk", "Outcomes")) +}) + + +test_that("output of pred_predict for survival model is correct", { + model2 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models[1,], + cum_hazard = SYNPM$TTE_mod1_baseline) + predout <- pred_predict(x = model2, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = 5) + + expect_type(predout, type = "list") + expect_equal(length(predout), 4) + expect_equal(names(predout), c("LinearPredictor", "PredictedRisk", "TimeHorizon", "Outcomes")) +}) + + +test_that("output of pred_predict for multiple logistic model passing", { + model2 <- pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models) + predout <- pred_predict(x = model2, + new_data = SYNPM$ValidationData, + binary_outcome = "Y") + + expect_type(predout, type = "list") + expect_equal(length(predout), model2$M) + expect_equal(names(predout[[1]]), c("LinearPredictor", "PredictedRisk", "Outcomes")) + expect_equal(names(predout[[2]]), c("LinearPredictor", "PredictedRisk", "Outcomes")) +}) + + +test_that("output of pred_predict for multiple survival model passing", { + model2 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models[1:2,], + cum_hazard = list(SYNPM$TTE_mod1_baseline, + SYNPM$TTE_mod2_baseline)) + predout <- pred_predict(x = model2, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = 5) + + expect_type(predout, type = "list") + expect_equal(length(predout), model2$M) + expect_equal(names(predout[[1]]), c("LinearPredictor", "PredictedRisk", "TimeHorizon", "Outcomes")) + expect_equal(names(predout[[2]]), c("LinearPredictor", "PredictedRisk", "TimeHorizon", "Outcomes")) +}) + + +test_that("output of pred_predict for survival models with no cum_hazard", { + model2 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models, + cum_hazard = list(NULL, + NULL, + NULL)) + predout <- pred_predict(x = model2, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = 5) + + expect_type(predout, type = "list") + expect_equal(length(predout), model2$M) + expect_equal(names(predout[[1]]$PredictedRisk), NULL) + + + model2 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models[2,], + cum_hazard = SYNPM$TTE_mod2_baseline) + predout <- pred_predict(x = model2, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = 5) + + expect_type(predout, type = "list") + expect_equal(length(predout), 4) + expect_equal(names(predout$PredictedRisk), NULL) +}) + + + +test_that("error messages of pred_predict are as expected", { + model2 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models, + cum_hazard = list(SYNPM$TTE_mod1_baseline, + SYNPM$TTE_mod2_baseline, + SYNPM$TTE_mod3_baseline)) + expect_error(pred_predict(x = model2, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = c(3, 4, 5))) #not allowed multiple time_horizons + + expect_error(pred_predict(x = model2, + new_data = SYNPM$ValidationData, + survival_time = "Time", #outcome name wrong + event_indicator = "Status", + time_horizon = 5)) + + expect_error(pred_predict(x = data.frame("test"), #not predinfo object + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = 5)) +}) + + diff --git a/tests/testthat/test-pred_stacked_regression.R b/tests/testthat/test-pred_stacked_regression.R new file mode 100644 index 0000000..036c5e9 --- /dev/null +++ b/tests/testthat/test-pred_stacked_regression.R @@ -0,0 +1,54 @@ +test_that("pred_stacked_regression has expected output", { + LogisticModels <- pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models) + expect_error(pred_stacked_regression(x = data.frame("test"), + new_data = SYNPM$ValidationData, + binary_outcome = "Y")) + expect_error(pred_stacked_regression(x = data.frame("test"), + new_data = SYNPM$ValidationData)) + expect_error(pred_stacked_regression(x = pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models[1,]), + new_data = SYNPM$ValidationData, + binary_outcome = "Y")) + + SR <- pred_stacked_regression(x = LogisticModels, + new_data = SYNPM$ValidationData, + binary_outcome = "Y") + expect_type(SR, type = "list") + expect_equal(names(SR), c("M", "model_type", "coefs", "coef_names", "formula", "model_info", "Stacked_Regression_Weights")) + expect_s3_class(SR, "predSR") + expect_s3_class(SR, "predinfo_logistic") + expect_s3_class(SR, "predinfo") + + SR <- pred_stacked_regression(x = LogisticModels, + new_data = SYNPM$ValidationData, + binary_outcome = "Y", + positivity_constraint = TRUE) + expect_type(SR, type = "list") + expect_equal(names(SR), c("M", "model_type", "coefs", "coef_names", "formula", "model_info", "Stacked_Regression_Weights")) + expect_s3_class(SR, "predSR") + expect_s3_class(SR, "predinfo_logistic") + expect_s3_class(SR, "predinfo") + + expect_snapshot(summary(SR)) + + + TTModels <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models, + cum_hazard = list(SYNPM$TTE_mod1_baseline, + SYNPM$TTE_mod2_baseline, + SYNPM$TTE_mod3_baseline)) + expect_error(pred_stacked_regression(x = TTModels, + new_data = SYNPM$ValidationData)) + + SR <- pred_stacked_regression(x = TTModels, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status") + + expect_type(SR, type = "list") + expect_equal(names(SR), c("M", "model_type", "coefs", "coef_names", "formula", "cum_hazard", "model_info", "Stacked_Regression_Weights")) + expect_s3_class(SR, "predSR") + expect_s3_class(SR, "predinfo_survival") + expect_s3_class(SR, "predinfo") +}) diff --git a/tests/testthat/test-pred_update.R b/tests/testthat/test-pred_update.R new file mode 100644 index 0000000..625f8cd --- /dev/null +++ b/tests/testthat/test-pred_update.R @@ -0,0 +1,85 @@ +test_that("pred_update() has correct outputs", { + model1 <- pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models[1,]) + + expect_error(pred_update(x = "test non S£ calss", + update_type = "recalibration", + new_data = SYNPM$ValidationData, + binary_outcome = "Y")) + + expect_error(pred_update(x = model1, + update_type = "recalibration", + new_data = SYNPM$ValidationData)) + expect_error(pred_update(x = pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models), + update_type = "recalibration", + new_data = SYNPM$ValidationData, + binary_outcome = "Y")) + + intupdate_model1 <- pred_update(x = model1, + update_type = "intercept_update", + new_data = SYNPM$ValidationData, + binary_outcome = "Y") + recalibrated_model1 <- pred_update(x = model1, + update_type = "recalibration", + new_data = SYNPM$ValidationData, + binary_outcome = "Y") + refit_model1 <- pred_update(x = model1, + update_type = "refit", + new_data = SYNPM$ValidationData, + binary_outcome = "Y") + + expect_s3_class(intupdate_model1, c("predUpdate", "predinfo_logistic", "predinfo")) + expect_s3_class(recalibrated_model1, c("predUpdate", "predinfo_logistic", "predinfo")) + expect_s3_class(refit_model1, c("predUpdate", "predinfo_logistic", "predinfo")) + + expect_type(intupdate_model1, type = "list") + expect_equal(names(intupdate_model1), c("M", "model_type", "coefs", "coef_names", "formula", "model_info", "model_update_results", "update_type")) + expect_equal(intupdate_model1$update_type, "intercept_update") + + expect_type(recalibrated_model1, type = "list") + expect_equal(names(recalibrated_model1), c("M", "model_type", "coefs", "coef_names", "formula", "model_info", "model_update_results", "update_type")) + expect_equal(recalibrated_model1$update_type, "recalibration") + + expect_type(refit_model1, type = "list") + expect_equal(names(refit_model1), c("M", "model_type", "coefs", "coef_names", "formula", "model_info", "model_update_results", "update_type")) + expect_equal(refit_model1$update_type, "refit") + + + + model2 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models[1,], + cum_hazard = SYNPM$TTE_mod1_baseline) + intupdate_model2 <- pred_update(x = model2, + update_type = "intercept_update", + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status") + recalibrated_model2 <- pred_update(x = model2, + update_type = "recalibration", + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status") + refit_model2 <- pred_update(x = model2, + update_type = "refit", + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status") + + expect_s3_class(intupdate_model2, c("predUpdate", "predinfo_survival", "predinfo")) + expect_s3_class(recalibrated_model2, c("predUpdate", "predinfo_survival", "predinfo")) + expect_s3_class(refit_model2, c("predUpdate", "predinfo_survival", "predinfo")) + + expect_type(intupdate_model2, type = "list") + expect_equal(names(intupdate_model2), c("M", "model_type", "coefs", "coef_names", "formula", "cum_hazard", "model_info", "model_update_results", "update_type")) + expect_equal(intupdate_model2$update_type, "intercept_update") + + expect_type(recalibrated_model2, type = "list") + expect_equal(names(recalibrated_model2), c("M", "model_type", "coefs", "coef_names", "formula", "cum_hazard", "model_info", "model_update_results", "update_type")) + expect_equal(recalibrated_model2$update_type, "recalibration") + + expect_type(refit_model2, type = "list") + expect_equal(names(refit_model2), c("M", "model_type", "coefs", "coef_names", "formula", "cum_hazard", "model_info", "model_update_results", "update_type")) + expect_equal(refit_model2$update_type, "refit") + +}) diff --git a/tests/testthat/test-pred_validate_logistic.R b/tests/testthat/test-pred_validate_logistic.R new file mode 100644 index 0000000..3615a84 --- /dev/null +++ b/tests/testthat/test-pred_validate_logistic.R @@ -0,0 +1,44 @@ +test_that("output of pred_validate is as expected - single models", { + + expect_error(pred_validate(x = "test S3 class", + new_data = SYNPM$ValidationData, + binary_outcome = "Y")) + + model1 <- pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models[1,]) + expect_error(pred_validate(x = model1, + new_data = SYNPM$ValidationData)) #no outcome given + + val_results <- pred_validate(x = model1, + new_data = SYNPM$ValidationData, + binary_outcome = "Y") + expect_s3_class(val_results, c("predvalidate_logistic", "predvalidate")) + expect_type(val_results, type = "list") + expect_equal(names(val_results), + c("CITL", "CITL_SE", "CalSlope", "CalSlope_SE", "AUC", + "AUC_SE", "R2_CoxSnell", "R2_Nagelkerke", "BrierScore")) + + expect_snapshot(print(val_results)) + +}) + + + +test_that("output of pred_validate is as expected - multiple models", { + + model2 <- pred_input_info(model_type = "logistic", + model_info = SYNPM$Existing_logistic_models) + val_results <- pred_validate(x = model2, + new_data = SYNPM$ValidationData, + binary_outcome = "Y", + cal_plot = FALSE) + + expect_type(val_results, type = "list") + expect_equal(length(val_results), model2$M) + + expect_s3_class(val_results[[1]], c("predvalidate_logistic", "predvalidate")) + expect_type(val_results[[1]], type = "list") + expect_equal(names(val_results[[1]]), + c("CITL", "CITL_SE", "CalSlope", "CalSlope_SE", "AUC", + "AUC_SE", "R2_CoxSnell", "R2_Nagelkerke", "BrierScore")) +}) diff --git a/tests/testthat/test-pred_validate_survival.R b/tests/testthat/test-pred_validate_survival.R new file mode 100644 index 0000000..a733166 --- /dev/null +++ b/tests/testthat/test-pred_validate_survival.R @@ -0,0 +1,42 @@ +test_that("output of pred_validate is as expected - single models", { + + model1 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models[2,], + cum_hazard = SYNPM$TTE_mod2_baseline) + val_results<- pred_validate(x = model1, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = 5) + expect_s3_class(val_results, c("predvalidate_survival", "predvalidate")) + expect_type(val_results, type = "list") + expect_equal(names(val_results), + c("OE_ratio", "OE_ratio_SE", "CalSlope", "CalSlope_SE", "harrell_C", + "harrell_C_SE")) + + expect_snapshot(print(val_results)) +}) + +test_that("output of pred_validate is as expected - multiple models", { + + model2 <- pred_input_info(model_type = "survival", + model_info = SYNPM$Existing_TTE_models, + cum_hazard = list(SYNPM$TTE_mod1_baseline, + SYNPM$TTE_mod2_baseline, + SYNPM$TTE_mod3_baseline)) + val_results<- pred_validate(x = model2, + new_data = SYNPM$ValidationData, + survival_time = "ETime", + event_indicator = "Status", + time_horizon = 5, + cal_plot = FALSE) + + expect_type(val_results, type = "list") + expect_equal(length(val_results), model2$M) + + expect_s3_class(val_results[[1]], c("predvalidate_survival", "predvalidate")) + expect_type(val_results[[1]], type = "list") + expect_equal(names(val_results[[1]]), + c("OE_ratio", "OE_ratio_SE", "CalSlope", "CalSlope_SE", "harrell_C", + "harrell_C_SE")) +})