R/utils.R

In l0ara: Sparse Generalized Linear Model with L0 Approximation for Feature Selection

.l0ara_as_matrix <- function(x) {
  if (is.matrix(x)) {
    return(x)
  }

  x_matrix <- try(model.matrix(~0 + ., data = x), silent = TRUE)
  if (inherits(x_matrix, "try-error")) {
    stop("x must be a matrix or able to be coerced to a matrix", call. = FALSE)
  }

  x_matrix
}

.l0ara_as_numeric <- function(y) {
  if (is.numeric(y)) {
    return(drop(y))
  }

  y_numeric <- try(as.numeric(y), silent = TRUE)
  if (inherits(y_numeric, "try-error")) {
    stop("y must numeric or able to be coerced to numeric", call. = FALSE)
  }

  drop(y_numeric)
}

.l0ara_family_response <- function(eta, family) {
  switch(
    family,
    gaussian = eta,
    logit = plogis(eta),
    poisson = exp(eta),
    gamma = 1 / eta,
    inv.gaussian = 1 / sqrt(eta)
  )
}

.l0ara_family_label <- function(family) {
  switch(
    family,
    gaussian = "Linear regression",
    logit = "Logistic regression",
    poisson = "Poisson regression",
    inv.gaussian = "Inverse gaussian regression",
    gamma = "Gamma regression"
  )
}

.l0ara_measure_label <- function(measure) {
  switch(
    measure,
    mse = "Mean square error",
    mae = "Mean absolute error",
    class = "Misclassification rate",
    auc = "Area under the curve"
  )
}

.l0ara_lambda_value <- function(object) {
  if (!is.null(object$lam)) {
    return(object$lam)
  }

  object$lambda
}

.l0ara_coef_names <- function(object) {
  beta <- object$beta
  n_beta <- length(beta)
  coef_names <- character(n_beta)

  if (n_beta > 0L) {
    coef_names[1L] <- "Intercept"
  }
  if (n_beta > 1L) {
    coef_names[2L:n_beta] <- paste0("X", seq_len(n_beta - 1L))
  }

  coef_names
}

.l0ara_linear_predictor <- function(beta, newx) {
  drop(newx %*% beta)
}

.l0ara_fit_raw <- function(x, y, family, lam, maxit, eps, standardize = TRUE) {
  if (standardize) {
    xx <- scale(x)
  } else {
    xx <- x
  }

  out <- l0araC(xx, y, family, lam, maxit, eps)
  beta <- drop(out$beta)

  list(
    beta = beta,
    df = sum(beta != 0),
    lam = lam,
    lambda = lam,
    iter = out$iter,
    family = family,
    x = x,
    y = y
  )
}

.l0ara_fit_beta <- function(x, y, family, lam, maxit, eps, standardize = TRUE) {
  if (standardize) {
    xx <- scale(x)
  } else {
    xx <- x
  }

  out <- l0araC(xx, y, family, lam, maxit, eps)
  beta <- out$beta
  drop(beta)
}