From 0e65badb738a733b4b4dd13a0da5a87f1394c672 Mon Sep 17 00:00:00 2001 From: Wenjie Wang Date: Sat, 6 Jan 2024 21:47:08 -0500 Subject: [PATCH] Return original controls --- R/abclass.R | 8 ++++---- R/abclass_engine.R | 9 ++++++++- inst/tinytest/test-abclass.R | 9 ++++++++- inst/tinytest/test-et.abclass.R | 10 +++++----- man/abclass.Rd | 8 ++++---- 5 files changed, 29 insertions(+), 15 deletions(-) diff --git a/R/abclass.R b/R/abclass.R index aa70c03..1ff9e58 100644 --- a/R/abclass.R +++ b/R/abclass.R @@ -148,8 +148,8 @@ abclass.control <- function(lambda = NULL, alpha = 1.0, nlambda = 50L, lambda_min_ratio = NULL, - grouped = TRUE, penalty_factor = NULL, + grouped = TRUE, group_penalty = c("lasso", "scad", "mcp"), offset = NULL, kappa_ratio = 0.9, @@ -175,13 +175,13 @@ abclass.control <- function(lambda = NULL, } structure(list( alpha = alpha, - lambda = null2num0(lambda), + lambda = lambda, nlambda = as.integer(nlambda), lambda_min_ratio = lambda_min_ratio, + penalty_factor = penalty_factor, grouped = grouped, group_penalty = group_penalty, - penalty_factor = null2num0(penalty_factor), - offset = null2mat0(offset), + offset = offset, standardize = standardize, maxit = as.integer(maxit), epsilon = epsilon, diff --git a/R/abclass_engine.R b/R/abclass_engine.R index e0ae4d3..7fd1a61 100644 --- a/R/abclass_engine.R +++ b/R/abclass_engine.R @@ -48,10 +48,10 @@ c("lasso", "scad", "mcp")) } ## process alignment + all_alignment <- c("fraction", "lambda") if (is.numeric(alignment)) { alignment <- as.integer(alignment[1L]) } else if (is.character(alignment)) { - all_alignment <- c("fraction", "lambda") alignment <- match.arg(alignment, choices = all_alignment) alignment <- match(alignment, all_alignment) - 1L } else { @@ -77,6 +77,9 @@ loss_id = loss_id, penalty_id = penalty_id) ) + ctrl$lambda <- null2num0(ctrl$lambda) + ctrl$penalty_factor = null2num0(ctrl$penalty_factor) + ctrl$offset = null2mat0(ctrl$offset) ## arguments call_list <- c(list(x = x, y = cat_y$y, control = ctrl)) fun_to_call <- if (is_x_sparse) { @@ -93,6 +96,10 @@ res$control <- control if (call_list$control$nfolds == 0L) { res$cross_validation <- NULL + } else { + res$cross_validation$alignment <- all_alignment[ + res$cross_validation$alignment + ] } if (call_list$control$nstages == 0L) { res$et <- NULL diff --git a/inst/tinytest/test-abclass.R b/inst/tinytest/test-abclass.R index 2c98b71..a7572b0 100644 --- a/inst/tinytest/test-abclass.R +++ b/inst/tinytest/test-abclass.R @@ -16,7 +16,14 @@ train_y <- y[train_idx] test_y <- y[- train_idx] ## logistic deviance loss -model1 <- abclass(train_x, train_y, nlambda = 5, grouped = FALSE) +model1 <- abclass( + x = train_x, + y = train_y, + nlambda = 5, + grouped = FALSE, + control = abclass.control(penalty_factor = runif(ncol(train_x))) +) + pred1 <- predict(model1, test_x, s = 5) expect_true(mean(test_y == pred1) > 0.5) expect_equivalent(dim(coef(model1, s = 5)), c(p + 1, k - 1)) diff --git a/inst/tinytest/test-et.abclass.R b/inst/tinytest/test-et.abclass.R index e04d5c8..8804642 100644 --- a/inst/tinytest/test-et.abclass.R +++ b/inst/tinytest/test-et.abclass.R @@ -21,13 +21,13 @@ test_y <- y[- train_idx] ## without refit model1 <- et.abclass(train_x, train_y, nstages = 2, - lambda_min_ratio = 1e-6, grouped = FALSE, + lambda_min_ratio = 1e-4, grouped = FALSE, refit = FALSE) expect_equivalent(dim(coef(model1)), c(p + 1, k - 1)) ## with refit being TRUE model1 <- et.abclass(train_x, train_y, nstages = 2, - lambda_min_ratio = 1e-6, grouped = TRUE, + lambda_min_ratio = 1e-4, grouped = TRUE, refit = TRUE) expect_equivalent(dim(coef(model1)), c(p + 1, k - 1)) pred1 <- predict(model1, test_x) @@ -36,7 +36,7 @@ expect_true(mean(test_y == pred1) > 0.5) ## with reift as a list ## with cv model1 <- et.abclass(train_x, train_y, nstages = 2, - lambda_min_ratio = 1e-6, grouped = TRUE, + lambda_min_ratio = 1e-4, grouped = TRUE, refit = list(alpha = 0, nlambda = 10, nfolds = 3)) expect_equivalent(dim(coef(model1)), c(p + 1, k - 1)) pred1 <- predict(model1, test_x) @@ -44,7 +44,7 @@ expect_true(mean(test_y == pred1) > 0.5) ## without cv model1 <- et.abclass(train_x, train_y, nstages = 2, - lambda_min_ratio = 1e-6, grouped = TRUE, + lambda_min_ratio = 1e-4, grouped = TRUE, refit = list(alpha = 0, nlambda = 10)) expect_equivalent(dim(coef(model1, selection = 10)), c(p + 1, k - 1)) pred1 <- predict(model1, test_x, s = 10) @@ -55,7 +55,7 @@ expect_error( et.abclass(train_x, train_y, penalty_factor = runif(ncol(train_x) + 1)) ) -## with refit and penalty factors +## with penalty factors gw <- runif(ncol(train_x)) model1 <- et.abclass(train_x, train_y, nstages = 2, lambda_min_ratio = 1e-4, diff --git a/man/abclass.Rd b/man/abclass.Rd index 3ff9969..0174de2 100644 --- a/man/abclass.Rd +++ b/man/abclass.Rd @@ -20,8 +20,8 @@ abclass.control( alpha = 1, nlambda = 50L, lambda_min_ratio = NULL, - grouped = TRUE, penalty_factor = NULL, + grouped = TRUE, group_penalty = c("lasso", "scad", "mcp"), offset = NULL, kappa_ratio = 0.9, @@ -85,13 +85,13 @@ smallest lambda parameter to the largest lambda parameter. The default value is set to \code{1e-4} if the sample size is larger than the number of predictors, and \code{1e-2} otherwise.} -\item{grouped}{A logicial value. Experimental flag to apply group -penalties.} - \item{penalty_factor}{A numerical vector with nonnegative values specifying the adaptive penalty factors for individual predictors (excluding intercept).} +\item{grouped}{A logicial value. Experimental flag to apply group +penalties.} + \item{group_penalty}{A character vector specifying the name of the group penalty.}