From dd8f15017445dad9dc25a6d5e3206dc7f03c6a94 Mon Sep 17 00:00:00 2001
From: egillax <egillax@gmail.com>
Date: Tue, 26 Mar 2024 15:22:58 +0100
Subject: [PATCH 1/3] feat: add broken adaptive ridge settings

---
 DESCRIPTION                         |   1 +
 NAMESPACE                           |   1 +
 R/CyclopsModels.R                   | 211 +++++++++++++++++++++++++++-
 R/CyclopsSettings.R                 | 148 +++++++++++++++++++
 _pkgdown.yml                        |   1 +
 man/setBrokenAdaptiveRidge.Rd       |  77 ++++++++++
 tests/testthat/test-cyclopsModels.R |  58 ++++++++
 7 files changed, 492 insertions(+), 5 deletions(-)
 create mode 100644 man/setBrokenAdaptiveRidge.Rd

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..3dc086106 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,172 @@ 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(
+      fold = max(folds$index),
+      threads = settings$threads,
+      seed = settings$seed,
+      noiseLevel = "silent"
+    )
+
+    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
+  )
+
+  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,
+        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,
+        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..eba785082 100644
--- a/R/CyclopsSettings.R
+++ b/R/CyclopsSettings.R
@@ -371,3 +371,151 @@ 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.
+#' @param prior Which BAR prior implementation to use: `"regular"` or `"fast"`.
+#'
+#' @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,
+    prior = "regular") {
+  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"))
+  checkIsClass(initialRidgeVariance, c("numeric", "integer", "character"))
+  if (length(initialRidgeVariance) != 1) {
+    stop("initialRidgeVariance must be a single value")
+  }
+  if (inherits(initialRidgeVariance, "character") && !identical(initialRidgeVariance, "auto")) {
+    stop('initialRidgeVariance must be numeric or "auto"')
+  }
+  checkIsClass(penalty, c("numeric", "integer", "character"))
+  if (length(penalty) != 1) {
+    stop("penalty must be a single value")
+  }
+  if (inherits(penalty, "character") && !penalty %in% c("auto", "logN")) {
+    stop('penalty must be numeric, "auto", or "logN"')
+  }
+  checkIsClass(penaltyRatio, c("numeric", "integer"))
+  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"))
+  if (length(penaltyGridSize) != 1 || penaltyGridSize < 1 || penaltyGridSize != floor(penaltyGridSize)) {
+    stop("penaltyGridSize must be a single positive whole number")
+  }
+  checkIsClass(lowerLimit, c("numeric", "integer"))
+  checkIsClass(upperLimit, c("numeric", "integer"))
+  checkHigherEqual(upperLimit, lowerLimit)
+  if (!is.logical(forceIntercept)) {
+    stop("forceIntercept must be of type: logical")
+  }
+
+  prior <- tolower(prior[1])
+  if (!prior %in% c("regular", "fast")) {
+    stop('prior must be "regular" or "fast"')
+  }
+  priorFunction <- if (identical(prior, "fast")) {
+    "BrokenAdaptiveRidge::createFastBarPrior"
+  } else {
+    "BrokenAdaptiveRidge::createBarPrior"
+  }
+
+  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 = priorFunction,
+    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/_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..bc4a086d0
--- /dev/null
+++ b/man/setBrokenAdaptiveRidge.Rd
@@ -0,0 +1,77 @@
+% 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,
+  prior = "regular"
+)
+}
+\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.}
+
+\item{prior}{Which BAR prior implementation to use: \code{"regular"} or \code{"fast"}.}
+}
+\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..2b5dd92e1 100644
--- a/tests/testthat/test-cyclopsModels.R
+++ b/tests/testthat/test-cyclopsModels.R
@@ -297,6 +297,64 @@ 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,
+    prior = "fast",
+    seed = 42
+  )
+  expect_equal(modelSet$settings$priorfunction, "BrokenAdaptiveRidge::createFastBarPrior")
+  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(penalty = "bad"))
+  expect_error(setBrokenAdaptiveRidge(penalty = c(0.1, 0.2)))
+  expect_error(setBrokenAdaptiveRidge(penaltyRatio = 1))
+  expect_error(setBrokenAdaptiveRidge(penaltyGridSize = 1.5))
+  expect_error(setBrokenAdaptiveRidge(prior = "bad"))
+})
+
+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)
+})
+
 
 
 # ================ FUNCTION TESTING

From 734fb9ae8f3db8ac8edf641cb5399910fcb6da5e Mon Sep 17 00:00:00 2001
From: egillax <egillax@gmail.com>
Date: Fri, 19 Jun 2026 16:38:00 +0200
Subject: [PATCH 2/3] fix: refine broken adaptive ridge settings

---
 R/CyclopsModels.R                   | 20 +++++++++--
 R/CyclopsSettings.R                 | 48 ++++++++++++++-----------
 R/ParamChecks.R                     |  9 +++++
 man/setBrokenAdaptiveRidge.Rd       |  5 +--
 tests/testthat/test-cyclopsModels.R | 54 +++++++++++++++++++++++++++--
 tests/testthat/test-paramchecks.R   | 10 ++++++
 6 files changed, 116 insertions(+), 30 deletions(-)

