diff --git a/DESCRIPTION b/DESCRIPTION index 1b03dcd04..e6d661a49 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,6 +41,7 @@ Imports: tidyr, utils Suggests: + BrokenAdaptiveRidge, curl, Eunomia (>= 2.0.0), glmnet, diff --git a/NAMESPACE b/NAMESPACE index d0d2327a4..f05473878 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -104,6 +104,7 @@ export(savePlpResult) export(savePlpShareable) export(savePrediction) export(setAdaBoost) +export(setBrokenAdaptiveRidge) export(setCoxModel) export(setDecisionTree) export(setGradientBoostingMachine) diff --git a/R/CyclopsModels.R b/R/CyclopsModels.R index 7d6768153..c327d231f 100644 --- a/R/CyclopsModels.R +++ b/R/CyclopsModels.R @@ -94,13 +94,32 @@ fitCyclopsModel <- function( if (settings$crossValidationInPrior) { param$priorParams$useCrossValidation <- max(trainData$folds$index) > 1 } - prior <- do.call(eval(parse(text = settings$priorfunction)), param$priorParams) + + modelSettingsForFit <- modelSettings + param <- resolveCyclopsPriorParams( + param = param, + cyclopsData = cyclopsData, + labels = trainData$labels, + folds = trainData$folds, + settings = settings + ) + modelSettingsForFit$param <- param + hyperParamSearch <- data.frame() + + prior <- NULL + if (!isTRUE(settings$manualPenaltyCv)) { + prior <- do.call(eval(parse(text = settings$priorfunction)), param$priorParams) + } if (settings$useControl) { + startingVariance <- param$priorParams$variance + if (is.null(startingVariance)) { + startingVariance <- param$priorParams$initialRidgeVariance + } control <- Cyclops::createControl( cvType = "auto", fold = max(trainData$folds$index), - startingVariance = param$priorParams$variance, + startingVariance = startingVariance, lowerLimit = param$lowerLimit, upperLimit = param$upperLimit, tolerance = settings$tolerance, @@ -125,6 +144,18 @@ fitCyclopsModel <- function( }, finally = ParallelLogger::logInfo("Done.") ) + } else if (isTRUE(settings$manualPenaltyCv)) { + result <- doCyclopsCvPenalty( + trainData = trainData, + cyclopsData = cyclopsData, + modelSettings = modelSettingsForFit, + fixedCoefficients = fixedCoefficients, + startingCoefficients = startingCoefficients, + warmStart = isTRUE(settings$manualPenaltyCvWarmStart) + ) + fit <- result$modelFit + hyperParamSearch <- result$hyperParamSearch + modelSettingsForFit <- result$modelSettings } else { fit <- tryCatch( { @@ -143,7 +174,7 @@ fitCyclopsModel <- function( cyclopsData = cyclopsData, labels = trainData$covariateData$labels, folds = trainData$folds, - modelSettings = modelSettings, + modelSettings = modelSettingsForFit, covariateData = trainData$covariateData ) @@ -206,6 +237,7 @@ fitCyclopsModel <- function( # remove the cv from the model: modelTrained$cv <- NULL } + hyperParamSearch <- dplyr::bind_rows(hyperParamSearch, cvPerFold) result <- list( model = modelTrained, @@ -223,7 +255,7 @@ fitCyclopsModel <- function( populationSettings = attr(trainData, "metaData")$populationSettings, featureEngineeringSettings = attr(trainData, "metaData")$featureEngineeringSettings, preprocessSettings = attr(trainData$covariateData, "metaData")$preprocessSettings, - modelSettings = modelSettings, # modified + modelSettings = modelSettingsForFit, # modified splitSettings = attr(trainData, "metaData")$splitSettings, sampleSettings = attr(trainData, "metaData")$sampleSettings ), @@ -240,7 +272,7 @@ fitCyclopsModel <- function( variance = modelTrained$priorVariance, log_likelihood = modelTrained$log_likelihood ), - hyperParamSearch = cvPerFold + hyperParamSearch = hyperParamSearch ), covariateImportance = variableImportance ) @@ -498,6 +530,9 @@ createCyclopsCvPrior <- function(modelSettings, fit, cyclopsData) { forceIntercept = isTRUE(priorParams$forceIntercept) )) } + if (grepl("^BrokenAdaptiveRidge::create", priorFunction)) { + return(do.call(eval(parse(text = priorFunction)), priorParams)) + } stop( "Cyclops fit did not return fitted final prior variances for CV refitting" @@ -552,6 +587,188 @@ checkCyclopsCovariates <- function(cyclopsData, covariates) { covariates } +resolveCyclopsPriorParams <- function( + param, + cyclopsData, + labels, + folds, + settings) { + if (!is.null(param$priorParams$penalty) && identical(param$priorParams$penalty, "logN")) { + param$priorParams$penalty <- log(nrow(labels)) / 2 + } + if (!is.null(param$priorParams$initialRidgeVariance) && + identical(param$priorParams$initialRidgeVariance, "auto")) { + normalPrior <- Cyclops::createPrior( + priorType = "normal", + useCrossValidation = max(folds$index) > 1 + ) + normalControl <- Cyclops::createControl( + cvType = "auto", + fold = max(folds$index), + lowerLimit = param$lowerLimit, + upperLimit = param$upperLimit, + tolerance = settings$tolerance, + cvRepetitions = 1, + selectorType = settings$selectorType, + noiseLevel = "silent", + threads = settings$threads, + maxIterations = settings$maxIterations, + seed = settings$seed + ) + + ridgeFit <- tryCatch( + { + ParallelLogger::logInfo("Determining initialRidgeVariance") + Cyclops::fitCyclopsModel( + cyclopsData = cyclopsData, + prior = normalPrior, + control = normalControl + ) + }, + finally = ParallelLogger::logInfo("Done.") + ) + param$priorParams$initialRidgeVariance <- ridgeFit$variance + } + param +} + +doCyclopsCvPenalty <- function( + trainData, + cyclopsData, + modelSettings, + fixedCoefficients = NULL, + startingCoefficients = NULL, + warmStart = TRUE) { + if (max(trainData$folds$index) < 2) { + stop('penalty = "auto" requires at least two training folds') + } + + penalties <- createBarPenaltyGrid( + labels = trainData$labels, + penaltyRatio = modelSettings$settings$penaltyRatio, + penaltyGridSize = modelSettings$settings$penaltyGridSize + ) + control <- Cyclops::createControl( + tolerance = modelSettings$settings$tolerance, + noiseLevel = "silent", + threads = modelSettings$settings$threads, + maxIterations = modelSettings$settings$maxIterations, + seed = modelSettings$settings$seed + ) + + ParallelLogger::logInfo("Performing hyperparameter tuning to determine best BAR penalty") + labels <- merge(trainData$covariateData$labels, trainData$folds, by = "rowId") + cvByFold <- lapply(seq_len(max(labels$index)), function(i) { + holdOut <- labels$index == i + weights <- rep(1.0, Cyclops::getNumberOfRows(cyclopsData)) + weights[holdOut] <- 0.0 + foldStartingCoefficients <- startingCoefficients + + foldSearch <- vector("list", length(penalties)) + for (penaltyIndex in seq_along(penalties)) { + penalty <- penalties[penaltyIndex] + candidateSettings <- modelSettings + candidateSettings$param$priorParams$penalty <- penalty + cvPrior <- do.call( + eval(parse(text = candidateSettings$settings$priorfunction)), + candidateSettings$param$priorParams + ) + + subsetFit <- suppressWarnings(Cyclops::fitCyclopsModel( + cyclopsData, + prior = cvPrior, + control = control, + weights = weights, + fixedCoefficients = fixedCoefficients, + startingCoefficients = foldStartingCoefficients + )) + coefficients <- stats::coef(subsetFit) + if (isTRUE(warmStart)) { + foldStartingCoefficients <- as.numeric(coefficients) + } + + coefDf <- data.frame( + betas = as.numeric(coefficients), + covariateIds = names(coefficients), + stringsAsFactors = FALSE + ) + predAll <- predictCyclopsType( + coefficients = coefDf, + population = labels, + covariateData = trainData$covariateData, + modelType = candidateSettings$settings$cyclopsModelType + ) + auc <- aucWithoutCi(predAll$rawValue[holdOut], labels$y[holdOut]) + foldSearch[[penaltyIndex]] <- data.frame( + metric = "AUC", + fold = paste0("Fold", i), + value = auc, + penalty = penalty, + stringsAsFactors = FALSE + ) + } + foldSearch + }) + hyperParamSearch <- dplyr::bind_rows(unlist(cvByFold, recursive = FALSE)) + cvMeans <- hyperParamSearch %>% + dplyr::group_by(.data$penalty) %>% + dplyr::summarise(value = mean(.data$value, na.rm = TRUE), .groups = "drop") %>% + dplyr::mutate( + metric = "AUC", + fold = "CV" + ) %>% + dplyr::select("metric", "fold", "value", "penalty") + hyperParamSearch <- dplyr::bind_rows( + cvMeans, + hyperParamSearch + ) %>% + dplyr::arrange( + dplyr::desc(.data$penalty), + match(.data$fold, c("CV", paste0("Fold", seq_len(max(labels$index))))) + ) + bestRow <- hyperParamSearch %>% + dplyr::filter(.data$fold == "CV") %>% + dplyr::arrange(dplyr::desc(.data$value), dplyr::desc(.data$penalty)) %>% + dplyr::slice(1) + bestPenalty <- bestRow$penalty + ParallelLogger::logInfo(paste0("Best BAR penalty: ", signif(bestPenalty, 4))) + + modelSettings$param$priorParams$penalty <- bestPenalty + prior <- do.call( + eval(parse(text = modelSettings$settings$priorfunction)), + modelSettings$param$priorParams + ) + + modelFit <- tryCatch( + { + ParallelLogger::logInfo("Refitting BAR model with best penalty") + Cyclops::fitCyclopsModel( + cyclopsData = cyclopsData, + prior = prior, + control = control, + fixedCoefficients = fixedCoefficients, + startingCoefficients = startingCoefficients + ) + }, + finally = ParallelLogger::logInfo("Done.") + ) + + list( + modelFit = modelFit, + modelSettings = modelSettings, + hyperParamSearch = hyperParamSearch + ) +} + +createBarPenaltyGrid <- function(labels, penaltyRatio, penaltyGridSize) { + startingPenalty <- log(nrow(labels)) / 2 + seq( + from = startingPenalty, + to = penaltyRatio * startingPenalty, + length.out = penaltyGridSize + ) +} + getCV <- function( diff --git a/R/CyclopsSettings.R b/R/CyclopsSettings.R index 7518ac724..60750b0ae 100644 --- a/R/CyclopsSettings.R +++ b/R/CyclopsSettings.R @@ -371,3 +371,157 @@ setIterativeHardThresholding <- function( return(result) } + + +#' Create setting for Broken Adaptive Ridge logistic regression +#' +#' @description +#' Creates model settings for Broken Adaptive Ridge logistic regression using +#' Cyclops and the BrokenAdaptiveRidge prior. `initialRidgeVariance = "auto"` +#' first fits a ridge model with Cyclops cross-validation and uses the selected +#' ridge variance to initialize BAR. `penalty = "auto"` cross-validates over a +#' BAR penalty grid and refits using the penalty with the highest mean +#' out-of-fold AUC. +#' +#' @param initialRidgeVariance Numeric prior starting variance, or `"auto"` to +#' estimate this using ridge cross-validation. +#' @param seed An option to add a seed when training the model. +#' @param includeCovariateIds A set of covariateIds to limit the analysis to. +#' @param noShrinkage A set of covariates which are forced into the model. The +#' default is the intercept. +#' @param penalty Numeric BAR penalty, `"logN"` to use `log(n) / 2`, or `"auto"` +#' to cross-validate over a penalty grid. +#' @param penaltyRatio Minimum penalty in the automatic grid as a ratio of the +#' `log(n) / 2` starting penalty. +#' @param penaltyGridSize Number of penalties to evaluate when `penalty = "auto"`. +#' @param threads An option to set number of threads when training model. +#' @param forceIntercept Logical: Force intercept coefficient into prior. +#' @param upperLimit Numeric: Upper prior variance limit for grid-search. +#' @param lowerLimit Numeric: Lower prior variance limit for grid-search. +#' @param tolerance Numeric: maximum relative change in convergence criterion +#' from successive iterations to achieve convergence. +#' @param maxIterations Integer: maximum iterations of Cyclops to attempt before +#' returning a failed-to-converge error. +#' @param threshold Numeric BAR threshold. +#' +#' @return `modelSettings` object +#' +#' @examplesIf rlang::is_installed("BrokenAdaptiveRidge") +#' modelBar <- setBrokenAdaptiveRidge(seed = 42) +#' @export +setBrokenAdaptiveRidge <- function( + initialRidgeVariance = "auto", + seed = NULL, + includeCovariateIds = c(), + noShrinkage = c("(Intercept)"), + penalty = "auto", + penaltyRatio = 0.1, + penaltyGridSize = 10, + threads = -1, + forceIntercept = FALSE, + upperLimit = 20, + lowerLimit = 0.01, + tolerance = 2e-06, + maxIterations = 3000, + threshold = 1e-06) { + rlang::check_installed("BrokenAdaptiveRidge") + + checkIsClass(seed, c("numeric", "NULL", "integer")) + if (is.null(seed[1])) { + seed <- as.integer(sample(100000000, 1)) + } + checkIsClass(threads, c("numeric", "integer")) + checkSingleFiniteNumeric(threads) + checkIsClass(initialRidgeVariance, c("numeric", "integer", "character")) + if (length(initialRidgeVariance) != 1) { + stop("initialRidgeVariance must be a single value") + } + if (inherits(initialRidgeVariance, "character")) { + checkInStringVector(initialRidgeVariance, "auto") + } else { + checkSingleFiniteNumeric(initialRidgeVariance) + checkHigher(initialRidgeVariance, 0) + } + checkIsClass(penalty, c("numeric", "integer", "character")) + if (length(penalty) != 1) { + stop("penalty must be a single value") + } + if (inherits(penalty, "character")) { + checkInStringVector(penalty, c("auto", "logN")) + } else { + checkSingleFiniteNumeric(penalty) + checkHigher(penalty, 0) + } + checkIsClass(penaltyRatio, c("numeric", "integer")) + checkSingleFiniteNumeric(penaltyRatio) + checkHigherEqual(penaltyRatio, 0) + if (length(penaltyRatio) != 1 || penaltyRatio <= 0 || penaltyRatio >= 1) { + stop("penaltyRatio must be a single value greater than 0 and less than 1") + } + checkIsClass(penaltyGridSize, c("numeric", "integer")) + checkIsWholeNumber(penaltyGridSize) + checkHigher(penaltyGridSize, 0) + checkIsClass(lowerLimit, c("numeric", "integer")) + checkIsClass(upperLimit, c("numeric", "integer")) + checkSingleFiniteNumeric(lowerLimit) + checkSingleFiniteNumeric(upperLimit) + checkHigherEqual(upperLimit, lowerLimit) + if (!is.logical(forceIntercept)) { + stop("forceIntercept must be of type: logical") + } + checkIsClass(tolerance, c("numeric", "integer")) + checkSingleFiniteNumeric(tolerance) + checkHigher(tolerance, 0) + checkIsClass(maxIterations, c("numeric", "integer")) + checkIsWholeNumber(maxIterations) + checkHigher(maxIterations, 0) + checkIsClass(threshold, c("numeric", "integer")) + checkSingleFiniteNumeric(threshold) + checkHigher(threshold, 0) + + param <- list( + priorParams = list( + forceIntercept = forceIntercept, + initialRidgeVariance = initialRidgeVariance, + exclude = noShrinkage, + tolerance = tolerance[1], + maxIterations = maxIterations[1], + penalty = penalty, + threshold = threshold + ), + includeCovariateIds = includeCovariateIds, + upperLimit = upperLimit, + lowerLimit = lowerLimit + ) + + settings <- list( + modelName = "brokenAdaptiveRidge", + modelType = "binary", + cyclopsModelType = "logistic", + priorfunction = "BrokenAdaptiveRidge::createBarPrior", + selectorType = "byPid", + crossValidationInPrior = FALSE, + addIntercept = TRUE, + useControl = !identical(penalty, "auto"), + manualPenaltyCv = identical(penalty, "auto"), + manualPenaltyCvWarmStart = TRUE, + penaltyRatio = penaltyRatio[1], + penaltyGridSize = penaltyGridSize[1], + seed = seed[1], + threads = threads[1], + tolerance = tolerance[1], + cvRepetitions = 1, + maxIterations = maxIterations[1], + saveType = "RtoJson", + predict = "predictCyclops" + ) + + result <- list( + fitFunction = "fitCyclopsModel", + param = param, + settings = settings + ) + class(result) <- "modelSettings" + + return(result) +} diff --git a/R/ParamChecks.R b/R/ParamChecks.R index 5b20eb23c..cc9447c26 100644 --- a/R/ParamChecks.R +++ b/R/ParamChecks.R @@ -81,6 +81,15 @@ checkIsClass <- function(parameter, classes) { return(TRUE) } +checkSingleFiniteNumeric <- function(parameter) { + name <- deparse(substitute(parameter)) + if (length(parameter) != 1 || !is.numeric(parameter) || is.na(parameter) || !is.finite(parameter)) { + ParallelLogger::logError(paste0(name, " must be a single finite numeric value")) + stop(paste0(name, " must be a single finite numeric value")) + } + return(TRUE) +} + checkIsWholeNumber <- function(parameter) { name <- deparse(substitute(parameter)) if (length(parameter) != 1 || !is.numeric(parameter) || is.na(parameter) || diff --git a/_pkgdown.yml b/_pkgdown.yml index 081ff9544..301585828 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -142,6 +142,7 @@ reference: - setGradientBoostingMachine - setLassoLogisticRegression - setRidgeRegression + - setBrokenAdaptiveRidge - setMLP - setNaiveBayes - setRandomForest diff --git a/man/setBrokenAdaptiveRidge.Rd b/man/setBrokenAdaptiveRidge.Rd new file mode 100644 index 000000000..af855953c --- /dev/null +++ b/man/setBrokenAdaptiveRidge.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CyclopsSettings.R +\name{setBrokenAdaptiveRidge} +\alias{setBrokenAdaptiveRidge} +\title{Create setting for Broken Adaptive Ridge logistic regression} +\usage{ +setBrokenAdaptiveRidge( + initialRidgeVariance = "auto", + seed = NULL, + includeCovariateIds = c(), + noShrinkage = c("(Intercept)"), + penalty = "auto", + penaltyRatio = 0.1, + penaltyGridSize = 10, + threads = -1, + forceIntercept = FALSE, + upperLimit = 20, + lowerLimit = 0.01, + tolerance = 2e-06, + maxIterations = 3000, + threshold = 1e-06 +) +} +\arguments{ +\item{initialRidgeVariance}{Numeric prior starting variance, or \code{"auto"} to +estimate this using ridge cross-validation.} + +\item{seed}{An option to add a seed when training the model.} + +\item{includeCovariateIds}{A set of covariateIds to limit the analysis to.} + +\item{noShrinkage}{A set of covariates which are forced into the model. The +default is the intercept.} + +\item{penalty}{Numeric BAR penalty, \code{"logN"} to use \code{log(n) / 2}, or \code{"auto"} +to cross-validate over a penalty grid.} + +\item{penaltyRatio}{Minimum penalty in the automatic grid as a ratio of the +\code{log(n) / 2} starting penalty.} + +\item{penaltyGridSize}{Number of penalties to evaluate when \code{penalty = "auto"}.} + +\item{threads}{An option to set number of threads when training model.} + +\item{forceIntercept}{Logical: Force intercept coefficient into prior.} + +\item{upperLimit}{Numeric: Upper prior variance limit for grid-search.} + +\item{lowerLimit}{Numeric: Lower prior variance limit for grid-search.} + +\item{tolerance}{Numeric: maximum relative change in convergence criterion +from successive iterations to achieve convergence.} + +\item{maxIterations}{Integer: maximum iterations of Cyclops to attempt before +returning a failed-to-converge error.} + +\item{threshold}{Numeric BAR threshold.} +} +\value{ +\code{modelSettings} object +} +\description{ +Creates model settings for Broken Adaptive Ridge logistic regression using +Cyclops and the BrokenAdaptiveRidge prior. \code{initialRidgeVariance = "auto"} +first fits a ridge model with Cyclops cross-validation and uses the selected +ridge variance to initialize BAR. \code{penalty = "auto"} cross-validates over a +BAR penalty grid and refits using the penalty with the highest mean +out-of-fold AUC. +} +\examples{ +\dontshow{if (rlang::is_installed("BrokenAdaptiveRidge")) withAutoprint(\{ # examplesIf} +modelBar <- setBrokenAdaptiveRidge(seed = 42) +\dontshow{\}) # examplesIf} +} diff --git a/tests/testthat/test-cyclopsModels.R b/tests/testthat/test-cyclopsModels.R index ee955b40d..6b6158e6d 100644 --- a/tests/testthat/test-cyclopsModels.R +++ b/tests/testthat/test-cyclopsModels.R @@ -297,6 +297,122 @@ test_that("test IHT incorrect inputs", { expect_error(setIterativeHardThresholding(seed = "F")) }) +test_that("set BAR inputs", { + skip_if_not_installed("BrokenAdaptiveRidge") + skip_on_cran() + + modelSet <- setBrokenAdaptiveRidge(seed = 42) + expect_s3_class(modelSet, "modelSettings") + expect_equal(modelSet$fitFunction, "fitCyclopsModel") + expect_equal(modelSet$settings$modelName, "brokenAdaptiveRidge") + expect_equal(modelSet$settings$cyclopsModelType, "logistic") + expect_equal(modelSet$settings$modelType, "binary") + expect_equal(modelSet$settings$priorfunction, "BrokenAdaptiveRidge::createBarPrior") + expect_equal(modelSet$settings$manualPenaltyCv, TRUE) + expect_equal(modelSet$settings$manualPenaltyCvWarmStart, TRUE) + expect_equal(modelSet$settings$useControl, FALSE) + expect_equal(modelSet$param$priorParams$initialRidgeVariance, "auto") + expect_equal(modelSet$param$priorParams$penalty, "auto") + + modelSet <- setBrokenAdaptiveRidge( + initialRidgeVariance = 0.5, + penalty = "logN", + penaltyRatio = 0.2, + penaltyGridSize = 5, + seed = 42 + ) + expect_equal(modelSet$settings$priorfunction, "BrokenAdaptiveRidge::createBarPrior") + expect_equal(modelSet$settings$manualPenaltyCv, FALSE) + expect_equal(modelSet$settings$useControl, TRUE) + expect_equal(modelSet$settings$penaltyRatio, 0.2) + expect_equal(modelSet$settings$penaltyGridSize, 5) + expect_equal(modelSet$param$priorParams$initialRidgeVariance, 0.5) + expect_equal(modelSet$param$priorParams$penalty, "logN") + expect_equal(modelSet$param$priorParams$maxIterations, 3000) +}) + +test_that("test BAR incorrect inputs", { + skip_if_not_installed("BrokenAdaptiveRidge") + skip_on_cran() + + expect_error(setBrokenAdaptiveRidge(initialRidgeVariance = "bad")) + expect_error(setBrokenAdaptiveRidge(initialRidgeVariance = c(0.1, 0.2))) + expect_error(setBrokenAdaptiveRidge(initialRidgeVariance = NA_real_)) + expect_error(setBrokenAdaptiveRidge(initialRidgeVariance = Inf)) + expect_error(setBrokenAdaptiveRidge(initialRidgeVariance = 0)) + expect_error(setBrokenAdaptiveRidge(penalty = "bad")) + expect_error(setBrokenAdaptiveRidge(penalty = NA_character_)) + expect_error(setBrokenAdaptiveRidge(penalty = c(0.1, 0.2))) + expect_error(setBrokenAdaptiveRidge(penalty = NA_real_)) + expect_error(setBrokenAdaptiveRidge(penalty = Inf)) + expect_error(setBrokenAdaptiveRidge(penalty = 0)) + expect_error(setBrokenAdaptiveRidge(penaltyRatio = NA_real_)) + expect_error(setBrokenAdaptiveRidge(penaltyRatio = Inf)) + expect_error(setBrokenAdaptiveRidge(penaltyRatio = 1)) + expect_error(setBrokenAdaptiveRidge(penaltyGridSize = NA_real_)) + expect_error(setBrokenAdaptiveRidge(penaltyGridSize = Inf)) + expect_error(setBrokenAdaptiveRidge(penaltyGridSize = 1.5)) + expect_error(setBrokenAdaptiveRidge(lowerLimit = NA_real_)) + expect_error(setBrokenAdaptiveRidge(upperLimit = Inf)) + expect_error(setBrokenAdaptiveRidge(tolerance = NA_real_)) + expect_error(setBrokenAdaptiveRidge(tolerance = Inf)) + expect_error(setBrokenAdaptiveRidge(tolerance = 0)) + expect_error(setBrokenAdaptiveRidge(maxIterations = 1.5)) + expect_error(setBrokenAdaptiveRidge(maxIterations = 0)) + expect_error(setBrokenAdaptiveRidge(threshold = NA_real_)) + expect_error(setBrokenAdaptiveRidge(threshold = Inf)) + expect_error(setBrokenAdaptiveRidge(threshold = 0)) +}) + +test_that("BAR penalty grid starts at log(n) / 2", { + labels <- data.frame(rowId = seq_len(100)) + + grid <- createBarPenaltyGrid(labels, penaltyRatio = 0.1, penaltyGridSize = 3) + + expect_equal(length(grid), 3) + expect_equal(grid[1], log(100) / 2) + expect_equal(grid[3], 0.1 * log(100) / 2) +}) + +test_that("BAR prior parameters resolve auto values", { + skip_if_not_installed("BrokenAdaptiveRidge") + skip_on_cran() + + outcomes <- data.frame(rowId = seq_len(20), y = rep(c(0, 1), 10)) + covariates <- data.frame( + rowId = seq_len(20), + covariateId = rep(100, 20), + covariateValue = seq(-1, 1, length.out = 20) + ) + cyclopsData <- Cyclops::convertToCyclopsData( + outcomes = outcomes, + covariates = covariates, + addIntercept = TRUE, + modelType = "lr", + checkRowIds = FALSE, + quiet = TRUE + ) + modelSettings <- setBrokenAdaptiveRidge( + initialRidgeVariance = "auto", + penalty = "logN", + seed = 42, + threads = 1, + maxIterations = 1000 + ) + + param <- suppressWarnings(resolveCyclopsPriorParams( + param = modelSettings$param, + cyclopsData = cyclopsData, + labels = outcomes, + folds = data.frame(rowId = seq_len(20), index = rep(1, 20)), + settings = modelSettings$settings + )) + + expect_equal(param$priorParams$penalty, log(nrow(outcomes)) / 2) + expect_type(param$priorParams$initialRidgeVariance, "double") + expect_true(is.finite(param$priorParams$initialRidgeVariance)) +}) + # ================ FUNCTION TESTING @@ -445,6 +561,63 @@ test_that("test IHT returns CV predictions", { expect_true("CV" %in% fitModel$trainDetails$hyperParamSearch$fold) }) +test_that("test BAR automatic penalty search runs", { + skip_if_offline() + skip_if_not_installed("BrokenAdaptiveRidge") + skip_on_cran() + + fitModel <- suppressWarnings( + fitPlp( + trainData = tinyTrainData, + modelSettings = setBrokenAdaptiveRidge( + initialRidgeVariance = 0.5, + penalty = "auto", + penaltyGridSize = 2, + seed = 42, + threads = 1 + ), + analysisId = "barTest", + analysisPath = tempdir() + ) + ) + + expect_equal(length(unique(fitModel$prediction$evaluationType)), 2) + expect_true("CV" %in% fitModel$prediction$evaluationType) + expect_equal(nrow(fitModel$prediction), nrow(tinyTrainData$labels) * 2) + expect_true("penalty" %in% colnames(fitModel$trainDetails$hyperParamSearch)) + expect_true("CV" %in% fitModel$trainDetails$hyperParamSearch$fold) + expect_type(fitModel$modelDesign$modelSettings$param$priorParams$penalty, "double") + expect_false(identical(fitModel$modelDesign$modelSettings$param$priorParams$penalty, "auto")) +}) + +test_that("test BAR fixed logN penalty runs", { + skip_if_offline() + skip_if_not_installed("BrokenAdaptiveRidge") + skip_on_cran() + + fitModel <- suppressWarnings( + fitPlp( + trainData = tinyTrainData, + modelSettings = setBrokenAdaptiveRidge( + initialRidgeVariance = 0.5, + penalty = "logN", + seed = 42, + threads = 1 + ), + analysisId = "barFixedTest", + analysisPath = tempdir() + ) + ) + + expect_equal(length(unique(fitModel$prediction$evaluationType)), 2) + expect_true("CV" %in% fitModel$prediction$evaluationType) + expect_equal(nrow(fitModel$prediction), nrow(tinyTrainData$labels) * 2) + expect_equal( + fitModel$modelDesign$modelSettings$param$priorParams$penalty, + log(nrow(tinyTrainData$labels)) / 2 + ) +}) + test_that("test logistic regression runs", { skip_if_offline() modelSettings <- setLassoLogisticRegression() diff --git a/tests/testthat/test-paramchecks.R b/tests/testthat/test-paramchecks.R index 418912183..fe408abe0 100644 --- a/tests/testthat/test-paramchecks.R +++ b/tests/testthat/test-paramchecks.R @@ -83,6 +83,16 @@ test_that("checkIsWholeNumber", { expect_equal(checkIsWholeNumber(1L), TRUE) }) +test_that("checkSingleFiniteNumeric", { + expect_error(checkSingleFiniteNumeric(c(1, 2))) + expect_error(checkSingleFiniteNumeric("1")) + expect_error(checkSingleFiniteNumeric(NA_real_)) + expect_error(checkSingleFiniteNumeric(Inf)) + + expect_equal(checkSingleFiniteNumeric(1), TRUE) + expect_equal(checkSingleFiniteNumeric(1L), TRUE) +}) + test_that("checkInStringVector", { expect_error(checkInStringVector("dsdsds", c("dsds", "double"))) expect_error(checkInStringVector(c("dsdsds", "double"), c("dsdsds", "double")))