R Under development (unstable) (2026-10-21 r90733 ucrt) -- "Unsuffered Consequences" Copyright (C) 2026 The R Foundation for Statistical Computing Platform: x86_64-w64-mingw32/x64 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > library(ARISE) > > run_regression_tests <- function() { + helper <- function(name) { + get(name, envir = environment(ARISEFS), inherits = FALSE) + } + expect_error <- function(expr, pattern = NULL) { + result <- tryCatch({ + force(expr) + NULL + }, error = identity) + stopifnot(inherits(result, "error")) + if (!is.null(pattern)) { + stopifnot(grepl(pattern, conditionMessage(result), fixed = TRUE)) + } + invisible(NULL) + } + + had_seed <- exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE) + if (had_seed) { + original_seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE) + } + on.exit({ + if (had_seed) { + assign(".Random.seed", original_seed, envir = .GlobalEnv) + } else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) { + rm(".Random.seed", envir = .GlobalEnv) + } + }, add = TRUE) + + ## A large location shift must not turn a variable predictor into a constant. + variance <- helper(".arise_fast_variance") + shifted <- cbind( + shifted = 1e12 + seq_len(12L), + original = seq_len(12L), + constant = rep(1e12, 12L) + ) + stopifnot(isTRUE(all.equal( + unname(variance(shifted)), c(13, 13, 0), tolerance = 1e-12 + ))) + + ## Discrete predictors retain their information, including binary features. + mutual_information <- helper(".arise_mutual_information") + labels <- factor(rep(c("a", "b"), each = 4L)) + scores <- mutual_information(cbind( + perfect = rep(0:1, each = 4L), + independent = rep(0:1, 4L), + constant = rep(0, 8L) + ), labels) + stopifnot( + abs(scores["perfect"] - log(2)) < 1e-12, + abs(scores["independent"]) < 1e-12, + abs(scores["constant"]) < 1e-12 + ) + + ## Invalid inputs fail before expensive tuning and without coercion warnings. + small_x <- cbind( + signal = c(-3, -2, -1, 1, 2, 3), + noise = c(1, 3, 2, 3, 1, 2) + ) + small_y <- factor(rep(c("a", "b"), each = 3L)) + for (bad_top_k in list(0, -1, 1.5, NA_real_, Inf, c(1, 2), TRUE, + 1 + 1i, matrix(1))) { + expect_error(ARISEFS(small_x, small_y, bad_top_k), "'topK'") + } + expect_error(ARISEFS(small_x + 1i, small_y), "real numeric") + expect_error(ARISEFS(data.frame(a = seq_len(6L), b = letters[1:6]), small_y)) + matrix_column <- data.frame(a = seq_len(6L)) + matrix_column$b <- I(matrix(seq_len(12L), nrow = 6L)) + expect_error(ARISEFS(matrix_column, small_y), "Invalid columns") + list_column <- data.frame(a = seq_len(6L)) + list_column$b <- I(as.list(seq_len(6L))) + expect_error(ARISEFS(list_column, small_y), "Invalid columns") + expect_error(ARISEFS(array(seq_len(12L), c(3L, 2L, 2L)), small_y)) + expect_error(ARISEFS(small_x, as.complex(seq_len(6L))), "real class labels") + expect_error(ARISEFS(small_x, matrix(small_y, ncol = 1L))) + expect_error(ARISEFS(small_x, small_y[-1L]), "length(y)") + expect_error(ARISEFS(small_x, c("a", "a", "a", "b", "b", NA)), + "missing or non-finite") + expect_error(ARISEFS(small_x, rep("a", 6L)), "At least two") + expect_error(ARISEFS(small_x, c("a", "a", "a", "a", "b", "b")), + "at least 3") + duplicate_x <- small_x + colnames(duplicate_x) <- c("a", "a") + expect_error(ARISEFS(duplicate_x, small_y), "unique") + + ## Imputation and feature removal use only training data. + control <- helper(".arise_control")(tune = FALSE, stability_subsamples = 2L) + preprocess <- helper(".arise_fit_preprocessor") + apply_preprocessor <- helper(".arise_apply_preprocessor") + training <- cbind( + signal = c(1, 2, 3, 4, 5, NA_real_), + constant = rep(1, 6L), + unavailable = rep(NA_real_, 6L) + ) + prepared <- preprocess(training, control) + stopifnot( + identical(colnames(prepared$x), "signal"), + prepared$x[6L, "signal"] == 3 + ) + validation <- rbind(c(100, 1, NA_real_), c(NA_real_, 1, NA_real_)) + colnames(validation) <- colnames(training) + transformed <- apply_preprocessor(prepared$preprocessor, validation) + stopifnot(transformed[1L, 1L] == 100, transformed[2L, 1L] == 3) + expect_error(preprocess(matrix(1, nrow = 6L, ncol = 2L), control), + "No variable feature") + expect_error(preprocess(matrix(NA_real_, nrow = 6L, ncol = 2L), control), + "entirely non-finite") + stopifnot(ncol(preprocess(shifted, control)$x) == 2L) + + ## Repeated feature selection is deterministic and preserves the caller's RNG. + fit <- helper(".arise_fit") + set.seed(4821) + rng_before <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE) + first <- fit(small_x, small_y, 2L, control, seed = 13L) + second <- fit(small_x, small_y, 2L, control, seed = 13L) + stopifnot( + identical(first, second), + length(first) == 2L, + !anyDuplicated(first), + identical(rng_before, get(".Random.seed", envir = .GlobalEnv)) + ) + rm(".Random.seed", envir = .GlobalEnv) + invisible(helper(".arise_with_seed")(19L, function() stats::runif(3L))) + stopifnot(!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) + + ## Native SVM pair order must work for labels containing ambiguous slashes. + svm_x <- cbind( + first = rep(c(3, 1, -1, -3), each = 4L) + rep(c(-.1, 0, .1, .2), 4L), + second = rep(c(-3, 1, 3, -1), each = 4L) + rep(c(.2, -.1, 0, .1), 4L) + ) + simple_labels <- paste0("class", seq_len(4L)) + slash_labels <- c("a", "b/c", "a/b", "c") + class_index <- rep(4:1, each = 4L) + simple_y <- factor(simple_labels[class_index], levels = simple_labels) + slash_y <- factor(slash_labels[class_index], levels = slash_labels) + predict_fixed <- helper(".arise_fit_predict") + simple <- predict_fixed("svm", svm_x, simple_y, svm_x, control, 7L) + slash <- predict_fixed("svm", svm_x, slash_y, svm_x, control, 7L) + stopifnot( + isTRUE(all.equal(unname(simple$scores), unname(slash$scores), + tolerance = 1e-10)), + identical(as.integer(simple$class), as.integer(slash$class)), + all(is.finite(slash$scores)), + max(abs(rowSums(slash$scores) - 1)) < 1e-12 + ) + + ## One complete public call exercises both tuning stages and all learners. + ## A request exceeding the available predictors returns each available index. + set.seed(8273) + rng_before <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE) + selected <- ARISEFS(small_x, small_y, topK = 10L) + stopifnot( + is.integer(selected), + is.null(names(selected)), + length(selected) == ncol(small_x), + identical(sort(selected), seq_len(ncol(small_x))), + identical(rng_before, get(".Random.seed", envir = .GlobalEnv)) + ) + + ## The bundled dataset must load from the installed package. + data_environment <- new.env(parent = baseenv()) + utils::data("NovartisMultiTissue", package = "ARISE", envir = data_environment) + benchmark <- get("NovartisMultiTissue", envir = data_environment) + stopifnot( + is.list(benchmark), + is.matrix(benchmark$X), + is.numeric(benchmark$X), + identical(dim(benchmark$X), c(102L, 5565L)), + nrow(benchmark$X) == length(benchmark$Y), + all(is.finite(benchmark$X)), + identical(levels(benchmark$Y), as.character(seq_len(4L))), + identical(as.integer(table(benchmark$Y)), c(25L, 26L, 28L, 23L)), + identical(colnames(benchmark$X), paste0("Feature", seq_len(5565L))), + identical(rownames(benchmark$X), paste0("Sample", seq_len(102L))) + ) + invisible(TRUE) + } > > run_regression_tests() > > proc.time() user system elapsed 2.54 0.10 2.64