diff --git a/NEWS.md b/NEWS.md index 6a9bdad47..572e1f164 100644 --- a/NEWS.md +++ b/NEWS.md @@ -11,6 +11,8 @@ If you read this from a place other than 0) { + warning(paste(out_capt, collapse = "\n")) + } # Post-processing: rownames(fit$beta) <- colnames(x) sub <- nlist(alpha = fit$beta0, beta = fit$beta, w = fit$w, formula, x, y, @@ -169,10 +195,7 @@ fit_glm_callback <- function(formula, family, ...) { methods::formalArgs(stats::lm.wfit)) )] # Call the submodel fitter: - return(suppressMessages(suppressWarnings(do.call(stats::lm, c( - list(formula = formula), - dot_args - ))))) + return(do.call(stats::lm, c(list(formula = formula), dot_args))) } else { # Exclude arguments from `...` which cannot be passed to stats::glm(): dot_args <- list(...) @@ -182,10 +205,8 @@ fit_glm_callback <- function(formula, family, ...) { methods::formalArgs(stats::glm.control)) )] # Call the submodel fitter: - return(suppressMessages(suppressWarnings(do.call(stats::glm, c( - list(formula = formula, family = family), - dot_args - ))))) + return(do.call(stats::glm, c(list(formula = formula, family = family), + dot_args))) } } @@ -199,10 +220,7 @@ fit_gam_callback <- function(formula, ...) { methods::formalArgs(mgcv::gam.fit)) )] # Call the submodel fitter: - return(suppressMessages(suppressWarnings(do.call(mgcv::gam, c( - list(formula = formula), - dot_args - ))))) + return(do.call(mgcv::gam, c(list(formula = formula), dot_args))) } # Use package "gamm4" to fit additive multilevel submodels: @@ -219,11 +237,11 @@ fit_gamm_callback <- function(formula, projpred_formula_no_random, )] # Call the submodel fitter: fit <- tryCatch({ - suppressMessages(suppressWarnings(do.call(gamm4::gamm4, c( + do.call(gamm4::gamm4, c( list(formula = projpred_formula_no_random, random = projpred_random, data = data, family = family, control = control), dot_args - )))) + )) }, error = function(e) { if (grepl("not positive definite", as.character(e))) { if ("optimx" %in% control$optimizer && @@ -328,11 +346,11 @@ fit_glmer_callback <- function(formula, projpred_formula_no_random, stop("Unexpected length of `random_fmls`.") } # Call the submodel fitter: - return(suppressMessages(suppressWarnings(do.call(MASS::glmmPQL, c( + return(do.call(MASS::glmmPQL, c( list(fixed = projpred_formula_no_random, random = random_fmls, family = family, control = control), dot_args - ))))) + ))) } else if (family$family == "gaussian" && family$link == "identity" && getOption("projpred.gaussian_not_as_generalized", TRUE)) { # Exclude arguments from `...` which cannot be passed to lme4::lmer(): @@ -342,10 +360,8 @@ fit_glmer_callback <- function(formula, projpred_formula_no_random, methods::formalArgs(lme4::lmer) )] # Call the submodel fitter: - return(suppressMessages(suppressWarnings(do.call(lme4::lmer, c( - list(formula = formula, control = control), - dot_args - ))))) + return(do.call(lme4::lmer, c(list(formula = formula, control = control), + dot_args))) } else { # Exclude arguments from `...` which cannot be passed to lme4::glmer(): dot_args <- list(...) @@ -354,10 +370,9 @@ fit_glmer_callback <- function(formula, projpred_formula_no_random, methods::formalArgs(lme4::glmer) )] # Call the submodel fitter: - return(suppressMessages(suppressWarnings(do.call(lme4::glmer, c( - list(formula = formula, family = family, control = control), - dot_args - ))))) + return(do.call(lme4::glmer, c(list(formula = formula, family = family, + control = control), + dot_args))) } }, error = function(e) { if (grepl("No random effects", as.character(e))) { @@ -418,17 +433,30 @@ fit_glmer_callback <- function(formula, projpred_formula_no_random, } else if (grepl("pwrssUpdate did not converge in \\(maxit\\) iterations", as.character(e))) { tolPwrss_new <- 10 * control$tolPwrss - if (length(control$optCtrl$maxfun) > 0) { - maxfun_new <- 10 * control$optCtrl$maxfun - } else { - maxfun_new <- 1e4 + optCtrl_new <- list() + if (length(control$optimizer) == 0) { + stop("Unexpected length of `control$optimizer`. Please notify the ", + "package maintainer.") } - if (length(control$optCtrl$maxit) > 0) { - maxit_new <- 10 * control$optCtrl$maxit - } else { - maxit_new <- 1e4 + if (any(control$optimizer %in% c("Nelder_Mead", "bobyqa"))) { + if (length(control$optCtrl$maxfun) > 0) { + maxfun_new <- 10 * control$optCtrl$maxfun + } else { + maxfun_new <- 1e4 + } + optCtrl_new <- c(optCtrl_new, list(maxfun = maxfun_new)) } - if (tolPwrss_new > 1e-4 && maxfun_new > 1e7 && maxit_new > 1e7) { + if (any(!control$optimizer %in% c("Nelder_Mead", "bobyqa"))) { + if (length(control$optCtrl$maxit) > 0) { + maxit_new <- 10 * control$optCtrl$maxit + } else { + maxit_new <- 1e4 + } + optCtrl_new <- c(optCtrl_new, list(maxit = maxit_new)) + } + if (tolPwrss_new > 1e-4 && + (optCtrl_new$maxfun %||% -Inf > 1e7 || + optCtrl_new$maxit %||% -Inf > 1e7)) { stop("Encountering the ", "`pwrssUpdate did not converge in (maxit) iterations` error ", "while running the lme4 fitting procedure, but cannot fix this ", @@ -441,8 +469,7 @@ fit_glmer_callback <- function(formula, projpred_formula_no_random, projpred_random = projpred_random, family = family, control = control_callback(family, tolPwrss = tolPwrss_new, - optCtrl = list(maxfun = maxfun_new, - maxit = maxit_new)), + optCtrl = optCtrl_new), ... )) } else if (getOption("projpred.PQL", FALSE) && @@ -530,6 +557,8 @@ divmin_augdat <- function( projpred_var, projpred_ws_aug, verbose_divmin = getOption("projpred.verbose_project", FALSE), + throw_warn_sdivmin = getOption("projpred.warn_prj_drawwise", TRUE), + do_check_conv = getOption("projpred.check_conv", TRUE), ... ) { trms_all <- extract_terms_response(formula) @@ -594,20 +623,23 @@ divmin_augdat <- function( style = 3, initial = 0) on.exit(close(pb)) } - return(lapply(seq_len(ncol(projpred_ws_aug)), function(s) { + outdmin <- lapply(seq_len(ncol(projpred_ws_aug)), function(s) { if (verbose_divmin) { on.exit(utils::setTxtProgressBar(pb, s)) } - sdivmin( - formula = formula, - data = data, - family = family, - weights = projpred_ws_aug[, s], - projpred_formula_no_random = projpred_formula_no_random, - projpred_random = projpred_random, - ... + mssgs_warns_capt <- capt_mssgs_warns( + soutdmin <- sdivmin( + formula = formula, + data = data, + family = family, + weights = projpred_ws_aug[, s], + projpred_formula_no_random = projpred_formula_no_random, + projpred_random = projpred_random, + ... + ) ) - })) + return(nlist(soutdmin, mssgs_warns_capt)) + }) } else { # Parallel case. if (!requireNamespace("foreach", quietly = TRUE)) { @@ -618,7 +650,7 @@ divmin_augdat <- function( } dot_args <- list(...) `%do_projpred%` <- foreach::`%dopar%` - return(foreach::foreach( + outdmin <- foreach::foreach( projpred_w_aug_s = iterators::iter(projpred_ws_aug, by = "column"), .export = c( "sdivmin", "formula", "data", "family", "projpred_formula_no_random", @@ -629,18 +661,45 @@ divmin_augdat <- function( "projpred_ws_aug", "linkobjs" ) ) %do_projpred% { - do.call( - sdivmin, - c(list(formula = formula, - data = data, - family = family, - weights = as.vector(projpred_w_aug_s), - projpred_formula_no_random = projpred_formula_no_random, - projpred_random = projpred_random), - dot_args) + mssgs_warns_capt <- capt_mssgs_warns( + soutdmin <- do.call( + sdivmin, + c(list(formula = formula, + data = data, + family = family, + weights = as.vector(projpred_w_aug_s), + projpred_formula_no_random = projpred_formula_no_random, + projpred_random = projpred_random), + dot_args) + ) ) - }) + return(nlist(soutdmin, mssgs_warns_capt)) + } } + mssgs_warns_capts <- lapply(outdmin, "[[", "mssgs_warns_capt") + outdmin <- lapply(outdmin, "[[", "soutdmin") + mssgs_warns_capts <- lapply(mssgs_warns_capts, function(mssgs_warns_capt) { + # Filter out some warnings. + mssgs_warns_capt <- setdiff(mssgs_warns_capt, "") + mssgs_warns_capt <- grep("Warning in [^:]*:$", + mssgs_warns_capt, value = TRUE, invert = TRUE) + # For MASS::polr(): + mssgs_warns_capt <- grep("non-integer #successes in a binomial glm!$", + mssgs_warns_capt, value = TRUE, invert = TRUE) + # For ordinal::clmm(): + mssgs_warns_capt <- grep(paste("Using formula\\(x\\) is deprecated when x", + "is a character vector of length > 1\\.$"), + mssgs_warns_capt, value = TRUE, invert = TRUE) + # For ordinal::clmm(): + mssgs_warns_capt <- grep( + "Consider formula\\(paste\\(x, collapse = .*\\)\\) instead\\.$", + mssgs_warns_capt, value = TRUE, invert = TRUE + ) + return(mssgs_warns_capt) + }) + warn_prj_drawwise(mssgs_warns_capts, throw_warn = throw_warn_sdivmin) + check_conv(outdmin, lengths(mssgs_warns_capts), do_check = do_check_conv) + return(outdmin) } # Use MASS::polr() to fit submodels for the brms::cumulative() family: @@ -667,21 +726,15 @@ fit_cumul <- function(formula, data, family, weights, ...) { } else if (link_nm == "probit_approx") { link_nm <- "probit" } - # For catching warnings via capture.output() (which is necessary to filter out - # the warning "non-integer #successes in a binomial glm!"): - warn_orig <- options(warn = 1) # Call the submodel fitter: - warn_capt <- utils::capture.output({ - fitobj <- try(do.call(MASS::polr, c( - list(formula = formula, - data = data, - weights = quote(projpred_internal_w_aug), - model = FALSE, - method = link_nm), - dot_args - )), silent = TRUE) - }, type = "message") - options(warn_orig) + fitobj <- try(do.call(MASS::polr, c( + list(formula = formula, + data = data, + weights = quote(projpred_internal_w_aug), + model = FALSE, + method = link_nm), + dot_args + )), silent = TRUE) if (inherits(fitobj, "try-error") && grepl(paste("initial value in 'vmmin' is not finite", "attempt to find suitable starting values failed", @@ -700,29 +753,18 @@ fit_cumul <- function(formula, data, family, weights, ...) { # Start with thresholds which imply equal probabilities for the response # categories: start_thres <- linkfun_raw(seq_len(nthres) / ncats, link_nm = link_nm) - warn_orig <- options(warn = 1) - warn_capt <- utils::capture.output({ - fitobj <- try(do.call(MASS::polr, c( - list(formula = formula, - data = data, - weights = quote(projpred_internal_w_aug), - model = FALSE, - method = link_nm, - start = c(start_coefs, start_thres)), - dot_args - )), silent = TRUE) - }, type = "message") - options(warn_orig) - } - if (inherits(fitobj, "try-error")) { + fitobj <- do.call(MASS::polr, c( + list(formula = formula, + data = data, + weights = quote(projpred_internal_w_aug), + model = FALSE, + method = link_nm, + start = c(start_coefs, start_thres)), + dot_args + )) + } else if (inherits(fitobj, "try-error")) { stop(attr(fitobj, "condition")$message) } - warn_capt <- grep("Warning in .*:$", warn_capt, value = TRUE, invert = TRUE) - warn_capt <- grep("non-integer #successes in a binomial glm!$", warn_capt, - value = TRUE, invert = TRUE) - if (length(warn_capt) > 0) { - warning(warn_capt) - } return(fitobj) } @@ -761,39 +803,17 @@ fit_cumul_mlvl <- function(formula, data, family, weights, ...) { if (link_nm == "probit_approx") { link_nm <- "probit" } - # For catching warnings via capture.output() (which is necessary to filter out - # the warning "Using formula(x) is deprecated when x is a character vector of - # length > 1. [...]"): - warn_orig <- options(warn = 1) # Call the submodel fitter: - warn_capt <- utils::capture.output({ - fitobj <- try(do.call(ordinal::clmm, c( - list(formula = formula, - data = data, - weights = quote(projpred_internal_w_aug), - contrasts = NULL, - Hess = FALSE, - model = FALSE, - link = link_nm), - dot_args - )), silent = TRUE) - }, type = "message") - options(warn_orig) - if (inherits(fitobj, "try-error")) { - stop(attr(fitobj, "condition")$message) - } - warn_capt <- grep( - paste("Using formula\\(x\\) is deprecated when x is a character vector of", - "length > 1\\.$"), - warn_capt, value = TRUE, invert = TRUE - ) - warn_capt <- grep( - "Consider formula\\(paste\\(x, collapse = .*\\)\\) instead\\.$", - warn_capt, value = TRUE, invert = TRUE - ) - if (length(warn_capt) > 0) { - warning(warn_capt) - } + fitobj <- do.call(ordinal::clmm, c( + list(formula = formula, + data = data, + weights = quote(projpred_internal_w_aug), + contrasts = NULL, + Hess = FALSE, + model = FALSE, + link = link_nm), + dot_args + )) # Needed for the ordinal:::predict.clm() workaround (the value `"negative"` is # the default, see `?ordinal::clm.control`): fitobj$control$sign.location <- "negative" @@ -833,16 +853,20 @@ fit_categ <- function(formula, data, family, weights, ...) { } } # Call the submodel fitter: - out_capt <- utils::capture.output({ + out_capt <- utils::capture.output( fitobj <- do.call(nnet::multinom, c( list(formula = formula, data = data, weights = weights), dot_args )) - }) + ) if (utils::tail(out_capt, 1) != "converged") { - warning("The nnet::multinom() submodel fit did not converge.") + warning( + "Could not find the string \"converged\" at the end of the `stdout` ", + "output from the nnet::multinom() submodel fit, so perhaps this fitting ", + "procedure did not converge." + ) } return(fitobj) } @@ -897,7 +921,7 @@ fit_categ_mlvl <- function(formula, projpred_formula_no_random, random_fmls <- random_fmls[[1]] } # Call the submodel fitter: - out_capt <- utils::capture.output({ + out_capt <- utils::capture.output( fitobj <- do.call(mclogit::mblogit, c( list(formula = projpred_formula_no_random, data = data, @@ -909,60 +933,127 @@ fit_categ_mlvl <- function(formula, projpred_formula_no_random, method = "PQL"), dot_args )) - }) + ) if (utils::tail(out_capt, 1) != "converged") { - warning("The mclogit::mblogit() submodel fit did not converge.") + warning( + "Could not find the string \"converged\" at the end of the `stdout` ", + "output from the mclogit::mblogit() submodel fit, so perhaps this ", + "fitting procedure did not converge." + ) } return(fitobj) } -# Convergence checker ----------------------------------------------------- +# Convergence issues ------------------------------------------------------ + +# Throw unique messages and warnings from a list of messages and warnings +# retrieved during draw-wise projections: +warn_prj_drawwise <- function(mssgs_warns_capts, throw_warn = TRUE) { + if (!throw_warn) return() + mssgs_warns_capts_unq <- unique(unlist(mssgs_warns_capts)) + if (length(mssgs_warns_capts_unq) > 0) { + warning(paste( + c(paste0("The following messages and/or warnings have been thrown by ", + "the current submodel fitter (i.e., the current draw-wise ", + "divergence minimizer):"), + "---", mssgs_warns_capts_unq, "---"), + collapse = "\n" + )) + } + return() +} -check_conv <- function(fit) { - is_conv <- unlist(lapply(fit, function(fit_s) { - if (inherits(fit_s, "gam")) { - # TODO (GAMs): There is also `fit_s$mgcv.conv` (see `?mgcv::gamObject`). - # Do we need to take this into account? - return(fit_s$converged) - } else if (inherits(fit_s, "gamm4")) { - # TODO (GAMMs): Needs to be implemented. Return `TRUE` for now. - return(TRUE) - } else if (inherits(fit_s, c("lmerMod", "glmerMod"))) { - # The following was inferred from the source code of lme4::checkConv() and - # lme4::.prt.warn() (see also `?lme4::mkMerMod`). - return(fit_s@optinfo$conv$opt == 0 && ( - # Since lme4::.prt.warn() does not refer to `optinfo$conv$lme4$code`, - # that element might not always exist: - (!is.null(fit_s@optinfo$conv$lme4$code) && - all(fit_s@optinfo$conv$lme4$code == 0)) || - is.null(fit_s@optinfo$conv$lme4$code) - ) && length(unlist(fit_s@optinfo$conv$lme4$messages)) == 0 && - length(fit_s@optinfo$warnings) == 0) - } else if (inherits(fit_s, "glm")) { - return(fit_s$converged) - } else if (inherits(fit_s, "lm")) { - # Note: There doesn't seem to be a better way to check for convergence - # other than checking `NA` coefficients (see below). - return(all(!is.na(coef(fit_s)))) - } else if (inherits(fit_s, "subfit")) { - # Note: There doesn't seem to be any way to check for convergence, so - # return `TRUE` for now. - # TODO (GLMs with ridge regularization): Add a logical indicating - # convergence to objects of class `subfit` (i.e., from glm_ridge())? - return(TRUE) +# Check the convergence of the submodel fits from a whole `outdmin` object, also +# taking into account whether messages and warnings were thrown (indicated by +# argument `lengths_mssgs_warns` which must be of the same length as `outdmin`): +check_conv <- function(outdmin, lengths_mssgs_warns, do_check = TRUE) { + if (!do_check) return() + is_conv <- tryCatch( + unlist(lapply(outdmin, check_conv_s)), + error = function(e) { + warning("The draw-wise convergence checker errored with message \n```\n", + e, "```\nso the convergence of the current submodel fits cannot ", + "be checked. Please notify the package maintainer. Current ", + "submodel formula (right-hand side): ", + update(formula(outdmin[[1]]), NULL ~ .)) + return(rep(TRUE, length(outdmin))) + } + ) + is_conv <- is_conv & (lengths_mssgs_warns == 0) + not_conv <- sum(!is_conv) + if (not_conv > 0) { + if (getOption("projpred.additional_checks", FALSE)) { + cls <- unique(lapply(outdmin, class)) + stopifnot(length(cls) == 1) + cls <- cls[[1]] } else { - stop("Unrecognized submodel fit. Please notify the package maintainer.") + cls <- class(outdmin[[1]]) } - })) - if (any(!is_conv)) { - warning(sum(!is_conv), " out of ", length(is_conv), " submodel fits ", - "(there is one submodel fit per projected draw) probably have not ", - "converged (appropriately). It is recommended to inspect this in ", - "detail and (if necessary) to adjust lme4's tuning parameters via ", - "`...` or via a custom `divergence_minimizer` function. ", - "Formula (right-hand side): ", update(formula(fit[[1]]), NULL ~ .)) + cls <- paste0("c(", paste(paste0("\"", cls, "\""), collapse = ", "), ")") + warning( + not_conv, " out of ", length(is_conv), " submodel fits (there is one ", + "submodel fit per projected draw) might not have converged ", + "(appropriately). It is recommended to inspect this in detail and (if ", + "necessary) to adjust tuning parameters via `...` (the ellipsis of the ", + "employed top-level function such as project(), varsel(), or ", + "cv_varsel()) or via a custom `div_minimizer` function (an argument of ", + "init_refmodel()). In the present case, the submodel fits are of ", + "class(es) `", cls, "`. Documentation for corresponding tuning ", + "parameters is linked in section \"Draw-wise divergence minimizers\" of ", + "`` ?`projpred-package` ``. Current submodel formula (right-hand side): ", + update(formula(outdmin[[1]]), NULL ~ .) + ) + } + return() +} + +# Helper function for checking the convergence of a single submodel fit (not of +# a whole `outdmin` object): +check_conv_s <- function(fit_s) { + if (inherits(fit_s, "mmblogit")) { + return(fit_s$converged) + } else if (inherits(fit_s, "multinom")) { + return(fit_s$convergence == 0) + } else if (inherits(fit_s, "clmm")) { + return(fit_s$optRes$convergence == 0) + } else if (inherits(fit_s, "polr")) { + return(fit_s$convergence == 0) + } else if (inherits(fit_s, "gam")) { + # TODO (GAMs): Is this correct?: + return(fit_s$converged && fit_s$mgcv.conv$fully.converged %||% TRUE) + } else if (inherits(fit_s, "gamm4")) { + # TODO (GAMMs): I couldn't find any convergence-related information in + # element `fit_s$gam`, so the GAM part is currently not checked for + # convergence. For now, all we can check is the GLMM part from element + # `fit_s$mer`: + return(check_conv_s(fit_s$mer)) + } else if (inherits(fit_s, c("lmerMod", "glmerMod"))) { + # The following was inferred from the source code of lme4::checkConv() and + # lme4::.prt.warn() (see also `?lme4::mkMerMod`). + return(fit_s@optinfo$conv$opt == 0 && ( + # Since lme4::.prt.warn() does not refer to `optinfo$conv$lme4$code`, + # that element might not always exist: + (!is.null(fit_s@optinfo$conv$lme4$code) && + all(fit_s@optinfo$conv$lme4$code == 0)) || + is.null(fit_s@optinfo$conv$lme4$code) + ) && length(unlist(fit_s@optinfo$conv$lme4$messages)) == 0 && + length(fit_s@optinfo$warnings) == 0) + } else if (inherits(fit_s, "glm")) { + return(fit_s$converged) + } else if (inherits(fit_s, "lm")) { + # There doesn't seem to be a better way to check for convergence other than + # checking `NA` coefficients: + return(all(!is.na(coef(fit_s)))) + } else if (inherits(fit_s, "subfit")) { + # For a submodel of class `subfit`, non-convergence is only indicated by + # output written to the console (which is converted to a warning in + # fit_glm_ridge_callback() and then checked in check_conv()), so we need to + # return `TRUE` here: + return(TRUE) + } else { + warning("Unrecognized submodel fit. Please notify the package maintainer.") + return(TRUE) } - return(invisible(TRUE)) } # Prediction functions for submodels -------------------------------------- diff --git a/R/projfun.R b/R/projfun.R index d967eb9fb..114ad6782 100644 --- a/R/projfun.R +++ b/R/projfun.R @@ -39,10 +39,6 @@ proj_to_submodl <- function(predictor_terms, p_ref, refmodel, } outdmin <- do.call(refmodel$div_minimizer, args_divmin) - if (isTRUE(getOption("projpred.check_conv", FALSE))) { - check_conv(outdmin) - } - return(init_submodl( outdmin = outdmin, p_ref = p_ref, refmodel = refmodel, predictor_terms = predictor_terms, wobs = refmodel$wobs @@ -153,8 +149,8 @@ perf_eval <- function(search_path, return(out) } -# Process the output of the `divergence_minimizer` function (see -# init_refmodel()) to create an object of class `submodl`. +# Process the output of the `div_minimizer` function (see init_refmodel()) to +# create an object of class `submodl`. init_submodl <- function(outdmin, p_ref, refmodel, predictor_terms, wobs) { p_ref$mu <- p_ref$mu_offs if (!(all(is.na(p_ref$var)) || diff --git a/R/projpred-package.R b/R/projpred-package.R index de885ea16..7154adf68 100644 --- a/R/projpred-package.R +++ b/R/projpred-package.R @@ -82,17 +82,28 @@ #' * Submodel with multilevel and additive terms: [gamm4::gamm4()] (within #' \pkg{projpred}, the returned object inherits from class `gamm4`). #' -#' # Verbosity -#' -#' Setting the global option `projpred.extra_verbose` to `TRUE` will print out -#' which submodel \pkg{projpred} is currently projecting onto as well as (if -#' `method = "forward"` and `verbose = TRUE` in [varsel()] or [cv_varsel()]) -#' which submodel has been selected at those steps of the forward search for -#' which a percentage (of the maximum submodel size that the search is run up -#' to) is printed. In general, however, we cannot recommend setting this global -#' option to `TRUE` for [cv_varsel()] with `validate_search = TRUE` (simply due -#' to the amount of information that will be printed, but also due to the -#' progress bar which will not work anymore as intended). +#' # Verbosity, messages, warnings, errors +#' +#' Setting global option `projpred.extra_verbose` to `TRUE` will print out which +#' submodel \pkg{projpred} is currently projecting onto as well as (if `method = +#' "forward"` and `verbose = TRUE` in [varsel()] or [cv_varsel()]) which +#' submodel has been selected at those steps of the forward search for which a +#' percentage (of the maximum submodel size that the search is run up to) is +#' printed. In general, however, we cannot recommend setting this global option +#' to `TRUE` for [cv_varsel()] with `validate_search = TRUE` (simply due to the +#' amount of information that will be printed, but also due to the progress bar +#' which will not work as intended anymore). +#' +#' By default, \pkg{projpred} catches messages and warnings from the draw-wise +#' divergence minimizers and throws their unique collection after performing all +#' draw-wise divergence minimizations (i.e., draw-wise projections). This can be +#' deactivated by setting global option `projpred.warn_prj_drawwise` to `FALSE`. +#' +#' Furthermore, by default, \pkg{projpred} checks the convergence of the +#' draw-wise divergence minimizers and throws a warning if any seem to have not +#' converged. This warning is thrown after the warning message from global +#' option `projpred.warn_prj_drawwise` (see above) and can be deactivated by +#' setting global option `projpred.check_conv` to `FALSE`. #' #' # Parallelization #' diff --git a/R/search.R b/R/search.R index d879206d1..8b17f3bba 100644 --- a/R/search.R +++ b/R/search.R @@ -212,15 +212,27 @@ search_L1_surrogate <- function(p_ref, d_train, family, intercept, nterms_max, ## (Notice: here we use pmax = nterms_max+1 so that the computation gets ## carried until all the way down to the least regularization also for model ## size nterms_max) - search <- glm_elnet( - d_train$x, mu, family, - lambda_min_ratio = search_control$lambda_min_ratio %||% 1e-5, - nlambda = search_control$nlambda %||% 150, - pmax = nterms_max + 1, pmax_strict = FALSE, - weights = d_train$weights, - intercept = intercept, obsvar = v, penalty = penalty, - thresh = search_control$thresh %||% 1e-6 + out_capt <- utils::capture.output( + search <- glm_elnet( + d_train$x, mu, family, + lambda_min_ratio = search_control$lambda_min_ratio %||% 1e-5, + nlambda = search_control$nlambda %||% 150, pmax = nterms_max + 1, + pmax_strict = FALSE, weights = d_train$weights, intercept = intercept, + obsvar = v, penalty = penalty, thresh = search_control$thresh %||% 1e-6 + ) ) + out_capt <- unique(grep("[Ww]arning|bug", out_capt, value = TRUE)) + if (length(out_capt) > 0) { + warning(paste( + c(paste0("The following warnings have been thrown by projpred's ", + "internal L1-search function:"), + "---", out_capt, "---", + paste0("It is recommended to inspect this in detail and (if ", + "necessary) to adjust tuning parameters via argument ", + "`search_control` (of varsel() or cv_varsel()).")), + collapse = "\n" + )) + } ## sort the variables according to the order in which they enter the model in ## the L1-path diff --git a/man/projpred-package.Rd b/man/projpred-package.Rd index d378c3843..b4f0627fe 100644 --- a/man/projpred-package.Rd +++ b/man/projpred-package.Rd @@ -81,16 +81,26 @@ object inherits from class \code{gam}). } } -\section{Verbosity}{ -Setting the global option \code{projpred.extra_verbose} to \code{TRUE} will print out -which submodel \pkg{projpred} is currently projecting onto as well as (if -\code{method = "forward"} and \code{verbose = TRUE} in \code{\link[=varsel]{varsel()}} or \code{\link[=cv_varsel]{cv_varsel()}}) -which submodel has been selected at those steps of the forward search for -which a percentage (of the maximum submodel size that the search is run up -to) is printed. In general, however, we cannot recommend setting this global -option to \code{TRUE} for \code{\link[=cv_varsel]{cv_varsel()}} with \code{validate_search = TRUE} (simply due -to the amount of information that will be printed, but also due to the -progress bar which will not work anymore as intended). +\section{Verbosity, messages, warnings, errors}{ +Setting global option \code{projpred.extra_verbose} to \code{TRUE} will print out which +submodel \pkg{projpred} is currently projecting onto as well as (if \code{method = "forward"} and \code{verbose = TRUE} in \code{\link[=varsel]{varsel()}} or \code{\link[=cv_varsel]{cv_varsel()}}) which +submodel has been selected at those steps of the forward search for which a +percentage (of the maximum submodel size that the search is run up to) is +printed. In general, however, we cannot recommend setting this global option +to \code{TRUE} for \code{\link[=cv_varsel]{cv_varsel()}} with \code{validate_search = TRUE} (simply due to the +amount of information that will be printed, but also due to the progress bar +which will not work as intended anymore). + +By default, \pkg{projpred} catches messages and warnings from the draw-wise +divergence minimizers and throws their unique collection after performing all +draw-wise divergence minimizations (i.e., draw-wise projections). This can be +deactivated by setting global option \code{projpred.warn_prj_drawwise} to \code{FALSE}. + +Furthermore, by default, \pkg{projpred} checks the convergence of the +draw-wise divergence minimizers and throws a warning if any seem to have not +converged. This warning is thrown after the warning message from global +option \code{projpred.warn_prj_drawwise} (see above) and can be deactivated by +setting global option \code{projpred.check_conv} to \code{FALSE}. } \section{Parallelization}{ diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 0517d6b53..05b94b4fc 100755 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -208,15 +208,6 @@ fam_nms_aug_regex <- paste0("\\.(", paste(fam_nms_aug, collapse = "|"), ")\\.") fam_nms_unsupp_regex <- paste0("\\.(", paste(fam_nms_unsupp, collapse = "|"), ")\\.") -# Needed for package mclogit (providing the submodel fitter for multilevel -# brms::categorical() models): -warn_mclogit <- if (packageVersion("mclogit") >= "0.9.6") { - "Inner iterations did not coverge" -} else { - paste0("^step size truncated due to possible divergence$|", - "^Algorithm stopped due to false convergence$") -} - # Data -------------------------------------------------------------------- ## Setup ------------------------------------------------------------------ @@ -904,6 +895,10 @@ options(projpred.additional_checks = TRUE) # Suppress the warning thrown if `cvrefbuilder` is `NULL` (here in the tests, # this should only be relevant for `datafit`s): options(projpred.warn_cvrefbuilder_NULL = FALSE) +# Suppress warnings thrown while fitting the submodels: +options(projpred.warn_prj_drawwise = FALSE) +# Don't use the convergence checker: +options(projpred.check_conv = FALSE) # Set default number of significant digits to be printed: options(projpred.digits = getOption("digits")) @@ -1141,22 +1136,10 @@ if (run_vs) { })) >= 1) vss <- lapply(args_vs, function(args_vs_i) { - if (args_vs_i$prj_nm == "augdat" && args_vs_i$fam_nm == "cumul") { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (!is.null(args_vs_i$avoid.increase)) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - vs_out <- do.call(varsel, c( - list(object = refmods[[args_vs_i$tstsetup_ref]]), - excl_nonargs(args_vs_i) - )), - warn_expected, - info = args_vs_i$tstsetup_ref - ) - return(vs_out) + do.call(varsel, c( + list(object = refmods[[args_vs_i$tstsetup_ref]]), + excl_nonargs(args_vs_i) + )) }) } @@ -1419,24 +1402,10 @@ if (run_prj) { args_prj <- unlist_cust(args_prj) prjs <- lapply(args_prj, function(args_prj_i) { - if (args_prj_i$prj_nm == "augdat" && args_prj_i$fam_nm == "cumul" && - !any(grepl("\\|", args_prj_i$predictor_terms))) { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (!is.null(args_prj_i$avoid.increase) && - any(grepl("\\|", args_prj_i$predictor_terms))) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - prj_out <- do.call(project, c( - list(object = refmods[[args_prj_i$tstsetup_ref]]), - excl_nonargs(args_prj_i) - )), - warn_expected, - info = args_prj_i$tstsetup_ref - ) - return(prj_out) + do.call(project, c( + list(object = refmods[[args_prj_i$tstsetup_ref]]), + excl_nonargs(args_prj_i) + )) }) } @@ -1554,16 +1523,12 @@ if (run_cvvs) { args_prj_cvvs <- cre_args_prj_vsel(tstsetups_prj_cvvs) args_prj_cvvs <- unlist_cust(args_prj_cvvs) - # Use suppressWarnings() because of occasional pwrssUpdate() warnings: - prjs_cvvs <- suppressWarnings(lapply( - args_prj_cvvs, - function(args_prj_cvvs_i) { - do.call(project, c( - list(object = cvvss[[args_prj_cvvs_i$tstsetup_vsel]]), - excl_nonargs(args_prj_cvvs_i) - )) - } - )) + prjs_cvvs <- lapply(args_prj_cvvs, function(args_prj_cvvs_i) { + do.call(project, c( + list(object = cvvss[[args_prj_cvvs_i$tstsetup_vsel]]), + excl_nonargs(args_prj_cvvs_i) + )) + }) } ## Prediction ------------------------------------------------------------- diff --git a/tests/testthat/test_div_minimizer.R b/tests/testthat/test_div_minimizer.R index e118f3652..478f72083 100644 --- a/tests/testthat/test_div_minimizer.R +++ b/tests/testthat/test_div_minimizer.R @@ -163,7 +163,12 @@ test_that("divmin_augdat() works", { "length > 1" ) } else if (fam_crr == "categ" && mod_crr == "glmm") { - warn_expected <- warn_mclogit + warn_expected <- if (packageVersion("mclogit") >= "0.9.6") { + "Inner iterations did not coverge" + } else { + paste0("^step size truncated due to possible divergence$|", + "^Algorithm stopped due to false convergence$") + } } else { warn_expected <- NA } diff --git a/tests/testthat/test_parallel.R b/tests/testthat/test_parallel.R index 870520d7a..7ea40a6d7 100644 --- a/tests/testthat/test_parallel.R +++ b/tests/testthat/test_parallel.R @@ -65,8 +65,8 @@ test_that("cv_varsel() in parallel gives the same results as sequentially", { tstsetups <- grep("\\.glm\\.", names(cvvss), value = TRUE) for (tstsetup in tstsetups) { args_cvvs_i <- args_cvvs[[tstsetup]] - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_repr <- suppressWarnings(do.call(cv_varsel, c( list(object = refmods[[args_cvvs_i$tstsetup_ref]], cvfits = if (identical(args_cvvs_i$cv_method, "kfold")) { diff --git a/tests/testthat/test_proj_pred.R b/tests/testthat/test_proj_pred.R index f8fef78b7..3fffb6cfc 100644 --- a/tests/testthat/test_proj_pred.R +++ b/tests/testthat/test_proj_pred.R @@ -913,13 +913,6 @@ test_that(paste( } else { ncats_nlats_expected_crr <- integer() } - if (args_prj[[tstsetup]]$prj_nm == "augdat" && - args_prj[[tstsetup]]$fam_nm == "cumul" && - !any(grepl("\\|", args_prj[[tstsetup]]$predictor_terms))) { - warn_expected <- "non-integer #successes in a binomial glm!" - } else { - warn_expected <- NA - } pl_args <- list(refmods[[args_prj[[tstsetup]]$tstsetup_ref]], newdata = head(get_dat(tstsetup), 1), weightsnew = wobs_crr, @@ -931,12 +924,10 @@ test_that(paste( if (args_prj[[tstsetup]]$fam_nm == "categ" && any(grepl("\\|", args_prj[[tstsetup]]$predictor_terms))) { pl_args <- c(pl_args, list(avoid.increase = TRUE)) - warn_expected <- warn_mclogit } - expect_warning( - pl1 <- do.call(proj_linpred, pl_args), - warn_expected - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + pl1 <- suppressWarnings(do.call(proj_linpred, pl_args)) pl_tester(pl1, nprjdraws_expected = 1L, nobsv_expected = 1L, @@ -1658,13 +1649,6 @@ test_that(paste( } else { offs_crr <- NULL } - if (args_prj[[tstsetup]]$prj_nm == "augdat" && - args_prj[[tstsetup]]$fam_nm == "cumul" && - !any(grepl("\\|", args_prj[[tstsetup]]$predictor_terms))) { - warn_expected <- "non-integer #successes in a binomial glm!" - } else { - warn_expected <- NA - } pp_args <- list(refmods[[args_prj[[tstsetup]]$tstsetup_ref]], newdata = head(get_dat(tstsetup), 1), weightsnew = wobs_crr, @@ -1677,12 +1661,10 @@ test_that(paste( if (args_prj[[tstsetup]]$fam_nm == "categ" && any(grepl("\\|", args_prj[[tstsetup]]$predictor_terms))) { pp_args <- c(pp_args, list(avoid.increase = TRUE)) - warn_expected <- warn_mclogit } - expect_warning( - pp1 <- do.call(proj_predict, pp_args), - warn_expected - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + pp1 <- suppressWarnings(do.call(proj_predict, pp_args)) pp_tester(pp1, nprjdraws_out_expected = 1L, nobsv_expected = 1L, diff --git a/tests/testthat/test_proj_predfun.R b/tests/testthat/test_proj_predfun.R index 8295280a8..fa7082bc0 100644 --- a/tests/testthat/test_proj_predfun.R +++ b/tests/testthat/test_proj_predfun.R @@ -411,7 +411,7 @@ test_that(paste( NA } expect_warning( - out_capt <- capture.output({ + out_capt <- capture.output( mfit <- mclogit::mblogit( formula = cell ~ treat + age + Karn + prior, data = VA, @@ -419,7 +419,7 @@ test_that(paste( model = FALSE, y = FALSE ) - }), + ), warn_expected ) expect_identical(tail(out_capt, 1), "converged") @@ -653,7 +653,7 @@ test_that(paste( NA } expect_warning( - out_capt <- capture.output({ + out_capt <- capture.output( mfit <- mclogit::mblogit( formula = cell ~ treat + age + Karn + prior, data = VA, @@ -662,7 +662,7 @@ test_that(paste( model = FALSE, y = FALSE ) - }), + ), warn_expected ) expect_identical(tail(out_capt, 1), "converged") diff --git a/tests/testthat/test_project.R b/tests/testthat/test_project.R index 14a39d21f..1a0610670 100644 --- a/tests/testthat/test_project.R +++ b/tests/testthat/test_project.R @@ -347,22 +347,12 @@ test_that("non-clustered projection does not require a seed", { args_prj_i <- args_prj[[tstsetup]] p_orig <- prjs[[tstsetup]] rand_new1 <- runif(1) # Just to advance `.Random.seed[2]`. - if (args_prj_i$prj_nm == "augdat" && args_prj_i$fam_nm == "cumul" && - !any(grepl("\\|", args_prj_i$predictor_terms))) { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (!is.null(args_prj_i$avoid.increase) && - any(grepl("\\|", args_prj_i$predictor_terms))) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - p_new <- do.call(project, c( - list(object = refmods[[args_prj_i$tstsetup_ref]]), - excl_nonargs(args_prj_i, nms_excl_add = "seed") - )), - warn_expected - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + p_new <- suppressWarnings(do.call(project, c( + list(object = refmods[[args_prj_i$tstsetup_ref]]), + excl_nonargs(args_prj_i, nms_excl_add = "seed") + ))) if (args_prj_i$mod_nm %in% c("glmm", "gamm") && any(grepl("\\|", args_prj_i$predictor_terms))) { if (getOption("projpred.mlvl_pred_new", FALSE)) { diff --git a/tests/testthat/test_varsel.R b/tests/testthat/test_varsel.R index 2e4218140..c286bf922 100644 --- a/tests/testthat/test_varsel.R +++ b/tests/testthat/test_varsel.R @@ -135,20 +135,12 @@ test_that(paste( } } d_test_crr$y_oscale <- y_oscale_crr - if (prj_crr == "augdat" && fam_crr == "cumul") { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (!is.null(args_vs_i$avoid.increase)) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - vs_repr <- do.call(varsel, c( - list(object = refmods[[tstsetup_ref]], d_test = d_test_crr), - excl_nonargs(args_vs_i) - )), - warn_expected - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + vs_repr <- suppressWarnings(do.call(varsel, c( + list(object = refmods[[tstsetup_ref]], d_test = d_test_crr), + excl_nonargs(args_vs_i) + ))) meth_exp_crr <- args_vs_i$method %||% "forward" vsel_tester( vs_repr, @@ -263,20 +255,12 @@ test_that(paste( } } d_test_crr$y_oscale <- y_oscale_crr - if (prj_crr == "augdat" && fam_crr == "cumul") { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (!is.null(args_vs_i$avoid.increase)) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - vs_indep <- do.call(varsel, c( - list(object = refmods[[tstsetup_ref]], d_test = d_test_crr), - excl_nonargs(args_vs_i) - )), - warn_expected - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + vs_indep <- suppressWarnings(do.call(varsel, c( + list(object = refmods[[tstsetup_ref]], d_test = d_test_crr), + excl_nonargs(args_vs_i) + ))) meth_exp_crr <- args_vs_i$method %||% "forward" vsel_tester( vs_indep, @@ -309,28 +293,22 @@ test_that(paste( # varsel() at the place where the new group-level effects are drawn (not # even `.seed = NA` with an appropriate preparation is possible). - if (!is.null(args_vs_i$avoid.increase)) { - warn_expected <- NA - } # For getting the correct seed in proj_linpred(): set.seed(args_vs_i$seed) p_sel_dummy <- get_refdist(refmods[[tstsetup_ref]], nclusters = vs_indep$nprjdraws_search) - expect_warning( - pl_indep <- proj_linpred( - vs_indep, - newdata = dat_indep_crr, - offsetnew = d_test_crr$offset, - weightsnew = d_test_crr$weights, - transform = TRUE, - integrated = TRUE, - .seed = NA, - nterms = c(0L, seq_along(vs_indep$predictor_ranking)), - nclusters = args_vs_i$nclusters_pred, - seed = NA - ), - warn_expected - ) + pl_indep <- suppressWarnings(proj_linpred( + vs_indep, + newdata = dat_indep_crr, + offsetnew = d_test_crr$offset, + weightsnew = d_test_crr$weights, + transform = TRUE, + integrated = TRUE, + .seed = NA, + nterms = c(0L, seq_along(vs_indep$predictor_ranking)), + nclusters = args_vs_i$nclusters_pred, + seed = NA + )) summ_sub_ch <- lapply(pl_indep, function(pl_indep_k) { names(pl_indep_k)[names(pl_indep_k) == "pred"] <- "mu" names(pl_indep_k)[names(pl_indep_k) == "lpd"] <- "lppd" @@ -525,21 +503,12 @@ test_that("`refit_prj` works", { for (tstsetup in tstsetups) { args_vs_i <- args_vs[[tstsetup]] args_vs_i$refit_prj <- FALSE - if (args_vs_i$prj_nm == "augdat" && args_vs_i$fam_nm == "cumul") { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (!is.null(args_vs_i$avoid.increase)) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - vs_reuse <- do.call(varsel, c( - list(object = refmods[[args_vs_i$tstsetup_ref]]), - excl_nonargs(args_vs_i) - )), - warn_expected, - info = tstsetup - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + vs_reuse <- suppressWarnings(do.call(varsel, c( + list(object = refmods[[args_vs_i$tstsetup_ref]]), + excl_nonargs(args_vs_i) + ))) mod_crr <- args_vs_i$mod_nm fam_crr <- args_vs_i$fam_nm prj_crr <- args_vs_i$prj_nm @@ -905,21 +874,13 @@ test_that("for forward search, `penalty` has no effect", { } for (tstsetup in tstsetups) { args_vs_i <- args_vs[[tstsetup]] - if (args_vs_i$prj_nm == "augdat" && args_vs_i$fam_nm == "cumul") { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (!is.null(args_vs_i$avoid.increase)) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - vs_penal <- do.call(varsel, c( - list(object = refmods[[args_vs_i$tstsetup_ref]], - penalty = penal_tst), - excl_nonargs(args_vs_i) - )), - warn_expected - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + vs_penal <- suppressWarnings(do.call(varsel, c( + list(object = refmods[[args_vs_i$tstsetup_ref]], + penalty = penal_tst), + excl_nonargs(args_vs_i) + ))) vs_penal$args_search["penalty"] <- list(NULL) expect_equal(vs_penal, vss[[tstsetup]], info = tstsetup) } @@ -1168,21 +1129,12 @@ test_that("varsel.vsel() works for `vsel` objects from cv_varsel()", { } fam_crr <- args_cvvs[[tstsetup]]$fam_nm prj_crr <- args_cvvs[[tstsetup]]$prj_nm - if (refit_prj_crr && prj_crr == "augdat" && fam_crr == "cumul") { - warn_expected <- "non-integer #successes in a binomial glm!" - } else if (refit_prj_crr && - !is.null(args_cvvs[[tstsetup]]$avoid.increase)) { - warn_expected <- warn_mclogit - } else { - warn_expected <- NA - } - expect_warning( - vs_eval <- varsel( - cvvss[[tstsetup]], refit_prj = refit_prj_crr, - nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst - ), - warn_expected - ) + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + vs_eval <- suppressWarnings(varsel( + cvvss[[tstsetup]], refit_prj = refit_prj_crr, + nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst + )) tstsetup_ref <- args_cvvs[[tstsetup]]$tstsetup_ref meth_exp_crr <- args_cvvs[[tstsetup]]$method %||% "forward" vsel_tester( @@ -1297,8 +1249,8 @@ test_that("`seed` works (and restores the RNG state afterwards)", { cvvs_orig <- cvvss[[tstsetup]] rand_orig <- runif(1) # Just to advance `.Random.seed[2]`. .Random.seed_repr1 <- .Random.seed - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_repr <- suppressWarnings(do.call(cv_varsel, c( list(object = refmods[[args_cvvs_i$tstsetup_ref]], cvfits = if (identical(args_cvvs_i$cv_method, "kfold")) { @@ -1427,8 +1379,8 @@ test_that("invalid `nloo` fails", { invert = TRUE) for (tstsetup in head(tstsetups_nonkfold, 1)) { args_cvvs_i <- args_cvvs[[tstsetup]] - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: expect_error( suppressWarnings(do.call(cv_varsel, c( list(object = refmods[[args_cvvs_i$tstsetup_ref]], @@ -1453,8 +1405,8 @@ test_that(paste( ) for (tstsetup in tstsetups) { args_cvvs_i <- args_cvvs[[tstsetup]] - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_nloo <- suppressWarnings(do.call(cv_varsel, c( list(object = refmods[[args_cvvs_i$tstsetup_ref]], nloo = nloo_tst), @@ -1488,8 +1440,8 @@ test_that("setting `nloo` smaller than the number of observations works", { fam_crr <- args_cvvs_i$fam_nm prj_crr <- args_cvvs_i$prj_nm meth_exp_crr <- args_cvvs_i$method %||% "forward" - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_nloo <- suppressWarnings(do.call(cv_varsel, c( list(object = refmods[[args_cvvs_i$tstsetup_ref]], nloo = nloo_tst), @@ -1555,8 +1507,8 @@ test_that("`validate_search` works", { fam_crr <- args_cvvs_i$fam_nm prj_crr <- args_cvvs_i$prj_nm meth_exp_crr <- args_cvvs_i$method %||% "forward" - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_valsearch <- suppressWarnings(do.call(cv_varsel, c( list(object = refmods[[args_cvvs_i$tstsetup_ref]], validate_search = FALSE, @@ -1726,10 +1678,12 @@ test_that(paste( )) # Run cv_varsel(): - cvvs_cvfits <- do.call(cv_varsel, c( + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: + cvvs_cvfits <- suppressWarnings(do.call(cv_varsel, c( list(object = refmod_crr), excl_nonargs(args_cvvs_i, nms_excl_add = "K") - )) + ))) # Checks: vsel_tester( @@ -1947,8 +1901,8 @@ test_that(paste( refit_prj_crr <- !identical(args_cvvs[[tstsetup]]$validate_search, FALSE) || identical(args_cvvs[[tstsetup]]$cv_method, "kfold") nclusters_pred_crr <- nclusters_pred_tst - if (refit_prj_crr) 1L else 0L - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_eval <- suppressWarnings(cv_varsel( cvvss[[tstsetup]], refit_prj = refit_prj_crr, nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst @@ -2004,8 +1958,8 @@ test_that(paste( refit_prj_crr <- FALSE nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred } - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_eval <- suppressWarnings(cv_varsel( vss[[tstsetup]], validate_search = FALSE, refit_prj = refit_prj_crr, nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst @@ -2069,8 +2023,8 @@ test_that(paste( } else { nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred } - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_eval <- suppressWarnings(cv_varsel( vss[[tstsetup]], cv_method = "kfold", cvfits = cvfitss[[tstsetup_ref]], validate_search = FALSE, nclusters_pred = nclusters_pred_crr, @@ -2112,8 +2066,8 @@ test_that(paste( if (isFALSE(args_cvvs[[tstsetup]]$validate_search)) { next } - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cvvs_eval <- suppressWarnings(cv_varsel( cvvss[[tstsetup]], cv_method = "LOO", validate_search = FALSE, @@ -2192,8 +2146,8 @@ test_that(paste( next } nclusters_pred_crr <- args_cvvs[[tstsetup]]$nclusters_pred - 1L - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cvvs_eval <- suppressWarnings(cv_varsel( cvvss[[tstsetup]], validate_search = FALSE, @@ -2252,8 +2206,8 @@ test_that(paste( next } nclusters_pred_crr <- args_cvvs[[tstsetup]]$nclusters_pred - 1L - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cv_meth_crr <- "LOO" cvvs_eval <- suppressWarnings(cv_varsel( @@ -2315,8 +2269,8 @@ test_that(paste( next } nclusters_pred_crr <- args_cvvs[[tstsetup]]$nclusters_pred - 1L - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cv_meth_crr <- "LOO" cvvs_eval <- suppressWarnings(cv_varsel( @@ -2369,8 +2323,8 @@ test_that(paste( } else { nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred } - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_eval <- try( suppressWarnings(cv_varsel( vss[[tstsetup]], nclusters_pred = nclusters_pred_crr, verbose = FALSE, @@ -2446,8 +2400,8 @@ test_that(paste( } else { nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred } - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_eval <- try( suppressWarnings(cv_varsel( vss[[tstsetup]], cv_method = "kfold", cvfits = cvfitss[[tstsetup_ref]], @@ -2512,8 +2466,8 @@ test_that(paste( next } nclusters_pred_crr <- args_cvvs[[tstsetup]]$nclusters_pred - 1L - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cvvs_eval <- try( suppressWarnings(cv_varsel( @@ -2614,8 +2568,8 @@ test_that(paste( next } nclusters_pred_crr <- args_cvvs[[tstsetup]]$nclusters_pred - 1L - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cvvs_eval <- try( suppressWarnings(cv_varsel( @@ -2688,8 +2642,8 @@ test_that("cv_varsel.vsel(): `nloo` works for `vsel` objects from varsel()", { refit_prj_crr <- FALSE nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred } - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: cvvs_eval_valF <- suppressWarnings(cv_varsel( vss[[tstsetup]], nloo = nloo_tst, validate_search = FALSE, refit_prj = refit_prj_crr, nclusters_pred = nclusters_pred_crr, @@ -2766,8 +2720,8 @@ test_that(paste( stopifnot(any(valsearches), any(!valsearches)) } for (tstsetup in tstsetups) { - # Use suppressWarnings() because of occasional warnings concerning Pareto k - # diagnostics: + # Use suppressWarnings() because test_that() somehow redirects stderr() and + # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cvvs_eval_valF <- suppressWarnings(cv_varsel( cvvss[[tstsetup]], cv_method = "LOO", validate_search = FALSE,