Reduce R CMD check runtime overhead

.github/workflows/R_CMD_check_Hades.yaml

@@ -3,7 +3,8 @@
 on:
   push:
     branches:
-      - '**'
+      - develop
+      - main
   pull_request:
     branches:
       - '**'
@@ -111,14 +112,24 @@ jobs:
           path: check/*.tar.gz
 
       - name: Install covr
-        if: runner.os == 'macOS'
+        if: >-
+          runner.os == 'macOS' &&
+          (
+            (github.event_name == 'push' && (github.ref_name == 'develop' || github.ref_name == 'main')) ||
+            (github.event_name == 'pull_request' && (github.base_ref == 'develop' || github.base_ref == 'main'))
+          )
         run: |
           install.packages("remotes")
           remotes::install_cran("covr")
         shell: Rscript {0}
 
       - name: Test coverage
-        if: runner.os == 'macOS'
+        if: >-
+          runner.os == 'macOS' &&
+          (
+            (github.event_name == 'push' && (github.ref_name == 'develop' || github.ref_name == 'main')) ||
+            (github.event_name == 'pull_request' && (github.base_ref == 'develop' || github.base_ref == 'main'))
+          )
         run: covr::codecov(token = "${{ secrets.CODECOV_TOKEN }}")
         shell: Rscript {0}
 

R/uploadToDatabase.R

@@ -738,7 +738,9 @@ insertModelInDatabase <- function(
   )
   hyperparameterSettings <- NULL
   if (!is.null(model$modelDesign) && is.list(model$modelDesign)) {
-    hyperparameterSettings <- model$modelDesign$hyperparameterSettings
+    hyperparameterSettings <- sanitizeHyperparameterSettingsForDatabase(
+      model$modelDesign$hyperparameterSettings
+    )
   }
   trainDetails <- list(
     hyperParamSearch = hyperParamSearch,
@@ -813,6 +815,67 @@ normalizeHyperParamSearchForDatabase <- function(hyperParamSearch) {
   data.frame()
 }
 
+sanitizeObjectForDatabaseJson <- function(x) {
+  if (is.null(x)) {
+    return(NULL)
+  }
+  if (is.function(x)) {
+    return(list(type = "function"))
+  }
+  if (is.environment(x)) {
+    return(list(type = "environment"))
+  }
+  if (is.atomic(x)) {
+    return(x)
+  }
+  if (is.data.frame(x)) {
+    return(as.data.frame(lapply(x, sanitizeObjectForDatabaseJson), stringsAsFactors = FALSE))
+  }
+  if (is.list(x)) {
+    return(lapply(x, sanitizeObjectForDatabaseJson))
+  }
+  as.character(x)
+}
+
+sanitizeTuningMetricForDatabase <- function(tuningMetric) {
+  if (is.null(tuningMetric)) {
+    return(NULL)
+  }
+
+  list(
+    name = tuningMetric$name,
+    maximize = tuningMetric$maximize,
+    funArgs = sanitizeObjectForDatabaseJson(tuningMetric$funArgs)
+  )
+}
+
+sanitizeGeneratorForDatabase <- function(generator) {
+  if (is.null(generator)) {
+    return(NULL)
+  }
+  if (is.function(generator)) {
+    return(list(type = "function"))
+  }
+  list(
+    type = paste(class(generator), collapse = "/"),
+    methods = intersect(c("initialize", "getNext", "finalize"), names(generator))
+  )
+}
+
+sanitizeHyperparameterSettingsForDatabase <- function(hyperparameterSettings) {
+  if (is.null(hyperparameterSettings)) {
+    return(NULL)
+  }
+
+  list(
+    search = hyperparameterSettings$search,
+    tuningMetric = sanitizeTuningMetricForDatabase(hyperparameterSettings$tuningMetric),
+    sampleSize = hyperparameterSettings$sampleSize,
+    randomSeed = hyperparameterSettings$randomSeed,
+    generator = sanitizeGeneratorForDatabase(hyperparameterSettings$generator)
+  )
+}
+
 addModel <- function(
     conn,
     resultSchema,

R/uploadToDatabaseModelDesign.R

@@ -1097,6 +1097,7 @@ addHyperparameterSetting <- function(
     json,
     tempEmulationSchema = getOption("sqlRenderTempEmulationSchema")) {
   if (!inherits(x = json, what = "character")) {
+    json <- sanitizeHyperparameterSettingsForDatabase(json)
     json <- orderJson(json) # to ensure attributes are alphabetic order
     json <- ParallelLogger::convertSettingsToJson(json)
     json <- as.character(json) # now convert to character

tests/testthat/test-UploadToDatabase.R

@@ -384,6 +384,73 @@ test_that("normalizeHyperParamSearchForDatabase handles all supported shapes", {
   expect_equal(nrow(normalizedUnknown), 0)
 })
 
+test_that("sanitizeHyperparameterSettingsForDatabase stores metric metadata only", {
+  capturedData <- seq_len(10000)
+  metric <- createTuningMetric(
+    fun = function(prediction) mean(prediction$value) + length(capturedData),
+    maximize = FALSE,
+    name = "CustomLargeClosure",
+    funArgs = list(cutoff = 0.75)
+  )
+  settings <- createHyperparameterSettings(
+    tuningMetric = metric,
+    generator = function(definition, expanded, settings) expanded[1]
+  )
+
+  sanitized <- PatientLevelPrediction:::sanitizeHyperparameterSettingsForDatabase(settings)
+  json <- as.character(ParallelLogger::convertSettingsToJson(sanitized))
+
+  expect_equal(sanitized$search, "custom")
+  expect_equal(sanitized$tuningMetric$name, "CustomLargeClosure")
+  expect_false(sanitized$tuningMetric$maximize)
+  expect_equal(sanitized$tuningMetric$funArgs$cutoff, 0.75)
+  expect_null(sanitized$tuningMetric[["fun", exact = TRUE]])
+  expect_equal(sanitized$generator$type, "function")
+  expect_lt(nchar(json), 1000)
+})
+
+test_that("sanitizeHyperparameterSettingsForDatabase handles optional and non-json fields", {
+  env <- new.env(parent = emptyenv())
+  env$value <- 1
+  object <- structure(list(x = 1), class = "customThing")
+  generator <- list(
+    initialize = function(definition, settings) invisible(NULL),
+    getNext = function(history) NULL
+  )
+
+  expect_null(PatientLevelPrediction:::sanitizeObjectForDatabaseJson(NULL))
+  expect_equal(
+    PatientLevelPrediction:::sanitizeObjectForDatabaseJson(function() NULL),
+    list(type = "function")
+  )
+  expect_equal(
+    PatientLevelPrediction:::sanitizeObjectForDatabaseJson(env),
+    list(type = "environment")
+  )
+  expect_equal(
+    PatientLevelPrediction:::sanitizeObjectForDatabaseJson(data.frame(
+      keep = 1,
+      drop = I(list(function() NULL))
+    )),
+    data.frame(
+      keep = 1,
+      type = "function"
+    )
+  )
+  expect_equal(PatientLevelPrediction:::sanitizeObjectForDatabaseJson(object), list(x = 1))
+  expect_equal(
+    PatientLevelPrediction:::sanitizeObjectForDatabaseJson(stats::as.formula("~ x")),
+    c("~", "x")
+  )
+  expect_null(PatientLevelPrediction:::sanitizeTuningMetricForDatabase(NULL))
+  expect_null(PatientLevelPrediction:::sanitizeGeneratorForDatabase(NULL))
+  expect_equal(
+    PatientLevelPrediction:::sanitizeGeneratorForDatabase(generator),
+    list(type = "list", methods = c("initialize", "getNext"))
+  )
+  expect_null(PatientLevelPrediction:::sanitizeHyperparameterSettingsForDatabase(NULL))
+})
+
 test_that("insertModelDesignInDatabase handles missing hyperparameterSettings in runPlp model", {
   skip_if_not_installed(c("ResultModelManager", "Eunomia"))
   skip_if_offline()