enpy.R 2.2 KB
Newer Older
davidkep's avatar
davidkep committed
1 2
#' ENPY Initial Estimates
#'
davidkep's avatar
davidkep committed
3 4 5 6 7 8 9 10 11 12 13 14 15
#' @param x `n` by `p` matrix of numeric predictors.
#' @param y vector of response values of length `n`.
#' @param alpha value for the alpha parameter, the balance between L1 and L2
#'              penalization.
#' @param lambdas a vector of positive values for the lambda parameter.
#' @param penalty_loadings a vector of positive penalty loadings
#'                         (a.k.a. weights) for different penalization of each coefficient.
#' @param include_intercept include an intercept in the model.
#' @param bdp the desired breakdown point of the estimator, between 0 and 0.5.
#' @param cc consistency constant for the scale estimate. By default, the scale estimate is made consistent for the
#'                       given breakdown point under the Normal model.
#' @param en_algorithm_opts options for the EN algorithm. See [en_algorithm_options] for details.
#' @param mscale_opts options for the M-scale estimation. See [mscale_algorithm_options] for details.
davidkep's avatar
davidkep committed
16
#' @export
17
enpy_initial_estimates <- function (x, y, alpha, lambdas, bdp = 0.25, cc, include_intercept = TRUE,
davidkep's avatar
davidkep committed
18 19
                                    enpy_opts = enpy_options(), mscale_opts = mscale_algorithm_options()) {
  alpha <- .as(alpha[[1L]], 'numeric')
davidkep's avatar
davidkep committed
20
  if (missing(cc)) {
davidkep's avatar
davidkep committed
21
    cc <- NULL
davidkep's avatar
davidkep committed
22 23
  }

davidkep's avatar
davidkep committed
24 25
  if (alpha < 0 || alpha > 1) {
    stop("`alpha` is outside 0 and 1.")
davidkep's avatar
davidkep committed
26

davidkep's avatar
davidkep committed
27
  }
davidkep's avatar
davidkep committed
28 29 30 31
  if (alpha < sqrt(.Machine$double.eps)) {
    alpha <- 0
  }

davidkep's avatar
davidkep committed
32
  penalties <- make_penalties(alpha, lambdas)
davidkep's avatar
davidkep committed
33 34
  s_loss_params <- list(mscale = .full_mscale_algo_options(bdp = bdp, cc = cc, mscale_opts = mscale_opts),
                        intercept = include_intercept)
davidkep's avatar
davidkep committed
35

davidkep's avatar
davidkep committed
36 37
  # Check EN algorithm for ENPY
  enpy_opts$en_options <- .select_en_algorithm(enpy_opts$en_options, alpha, x)
davidkep's avatar
davidkep committed
38

davidkep's avatar
davidkep committed
39
  res <- .Call(C_penpy, x, drop(y), penalties, s_loss_params, enpy_opts, list())
davidkep's avatar
davidkep committed
40 41 42 43 44 45 46

  lapply(res, function (res) {
    if (!is.null(res$metrics)) {
      class(res$metrics) <- 'nsoptim_metrics'
    }
    return(res)
  })
davidkep's avatar
davidkep committed
47 48
}

davidkep's avatar
davidkep committed
49 50
## Make a list of penalties and ensure that `alpha` and `lambdas` are of
## correct type and order.
davidkep's avatar
davidkep committed
51 52 53 54 55
make_penalties <- function (alpha, lambdas) {
  lapply(sort(as.numeric(lambdas), decreasing = TRUE), function (lambda) {
    list(alpha = alpha, lambda = lambda)
  })
}