diff --git a/R/CyclopsModels.R b/R/CyclopsModels.R
index 3dc086106..c327d231f 100644
--- a/R/CyclopsModels.R
+++ b/R/CyclopsModels.R
@@ -603,10 +603,17 @@ resolveCyclopsPriorParams <- function(
       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,
-      seed = settings$seed,
-      noiseLevel = "silent"
+      maxIterations = settings$maxIterations,
+      seed = settings$seed
     )
 
     ridgeFit <- tryCatch(
@@ -641,6 +648,13 @@ doCyclopsCvPenalty <- function(
     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")
@@ -663,6 +677,7 @@ doCyclopsCvPenalty <- function(
       subsetFit <- suppressWarnings(Cyclops::fitCyclopsModel(
         cyclopsData,
         prior = cvPrior,
+        control = control,
         weights = weights,
         fixedCoefficients = fixedCoefficients,
         startingCoefficients = foldStartingCoefficients
@@ -730,6 +745,7 @@ doCyclopsCvPenalty <- function(
       Cyclops::fitCyclopsModel(
         cyclopsData = cyclopsData,
         prior = prior,
+        control = control,
         fixedCoefficients = fixedCoefficients,
         startingCoefficients = startingCoefficients
       )
diff --git a/R/CyclopsSettings.R b/R/CyclopsSettings.R
index eba785082..60750b0ae 100644
--- a/R/CyclopsSettings.R
+++ b/R/CyclopsSettings.R
@@ -403,7 +403,6 @@ setIterativeHardThresholding <- function(
 #' @param maxIterations Integer: maximum iterations of Cyclops to attempt before
 #'   returning a failed-to-converge error.
 #' @param threshold Numeric BAR threshold.
-#' @param prior Which BAR prior implementation to use: `"regular"` or `"fast"`.
 #'
 #' @return `modelSettings` object
 #'
@@ -424,8 +423,7 @@ setBrokenAdaptiveRidge <- function(
     lowerLimit = 0.01,
     tolerance = 2e-06,
     maxIterations = 3000,
-    threshold = 1e-06,
-    prior = "regular") {
+    threshold = 1e-06) {
   rlang::check_installed("BrokenAdaptiveRidge")
 
   checkIsClass(seed, c("numeric", "NULL", "integer"))
@@ -433,45 +431,53 @@ setBrokenAdaptiveRidge <- function(
     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") && !identical(initialRidgeVariance, "auto")) {
-    stop('initialRidgeVariance must be numeric or "auto"')
+  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") && !penalty %in% c("auto", "logN")) {
-    stop('penalty must be numeric, "auto", or "logN"')
+  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"))
-  if (length(penaltyGridSize) != 1 || penaltyGridSize < 1 || penaltyGridSize != floor(penaltyGridSize)) {
-    stop("penaltyGridSize must be a single positive whole number")
-  }
+  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")
   }
-
-  prior <- tolower(prior[1])
-  if (!prior %in% c("regular", "fast")) {
-    stop('prior must be "regular" or "fast"')
-  }
-  priorFunction <- if (identical(prior, "fast")) {
-    "BrokenAdaptiveRidge::createFastBarPrior"
-  } else {
-    "BrokenAdaptiveRidge::createBarPrior"
-  }
+  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(
@@ -492,7 +498,7 @@ setBrokenAdaptiveRidge <- function(
     modelName = "brokenAdaptiveRidge",
     modelType = "binary",
     cyclopsModelType = "logistic",
-    priorfunction = priorFunction,
+    priorfunction = "BrokenAdaptiveRidge::createBarPrior",
     selectorType = "byPid",
     crossValidationInPrior = FALSE,
     addIntercept = TRUE,
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/man/setBrokenAdaptiveRidge.Rd b/man/setBrokenAdaptiveRidge.Rd
index bc4a086d0..af855953c 100644
--- a/man/setBrokenAdaptiveRidge.Rd
+++ b/man/setBrokenAdaptiveRidge.Rd
@@ -18,8 +18,7 @@ setBrokenAdaptiveRidge(
   lowerLimit = 0.01,
   tolerance = 2e-06,
   maxIterations = 3000,
-  threshold = 1e-06,
-  prior = "regular"
+  threshold = 1e-06
 )
 }
 \arguments{
@@ -56,8 +55,6 @@ from successive iterations to achieve convergence.}
 returning a failed-to-converge error.}
 
 \item{threshold}{Numeric BAR threshold.}
-
-\item{prior}{Which BAR prior implementation to use: \code{"regular"} or \code{"fast"}.}
 }
 \value{
 \code{modelSettings} object
diff --git a/tests/testthat/test-cyclopsModels.R b/tests/testthat/test-cyclopsModels.R
index 2b5dd92e1..8e0bec6a2 100644
--- a/tests/testthat/test-cyclopsModels.R
+++ b/tests/testthat/test-cyclopsModels.R
@@ -319,10 +319,9 @@ test_that("set BAR inputs", {
     penalty = "logN",
     penaltyRatio = 0.2,
     penaltyGridSize = 5,
-    prior = "fast",
     seed = 42
   )
-  expect_equal(modelSet$settings$priorfunction, "BrokenAdaptiveRidge::createFastBarPrior")
+  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)
@@ -338,11 +337,31 @@ test_that("test BAR incorrect inputs", {
 
   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(prior = "bad"))
+  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", {
@@ -503,6 +522,35 @@ 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 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")))

From bf5d6e00b92e186a2551f795186a82d58d233767 Mon Sep 17 00:00:00 2001
From: egillax <egillax@gmail.com>
Date: Fri, 19 Jun 2026 17:24:29 +0200
Subject: [PATCH 3/3] test: cover broken adaptive ridge fit paths

---
 tests/testthat/test-cyclopsModels.R | 67 +++++++++++++++++++++++++++++
 1 file changed, 67 insertions(+)

diff --git a/tests/testthat/test-cyclopsModels.R b/tests/testthat/test-cyclopsModels.R
index 8e0bec6a2..6b6158e6d 100644
--- a/tests/testthat/test-cyclopsModels.R
+++ b/tests/testthat/test-cyclopsModels.R
@@ -374,6 +374,45 @@ test_that("BAR penalty grid starts at log(n) / 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
@@ -551,6 +590,34 @@ test_that("test BAR automatic penalty search runs", {
   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()