diff --git a/.github/workflows/R_CMD_check_Hades.yaml b/.github/workflows/R_CMD_check_Hades.yaml index f1c6a0473..f2a3d56f5 100644 --- a/.github/workflows/R_CMD_check_Hades.yaml +++ b/.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} diff --git a/R/uploadToDatabase.R b/R/uploadToDatabase.R index 6f463b11e..b669e23ae 100644 --- a/R/uploadToDatabase.R +++ b/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, diff --git a/R/uploadToDatabaseModelDesign.R b/R/uploadToDatabaseModelDesign.R index 2aa5b607f..a7f00ad45 100644 --- a/R/uploadToDatabaseModelDesign.R +++ b/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 diff --git a/tests/testthat/test-UploadToDatabase.R b/tests/testthat/test-UploadToDatabase.R index dfd3a120a..aac150af6 100644 --- a/tests/testthat/test-UploadToDatabase.R +++ b/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()