Fix code examples producing null models under glmnet 5.0

DESCRIPTION

@@ -36,4 +36,4 @@ Suggests:
     rmarkdown
 VignetteBuilder: knitr
 Encoding: UTF-8
-RoxygenNote: 7.3.3
+Config/roxygen2/version: 8.0.0

NAMESPACE

@@ -7,6 +7,7 @@ S3method(plot,hdnom.compare.validate)
 S3method(plot,hdnom.nomogram)
 S3method(plot,hdnom.validate)
 S3method(plot,hdnom.validate.external)
+S3method(plot,nomogram.raw)
 S3method(predict,hdnom.model)
 S3method(print,hdnom.calibrate)
 S3method(print,hdnom.calibrate.external)

R/1_1_model.R

@@ -30,9 +30,10 @@
 #'
 #' plot(nom)
 fit_lasso <- function(
-    x, y, nfolds = 5L,
-    rule = c("lambda.min", "lambda.1se"),
-    seed = 1001) {
+  x, y, nfolds = 5L,
+  rule = c("lambda.min", "lambda.1se"),
+  seed = 1001
+) {
   call <- match.call()
   rule <- match.arg(rule)
 
@@ -105,9 +106,10 @@ fit_lasso <- function(
 #'
 #' plot(nom)
 fit_alasso <- function(
-    x, y, nfolds = 5L,
-    rule = c("lambda.min", "lambda.1se"),
-    seed = c(1001, 1002)) {
+  x, y, nfolds = 5L,
+  rule = c("lambda.min", "lambda.1se"),
+  seed = c(1001, 1002)
+) {
   call <- match.call()
   rule <- match.arg(rule)
 
@@ -226,9 +228,10 @@ fit_alasso <- function(
 #'
 #' plot(nom)
 fit_enet <- function(
-    x, y, nfolds = 5L, alphas = seq(0.05, 0.95, 0.05),
-    rule = c("lambda.min", "lambda.1se"),
-    seed = 1001, parallel = FALSE) {
+  x, y, nfolds = 5L, alphas = seq(0.05, 0.95, 0.05),
+  rule = c("lambda.min", "lambda.1se"),
+  seed = 1001, parallel = FALSE
+) {
   call <- match.call()
   rule <- match.arg(rule)
 
@@ -325,10 +328,11 @@ fit_enet <- function(
 #'
 #' plot(nom)
 fit_aenet <- function(
-    x, y, nfolds = 5L, alphas = seq(0.05, 0.95, 0.05),
-    rule = c("lambda.min", "lambda.1se"),
-    seed = c(1001, 1002),
-    parallel = FALSE) {
+  x, y, nfolds = 5L, alphas = seq(0.05, 0.95, 0.05),
+  rule = c("lambda.min", "lambda.1se"),
+  seed = c(1001, 1002),
+  parallel = FALSE
+) {
   call <- match.call()
   rule <- match.arg(rule)
 
@@ -464,10 +468,11 @@ fit_aenet <- function(
 #' plot(nom)
 #' }
 fit_scad <- function(
-    x, y, nfolds = 5L,
-    gammas = c(2.01, 2.3, 3.7, 200),
-    eps = 1e-4, max.iter = 10000L,
-    seed = 1001, trace = FALSE, parallel = FALSE) {
+  x, y, nfolds = 5L,
+  gammas = c(2.01, 2.3, 3.7, 200),
+  eps = 1e-4, max.iter = 10000L,
+  seed = 1001, trace = FALSE, parallel = FALSE
+) {
   call <- match.call()
 
   scad_cv <- ncvreg_tune_gamma(
@@ -558,11 +563,12 @@ fit_scad <- function(
 #' plot(nom)
 #' }
 fit_snet <- function(
-    x, y, nfolds = 5L,
-    gammas = c(2.01, 2.3, 3.7, 200),
-    alphas = seq(0.05, 0.95, 0.05),
-    eps = 1e-4, max.iter = 10000L,
-    seed = 1001, trace = FALSE, parallel = FALSE) {
+  x, y, nfolds = 5L,
+  gammas = c(2.01, 2.3, 3.7, 200),
+  alphas = seq(0.05, 0.95, 0.05),
+  eps = 1e-4, max.iter = 10000L,
+  seed = 1001, trace = FALSE, parallel = FALSE
+) {
   call <- match.call()
 
   snet_cv <- ncvreg_tune_gamma_alpha(
@@ -653,9 +659,10 @@ fit_snet <- function(
 #' plot(nom)
 #' }
 fit_mcp <- function(
-    x, y, nfolds = 5L, gammas = c(1.01, 1.7, 3, 100),
-    eps = 1e-4, max.iter = 10000L,
-    seed = 1001, trace = FALSE, parallel = FALSE) {
+  x, y, nfolds = 5L, gammas = c(1.01, 1.7, 3, 100),
+  eps = 1e-4, max.iter = 10000L,
+  seed = 1001, trace = FALSE, parallel = FALSE
+) {
   call <- match.call()
 
   mcp_cv <- ncvreg_tune_gamma(
@@ -749,11 +756,12 @@ fit_mcp <- function(
 #' plot(nom)
 #' }
 fit_mnet <- function(
-    x, y, nfolds = 5L,
-    gammas = c(1.01, 1.7, 3, 100),
-    alphas = seq(0.05, 0.95, 0.05),
-    eps = 1e-4, max.iter = 10000L,
-    seed = 1001, trace = FALSE, parallel = FALSE) {
+  x, y, nfolds = 5L,
+  gammas = c(1.01, 1.7, 3, 100),
+  alphas = seq(0.05, 0.95, 0.05),
+  eps = 1e-4, max.iter = 10000L,
+  seed = 1001, trace = FALSE, parallel = FALSE
+) {
   call <- match.call()
 
   mnet_cv <- ncvreg_tune_gamma_alpha(
@@ -860,11 +868,12 @@ fit_mnet <- function(
 #'
 #' plot(nom)
 fit_flasso <- function(
-    x, y, nfolds = 5L,
-    lambda1 = c(0.001, 0.05, 0.5, 1, 5),
-    lambda2 = c(0.001, 0.01, 0.5),
-    maxiter = 25, epsilon = 1e-3,
-    seed = 1001, trace = FALSE, parallel = FALSE, ...) {
+  x, y, nfolds = 5L,
+  lambda1 = c(0.001, 0.05, 0.5, 1, 5),
+  lambda2 = c(0.001, 0.01, 0.5),
+  maxiter = 25, epsilon = 1e-3,
+  seed = 1001, trace = FALSE, parallel = FALSE, ...
+) {
   call <- match.call()
 
   if (trace) cat("Starting cross-validation...\n")

R/1_3_model_method.R

@@ -16,39 +16,33 @@
 #' event <- smart$EVENT
 #' y <- survival::Surv(time, event)
 #'
-#' fit <- fit_lasso(x, y, nfolds = 5, rule = "lambda.1se", seed = 11)
+#' fit <- fit_lasso(x, y, nfolds = 5, rule = "lambda.min", seed = 11)
 #' print(fit)
 print.hdnom.model <- function(x, ...) {
   model <- x$model
   model_type <- x$type
 
-  switch(
-
-    model_type,
-
+  switch(model_type,
     lasso = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
       cat("Model type: lasso\n")
       cat("Best lambda:", x$"lambda", "\n")
     },
-
     alasso = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
       cat("Model type: adaptive lasso\n")
       cat("First step best lambda:", x$"lambda_init", "\n")
       cat("Second step best lambda:", x$"lambda", "\n")
     },
-
     enet = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
       cat("Model type: elastic-net\n")
       cat("Best alpha:", x$"alpha", "\n")
       cat("Best lambda:", x$"lambda", "\n")
     },
-
     aenet = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
@@ -58,15 +52,13 @@ print.hdnom.model <- function(x, ...) {
       cat("Second step best alpha:", x$"alpha", "\n")
       cat("Second step best lambda:", x$"lambda", "\n")
     },
-
     mcp = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
       cat("Model type: MCP\n")
       cat("Best gamma:", x$"gamma", "\n")
       cat("Best lambda:", x$"lambda", "\n")
     },
-
     mnet = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
@@ -75,15 +67,13 @@ print.hdnom.model <- function(x, ...) {
       cat("Best alpha:", x$"alpha", "\n")
       cat("Best lambda:", x$"lambda", "\n")
     },
-
     scad = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
       cat("Model type: SCAD\n")
       cat("Best gamma:", x$"gamma", "\n")
       cat("Best lambda:", x$"lambda", "\n")
     },
-
     snet = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
@@ -92,7 +82,6 @@ print.hdnom.model <- function(x, ...) {
       cat("Best alpha:", x$"alpha", "\n")
       cat("Best lambda:", x$"lambda", "\n")
     },
-
     flasso = {
       cat("High-Dimensional Cox Model Object\n")
       cat("Random seed:", x$"seed", "\n")
@@ -135,7 +124,7 @@ print.hdnom.model <- function(x, ...) {
 #' event <- smart$EVENT
 #' y <- survival::Surv(time, event)
 #'
-#' fit <- fit_lasso(x, y, nfolds = 5, rule = "lambda.1se", seed = 11)
+#' fit <- fit_lasso(x, y, nfolds = 5, rule = "lambda.min", seed = 11)
 #' predict(fit, x, y, newx = x[101:105, ], pred.at = 1:10 * 365)
 predict.hdnom.model <- function(object, x, y, newx, pred.at, ...) {
   model <- object$model
@@ -146,24 +135,25 @@ predict.hdnom.model <- function(object, x, y, newx, pred.at, ...) {
   time <- y[, 1L]
   event <- y[, 2L]
 
-  obj_type <- switch(
-    model_type,
-    lasso = "glmnet", alasso = "glmnet", enet = "glmnet", aenet = "glmnet",
-    mcp = "ncvreg", mnet = "ncvreg", scad = "ncvreg", snet = "ncvreg",
+  obj_type <- switch(model_type,
+    lasso = "glmnet",
+    alasso = "glmnet",
+    enet = "glmnet",
+    aenet = "glmnet",
+    mcp = "ncvreg",
+    mnet = "ncvreg",
+    scad = "ncvreg",
+    snet = "ncvreg",
     flasso = "penalized"
   )
 
-  switch(
-
-    obj_type,
-
+  switch(obj_type,
     glmnet = {
       lp <- predict(model, x, type = "link")
       basesurv <- glmnet_basesurv(time, event, lp, pred.at)
       lpnew <- predict(model, newx, type = "link")
       p <- exp(exp(lpnew) %*% -t(basesurv$"cumulative_base_hazard"))
     },
-
     ncvreg = {
       lp <- predict(model, x, type = "link")
       basesurv <- ncvreg_basesurv(time, event, lp, pred.at)
@@ -177,7 +167,6 @@ predict.hdnom.model <- function(object, x, y, newx, pred.at, ...) {
       # p = matrix(NA, nrow = nrow(newx), ncol = length(pred.at))
       # for (i in 1L:nrow(newx)) p[i, ] = sapply(pred.at, survfun[[i]])
     },
-
     penalized = {
       pred <- predict(model, newx)
       p <- matrix(NA, nrow = nrow(newx), ncol = length(pred.at))
@@ -215,27 +204,27 @@ infer_variable_type <- function(object, x) {
   model <- object$model
   model_type <- object$type
 
-  obj_type <- switch(
-    model_type,
-    lasso = "glmnet", alasso = "glmnet", enet = "glmnet", aenet = "glmnet",
-    mcp = "ncvreg", mnet = "ncvreg", scad = "ncvreg", snet = "ncvreg",
+  obj_type <- switch(model_type,
+    lasso = "glmnet",
+    alasso = "glmnet",
+    enet = "glmnet",
+    aenet = "glmnet",
+    mcp = "ncvreg",
+    mnet = "ncvreg",
+    scad = "ncvreg",
+    snet = "ncvreg",
     flasso = "penalized"
   )
 
-  switch(
-
-    obj_type,
-
+  switch(obj_type,
     glmnet = {
       nonzero_idx <- which(as.logical(abs(model$beta) > .Machine$double.eps))
       nonzero_var <- rownames(model$beta)[nonzero_idx]
     },
-
     ncvreg = {
       nonzero_idx <- which(model$beta[-1L, ] > .Machine$double.eps)
       nonzero_var <- names(model$beta[-1L, ])[nonzero_idx]
     },
-
     penalized = {
       nonzero_idx <- which(model@"penalized" > .Machine$double.eps)
       nonzero_var <- colnames(x)[nonzero_idx]

R/2_1_nomogram.R

@@ -29,7 +29,8 @@
 #' fit <- fit_lasso(x, y, nfolds = 5, rule = "lambda.1se", seed = 1001)
 #'
 #' nom <- as_nomogram(
-#'   fit, x, time, event, pred.at = 365 * 2,
+#'   fit, x, time, event,
+#'   pred.at = 365 * 2,
 #'   funlabel = "2-Year Overall Survival Probability"
 #' )
 #'

R/2_3_survial_curves.R

@@ -52,8 +52,9 @@ glmnet_survcurve <- function(object, time, event, x, survtime) {
 #' @examples
 #' NULL
 glmnet_basesurv <- function(
-    time, event, lp,
-    times.eval = NULL, centered = FALSE) {
+  time, event, lp,
+  times.eval = NULL, centered = FALSE
+) {
   if (is.null(times.eval)) times.eval <- sort(unique(time))
 
   t.unique <- sort(unique(time[event == 1L]))
@@ -125,8 +126,9 @@ ncvreg_survcurve <- function(object, time, event, x, survtime) {
 #' @examples
 #' NULL
 ncvreg_basesurv <- function(
-    time, event, lp,
-    times.eval = NULL, centered = FALSE) {
+  time, event, lp,
+  times.eval = NULL, centered = FALSE
+) {
   if (is.null(times.eval)) times.eval <- sort(unique(time))
 
   t.unique <- sort(unique(time[event == 1L]))
@@ -198,8 +200,9 @@ penalized_survcurve <- function(object, time, event, x, survtime) {
 #' @examples
 #' NULL
 penalized_basesurv <- function(
-    time, event, lp,
-    times.eval = NULL, centered = FALSE) {
+  time, event, lp,
+  times.eval = NULL, centered = FALSE
+) {
   if (is.null(times.eval)) times.eval <- sort(unique(time))
 
   t.unique <- sort(unique(time[event == 1L]))