finish docs

OHDSI · Nov 11, 2024 · e4bb3e5 · e4bb3e5
1 parent ada8491
commit e4bb3e5
Show file tree

Hide file tree

Showing 2 changed files with 76 additions and 63 deletions.
diff --git a/R/Recalibration.R b/R/Recalibration.R
@@ -26,23 +26,22 @@
 #' @param newPopulation                    The population created using createStudyPopulation() who will have their risks predicted
 #' @param newData                          An object of type \code{plpData} - the patient level prediction
 #'                                         data extracted from the CDM.
+#' @param returnModel                      Logical: return the refitted model
 #' @return
 #' An prediction dataframe with the predictions of the recalibrated model added
 #'
 #' @export
 recalibratePlpRefit <- function(
     plpModel,
     newPopulation,
-    newData) {
-  if (is.null(newPopulation)) {
-    stop("NULL population")
-  }
-  if (!inherits(x = newData, what = "plpData")) {
-    stop("Incorrect plpData class")
-  }
-  if (!inherits(x = plpModel, what = "plpModel")) {
-    stop("plpModel is not of class plpModel")
-  }
+    newData, 
+    returnModel = FALSE) {
+  checkNotNull(plpModel)
+  checkNotNull(newPopulation)
+  checkNotNull(newData)
+  checkIsClass(plpModel, "plpModel")
+  checkIsClass(newData, "plpData")
+  checkBoolean(returnModel)
 
   # get selected covariates
   includeCovariateIds <- plpModel$covariateImportance %>%
@@ -130,8 +129,12 @@ recalibratePlpRefit <- function(
   newIntercept <- newModel$model$coefficients[names(newModel$model$coefficients) == "(Intercept)"]
 
   attr(prediction, "metaData")$recalibratePlpRefit <- list(adjust = adjust, newIntercept = newIntercept)
-
-  return(prediction)
+
+  if (returnModel) {
+    return(list(prediction = prediction, model = newModel))
+  } else {
+    return(prediction)
+  }
 }
 
 
@@ -141,7 +144,10 @@ recalibratePlpRefit <- function(
 #' Recalibrating a model using the recalibrationInTheLarge or weakRecalibration methods 
 #' 
 #' @details
-#' TODO: Add more details about available methods
+#' 'recalibrationInTheLarge' calculates a single correction factor for the 
+#' average predicted risks to match the average observed risks.
+#' 'weakRecalibration' fits a glm model to the logit of the predicted risks,
+#' also known as Platt scaling/logistic recalibration.
 #'
 #' @param prediction                      A prediction dataframe
 #' @param analysisId                      The model analysisId
@@ -208,7 +214,9 @@ recalibrationInTheLarge <- function(prediction, columnType = "evaluationType") {
 #' weakRecalibration
 #' 
 #' @description 
-#' Recalibrate a model using the weakRecalibration method which fits a glm model to the logit of the predicted risks
+#' Recalibrate a model using the weakRecalibration method which fits a glm model
+#' to the logit of the predicted risks.
+#' Alsi known as Platt scaling/logistic recalibration
 #' @param prediction                    A prediction dataframe
 #' @param columnType                    The column name where the strata types are specified
 #' @return 

diff --git a/tests/testthat/test-recalibration.R b/tests/testthat/test-recalibration.R
@@ -21,16 +21,16 @@ context("Recalibration")
 
 prediction <- data.frame(
   rowId = 1:100,
-  value = c(runif(20)/30,runif(80)/300),
-  outcomeCount = c(runif(20)>0.5, runif(80)>0.9)*1,
+  value = c(runif(20) / 30, runif(80) / 300),
+  outcomeCount = c(runif(20) > 0.5, runif(80) > 0.9) * 1,
   gender = sample(c(8507, 1111), 100, replace = T),
-  ageYear = sample(1:100,100, replace = T ),
-  survivalTime = rep(365,100),
-  evaluationType = rep('Test', 100)
-  )
+  ageYear = sample(1:100, 100, replace = T),
+  survivalTime = rep(365, 100),
+  evaluationType = rep("Test", 100)
+)
 
 metaData <- list(
-  modelType = "binary", 
+  modelType = "binary",
   targetId = 1,
   outcomeId = outcomeId,
   timepoint = 365
@@ -39,75 +39,80 @@ metaData <- list(
 attr(prediction, "metaData") <- metaData
 
 test_that("recalibrationInTheLarge", {
-
-  test <- recalibratePlp(prediction, analysisId = 'Analysis_1',
-                 method = 'recalibrationInTheLarge')
-
-  testthat::expect_true(sum(test$evaluationType == 'recalibrationInTheLarge') == 100)
-
+  test <- recalibratePlp(prediction,
+    analysisId = "Analysis_1",
+    method = "recalibrationInTheLarge"
+  )
+
+  testthat::expect_true(sum(test$evaluationType == "recalibrationInTheLarge") == 100)
 })
 
 
-#'weakRecalibration'
+#' weakRecalibration'
 test_that("weakRecalibration", {
+  test <- recalibratePlp(prediction,
+    analysisId = "Analysis_1",
+    method = "weakRecalibration"
+  )
 
-test <- recalibratePlp(prediction, analysisId = 'Analysis_1',
-                       method = 'weakRecalibration')
-
-testthat::expect_true(sum(test$evaluationType == 'weakRecalibration') == 100)
-
+  testthat::expect_true(sum(test$evaluationType == "weakRecalibration") == 100)
 })
 
 
-
-
 test_that("recalibratePlpRefit", {
-
-  newPop <- plpResult$prediction %>% dplyr::select(-"value") %>% dplyr::filter(.data$evaluationType %in% c('Test','Train'))
-  attr(newPop, 'metaData') <- list(
-    targetId = 1, 
+  newPop <- plpResult$prediction %>%
+    dplyr::select(-"value") %>%
+    dplyr::filter(.data$evaluationType %in% c("Test", "Train"))
+  attr(newPop, "metaData") <- list(
+    targetId = 1,
     outcomeId = outcomeId,
     restrictPlpDataSettings = PatientLevelPrediction::createRestrictPlpDataSettings(),
     populationSettings = PatientLevelPrediction::createStudyPopulationSettings()
   )
-  
+
   testRecal <- recalibratePlpRefit(
-    plpModel = plpResult$model, 
-    newPopulation = newPop, 
+    plpModel = plpResult$model,
+    newPopulation = newPop,
     newData = plpData
   )
-  
-  if(!is.null(testRecal)){
+
+  if (!is.null(testRecal)) {
     testthat::expect_true(
-      sum(testRecal$evaluationType == 'recalibrationRefit')>0
+      sum(testRecal$evaluationType == "recalibrationRefit") > 0
     )
-
-    testthat::expect_s3_class(testRecal, 'data.frame')
+    testthat::expect_s3_class(testRecal, "data.frame")
   }
 
+  testRecalWithModel <- recalibratePlpRefit(
+    plpModel = plpResult$model,
+    newPopulation = newPop,
+    newData = plpData,
+    returnModel = TRUE
+  )
+  expect_type(testRecalWithModel, "list")
+  expect_s3_class(testRecalWithModel$model, "plpModel")
+  expect_s3_class(testRecalWithModel$prediction, "data.frame")
+
   # add more test...
 })
 
 
 
 test_that("survival", {
-# survival
-metaData <- list(
-  modelType = "survival", 
-  targetId = 1,
-  outcomeId = outcomeId,
-  timepoint = 365
-)
+  # survival
+  metaData <- list(
+    modelType = "survival",
+    targetId = 1,
+    outcomeId = outcomeId,
+    timepoint = 365
+  )
 
-attr(prediction, "metaData") <- metaData
+  attr(prediction, "metaData") <- metaData
 
-  test <- recalibratePlp(prediction, analysisId = 'Analysis_1',
-    method = 'weakRecalibration')
+  test <- recalibratePlp(prediction,
+    analysisId = "Analysis_1",
+    method = "weakRecalibration"
+  )
 
-  testthat::expect_true(sum(test$evaluationType == 'weakRecalibration') == 100)
-
+  testthat::expect_true(sum(test$evaluationType == "weakRecalibration") == 100)
 })
-
-
-
-