From 0a9a4d695b35a5d603f56059eb0961bc16407051 Mon Sep 17 00:00:00 2001 From: Nan Xiao Date: Sun, 10 May 2026 12:41:29 -0700 Subject: [PATCH 1/2] Change rule in examples to `lambda.min` to be robust to glmnet path changes --- R/1_3_model_method.R | 57 +++++++++++++++----------------------- R/3_1_validate.R | 25 +++++++++-------- man/predict.hdnom.model.Rd | 2 +- man/print.hdnom.model.Rd | 2 +- man/validate.Rd | 2 +- 5 files changed, 39 insertions(+), 49 deletions(-) diff --git a/R/1_3_model_method.R b/R/1_3_model_method.R index 2131466..011ec20 100644 --- a/R/1_3_model_method.R +++ b/R/1_3_model_method.R @@ -16,23 +16,19 @@ #' 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") @@ -40,7 +36,6 @@ print.hdnom.model <- function(x, ...) { 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") @@ -48,7 +43,6 @@ print.hdnom.model <- function(x, ...) { 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,7 +52,6 @@ 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") @@ -66,7 +59,6 @@ print.hdnom.model <- function(x, ...) { 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,7 +67,6 @@ 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") @@ -83,7 +74,6 @@ print.hdnom.model <- function(x, ...) { 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] diff --git a/R/3_1_validate.R b/R/3_1_validate.R index 84d4546..44adc80 100644 --- a/R/3_1_validate.R +++ b/R/3_1_validate.R @@ -67,7 +67,7 @@ #' event <- smart$EVENT[1:500] #' 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) #' #' # Model validation by bootstrap with time-dependent AUC #' # Normally boot.times should be set to 200 or more, @@ -158,17 +158,18 @@ #' # summary(val.repcv) #' # plot(val.repcv) validate <- function( - x, time, event, - model.type = c( - "lasso", "alasso", "flasso", "enet", "aenet", - "mcp", "mnet", "scad", "snet" - ), - alpha, lambda, pen.factor = NULL, gamma, - lambda1, lambda2, - method = c("bootstrap", "cv", "repeated.cv"), - boot.times = NULL, nfolds = NULL, rep.times = NULL, - tauc.type = c("CD", "SZ", "UNO"), tauc.time, - seed = 1001, trace = TRUE) { + x, time, event, + model.type = c( + "lasso", "alasso", "flasso", "enet", "aenet", + "mcp", "mnet", "scad", "snet" + ), + alpha, lambda, pen.factor = NULL, gamma, + lambda1, lambda2, + method = c("bootstrap", "cv", "repeated.cv"), + boot.times = NULL, nfolds = NULL, rep.times = NULL, + tauc.type = c("CD", "SZ", "UNO"), tauc.time, + seed = 1001, trace = TRUE +) { model.type <- match.arg(model.type) method <- match.arg(method) tauc.type <- match.arg(tauc.type) diff --git a/man/predict.hdnom.model.Rd b/man/predict.hdnom.model.Rd index ff44853..f9ac1c9 100644 --- a/man/predict.hdnom.model.Rd +++ b/man/predict.hdnom.model.Rd @@ -35,6 +35,6 @@ time <- smart$TEVENT 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) } diff --git a/man/print.hdnom.model.Rd b/man/print.hdnom.model.Rd index fa6f93b..d33841f 100644 --- a/man/print.hdnom.model.Rd +++ b/man/print.hdnom.model.Rd @@ -21,6 +21,6 @@ time <- smart$TEVENT 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) } diff --git a/man/validate.Rd b/man/validate.Rd index d2e7285..0dc7c81 100644 --- a/man/validate.Rd +++ b/man/validate.Rd @@ -94,7 +94,7 @@ time <- smart$TEVENT[1:500] event <- smart$EVENT[1:500] 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) # Model validation by bootstrap with time-dependent AUC # Normally boot.times should be set to 200 or more, From 1ce4712c7db8c47d156ad29b5520399500eac5fc Mon Sep 17 00:00:00 2001 From: Nan Xiao Date: Sun, 10 May 2026 12:42:06 -0700 Subject: [PATCH 2/2] Fix roxygen2 8.0.0 errors and run styler --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/1_1_model.R | 79 +++++---- R/2_1_nomogram.R | 3 +- R/2_3_survial_curves.R | 15 +- R/3_2_validate_utils.R | 21 +-- R/3_3_validate_method.R | 7 +- R/3_4_validate_external.R | 7 +- R/3_5_validate_external_utils.R | 15 +- R/3_6_validate_external_method.R | 7 +- R/4_1_calibrate.R | 23 +-- R/4_2_calibrate_utils.R | 30 ++-- R/4_3_calibrate_method.R | 7 +- R/4_4_calibrate_external.R | 7 +- R/4_5_calibrate_external_utils.R | 7 +- R/4_6_calibrate_external_method.R | 7 +- R/4_7_kmplot.R | 16 +- R/5_1_compare_by_validate.R | 21 +-- R/5_2_compare_by_validate_method.R | 11 +- R/5_3_compare_by_calibrate.R | 21 +-- R/5_4_compare_by_calibrate_method.R | 9 +- R/rms_nomogram.R | 132 ++++++++------- R/rms_nomogram_method.R | 53 +++--- R/rms_nomogram_misc.R | 240 ++++++++++++++-------------- man/as_nomogram.Rd | 3 +- man/hdnom-package.Rd | 1 + 26 files changed, 406 insertions(+), 339 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index de32a10..9298e17 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,4 +36,4 @@ Suggests: rmarkdown VignetteBuilder: knitr Encoding: UTF-8 -RoxygenNote: 7.3.3 +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 0961fd9..c0c1fcc 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/1_1_model.R b/R/1_1_model.R index 32fd8f6..5200d29 100644 --- a/R/1_1_model.R +++ b/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") diff --git a/R/2_1_nomogram.R b/R/2_1_nomogram.R index a40b3eb..87ba392 100755 --- a/R/2_1_nomogram.R +++ b/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" #' ) #' diff --git a/R/2_3_survial_curves.R b/R/2_3_survial_curves.R index 4bc7ed8..a93c71d 100644 --- a/R/2_3_survial_curves.R +++ b/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])) diff --git a/R/3_2_validate_utils.R b/R/3_2_validate_utils.R index 967abf0..1cdb640 100644 --- a/R/3_2_validate_utils.R +++ b/R/3_2_validate_utils.R @@ -7,9 +7,10 @@ #' #' @keywords internal glmnet_validate_tauc <- function( - x_tr, x_te, y_tr, y_te, - alpha, lambda, pen.factor, - tauc.type, tauc.time) { + x_tr, x_te, y_tr, y_te, + alpha, lambda, pen.factor, + tauc.type, tauc.time +) { if (is.null(pen.factor)) { samp_fit <- glmnet( x = x_tr, y = y_tr, family = "cox", @@ -62,9 +63,10 @@ glmnet_validate_tauc <- function( #' #' @keywords internal ncvreg_validate_tauc <- function( - x_tr, x_te, y_tr, y_te, model.type, - gamma, alpha, lambda, - tauc.type, tauc.time) { + x_tr, x_te, y_tr, y_te, model.type, + gamma, alpha, lambda, + tauc.type, tauc.time +) { if (model.type == "mcp") { samp_fit <- ncvreg::ncvsurv( X = x_tr, y = y_tr, @@ -136,9 +138,10 @@ ncvreg_validate_tauc <- function( #' #' @keywords internal penalized_validate_tauc <- function( - x_tr, x_te, y_tr, y_te, - lambda1, lambda2, - tauc.type, tauc.time) { + x_tr, x_te, y_tr, y_te, + lambda1, lambda2, + tauc.type, tauc.time +) { samp_fit <- penalized( response = y_tr, penalized = x_tr, lambda1 = lambda1, lambda2 = lambda2, diff --git a/R/3_3_validate_method.R b/R/3_3_validate_method.R index b4fbf5b..bb488e6 100644 --- a/R/3_3_validate_method.R +++ b/R/3_3_validate_method.R @@ -240,13 +240,14 @@ summary.hdnom.validate <- function(object, silent = FALSE, ...) { #' @export #' #' @importFrom ggplot2 ggplot aes_string geom_point geom_line geom_point -#' geom_ribbon scale_x_continuous scale_fill_manual scale_colour_manual -#' theme ylab coord_cartesian +#' @importFrom ggplot2 geom_ribbon scale_x_continuous scale_fill_manual +#' @importFrom ggplot2 scale_colour_manual theme ylab coord_cartesian #' #' @examples #' NULL plot.hdnom.validate <- function( - x, col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ylim = NULL, ...) { + x, col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ylim = NULL, ... +) { df <- as.data.frame(t(summary(x, silent = TRUE))) tauc_time <- attr(x, "tauc.time") diff --git a/R/3_4_validate_external.R b/R/3_4_validate_external.R index 2f13f3f..a6242be 100644 --- a/R/3_4_validate_external.R +++ b/R/3_4_validate_external.R @@ -120,9 +120,10 @@ #' # summary(val.ext3) #' # plot(val.ext3) validate_external <- function( - object, x, time, event, - x_new, time_new, event_new, - tauc.type = c("CD", "SZ", "UNO"), tauc.time) { + object, x, time, event, + x_new, time_new, event_new, + tauc.type = c("CD", "SZ", "UNO"), tauc.time +) { if (!("hdnom.model" %in% class(object))) { stop('object must be of class "hdnom.model"') } diff --git a/R/3_5_validate_external_utils.R b/R/3_5_validate_external_utils.R index e4a9455..bdbdf79 100644 --- a/R/3_5_validate_external_utils.R +++ b/R/3_5_validate_external_utils.R @@ -7,8 +7,9 @@ #' #' @keywords internal glmnet_validate_external_tauc <- function( - object, x_tr, x_te, y_tr, y_te, - tauc.type, tauc.time) { + object, x_tr, x_te, y_tr, y_te, + tauc.type, tauc.time +) { lp_tr <- as.vector(predict(object, newx = x_tr, type = "link")) lp_te <- as.vector(predict(object, newx = x_te, type = "link")) @@ -47,8 +48,9 @@ glmnet_validate_external_tauc <- function( #' #' @keywords internal ncvreg_validate_external_tauc <- function( - object, x_tr, x_te, y_tr, y_te, - tauc.type, tauc.time) { + object, x_tr, x_te, y_tr, y_te, + tauc.type, tauc.time +) { lp_tr <- as.vector(predict(object, X = x_tr, type = "link")) lp_te <- as.vector(predict(object, X = x_te, type = "link")) @@ -88,8 +90,9 @@ ncvreg_validate_external_tauc <- function( #' #' @keywords internal penalized_validate_external_tauc <- function( - object, x_tr, x_te, y_tr, y_te, - tauc.type, tauc.time) { + object, x_tr, x_te, y_tr, y_te, + tauc.type, tauc.time +) { lp_tr <- as.vector(object@"lin.pred") lp_te <- as.vector(x_te %*% as.matrix(object@"penalized")) diff --git a/R/3_6_validate_external_method.R b/R/3_6_validate_external_method.R index cab447b..84ea1f8 100644 --- a/R/3_6_validate_external_method.R +++ b/R/3_6_validate_external_method.R @@ -82,13 +82,14 @@ summary.hdnom.validate.external <- function(object, silent = FALSE, ...) { #' @export #' #' @importFrom ggplot2 ggplot aes_string geom_point geom_line geom_point -#' geom_ribbon scale_x_continuous scale_fill_manual scale_colour_manual -#' theme ylab coord_cartesian +#' @importFrom ggplot2 geom_ribbon scale_x_continuous scale_fill_manual +#' @importFrom ggplot2 scale_colour_manual theme ylab coord_cartesian #' #' @examples #' NULL plot.hdnom.validate.external <- function( - x, col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ylim = NULL, ...) { + x, col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ylim = NULL, ... +) { df <- as.data.frame(t(summary(x, silent = TRUE))) tauc_time <- attr(x, "tauc.time") diff --git a/R/4_1_calibrate.R b/R/4_1_calibrate.R index 96e7a01..294f109 100644 --- a/R/4_1_calibrate.R +++ b/R/4_1_calibrate.R @@ -135,17 +135,18 @@ #' # summary(cal.repcv) #' # plot(cal.repcv) calibrate <- function( - x, time, event, - model.type = c( - "lasso", "alasso", "flasso", "enet", "aenet", - "mcp", "mnet", "scad", "snet" - ), - alpha, lambda, pen.factor = NULL, gamma, - lambda1, lambda2, - method = c("fitting", "bootstrap", "cv", "repeated.cv"), - boot.times = NULL, nfolds = NULL, rep.times = NULL, - pred.at, ngroup = 5, - seed = 1001, trace = TRUE) { + x, time, event, + model.type = c( + "lasso", "alasso", "flasso", "enet", "aenet", + "mcp", "mnet", "scad", "snet" + ), + alpha, lambda, pen.factor = NULL, gamma, + lambda1, lambda2, + method = c("fitting", "bootstrap", "cv", "repeated.cv"), + boot.times = NULL, nfolds = NULL, rep.times = NULL, + pred.at, ngroup = 5, + seed = 1001, trace = TRUE +) { model.type <- match.arg(model.type) method <- match.arg(method) if (length(pred.at) != 1L) stop("pred.at should only contain 1 time point") diff --git a/R/4_2_calibrate_utils.R b/R/4_2_calibrate_utils.R index 01522cc..c8847a9 100644 --- a/R/4_2_calibrate_utils.R +++ b/R/4_2_calibrate_utils.R @@ -7,9 +7,10 @@ #' #' @keywords internal glmnet_calibrate_surv_prob_pred <- function( - x_tr, x_te, y_tr, - alpha, lambda, pen.factor, - pred.at) { + x_tr, x_te, y_tr, + alpha, lambda, pen.factor, + pred.at +) { if (is.null(pen.factor)) { object <- glmnet( x = x_tr, y = y_tr, family = "cox", @@ -61,10 +62,11 @@ glmnet_calibrate_surv_prob_pred <- function( #' #' @keywords internal ncvreg_calibrate_surv_prob_pred <- function( - x_tr, x_te, y_tr, - model.type, - alpha, lambda, gamma, - pred.at) { + x_tr, x_te, y_tr, + model.type, + alpha, lambda, gamma, + pred.at +) { if (model.type == "mcp") { object <- ncvreg::ncvsurv( X = x_tr, y = y_tr, @@ -131,9 +133,10 @@ ncvreg_calibrate_surv_prob_pred <- function( #' #' @keywords internal penalized_calibrate_surv_prob_pred <- function( - x_tr, x_te, y_tr, - lambda1, lambda2, - pred.at) { + x_tr, x_te, y_tr, + lambda1, lambda2, + pred.at +) { object <- penalized( response = y_tr, penalized = x_tr, lambda1 = lambda1, lambda2 = lambda2, @@ -175,9 +178,10 @@ penalized_calibrate_surv_prob_pred <- function( #' #' @keywords internal calibrate_surv_prob_true <- function( - pred_prob, grp, - time, event, - pred.at, ngroup) { + pred_prob, grp, + time, event, + pred.at, ngroup +) { true_prob <- matrix(NA, ncol = 3L, nrow = ngroup) colnames(true_prob) <- c("Observed", "Lower 95%", "Upper 95%") diff --git a/R/4_3_calibrate_method.R b/R/4_3_calibrate_method.R index 9613941..f6e1998 100644 --- a/R/4_3_calibrate_method.R +++ b/R/4_3_calibrate_method.R @@ -297,13 +297,14 @@ summary.hdnom.calibrate <- function(object, ...) { #' @export #' #' @importFrom ggplot2 ggplot aes_string geom_errorbar -#' geom_line geom_point geom_abline xlab ylab +#' @importFrom ggplot2 geom_line geom_point geom_abline xlab ylab #' #' @examples #' NULL plot.hdnom.calibrate <- function( - x, xlim = c(0, 1), ylim = c(0, 1), - col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ...) { + x, xlim = c(0, 1), ylim = c(0, 1), + col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ... +) { df <- data.frame( "pre" = x[, "Predicted"], "obs" = x[, "Observed"], "ll" = x[, "Lower 95%"], "ul" = x[, "Upper 95%"] diff --git a/R/4_4_calibrate_external.R b/R/4_4_calibrate_external.R index e53dad9..380a951 100644 --- a/R/4_4_calibrate_external.R +++ b/R/4_4_calibrate_external.R @@ -102,9 +102,10 @@ #' # summary(cal.ext3) #' # plot(cal.ext3) calibrate_external <- function( - object, x, time, event, - x_new, time_new, event_new, - pred.at, ngroup = 5) { + object, x, time, event, + x_new, time_new, event_new, + pred.at, ngroup = 5 +) { if (!("hdnom.model" %in% class(object))) { stop('object must be of class "hdnom.model"') } diff --git a/R/4_5_calibrate_external_utils.R b/R/4_5_calibrate_external_utils.R index 6b82466..2c7c642 100644 --- a/R/4_5_calibrate_external_utils.R +++ b/R/4_5_calibrate_external_utils.R @@ -108,9 +108,10 @@ penalized_calibrate_external_surv_prob_pred <- function(object, x_tr, x_te, y_tr #' #' @keywords internal calibrate_external_surv_prob_true <- function( - pred_prob, grp, - time_new, event_new, - pred.at, ngroup) { + pred_prob, grp, + time_new, event_new, + pred.at, ngroup +) { true_prob <- matrix(NA, ncol = 3L, nrow = ngroup) colnames(true_prob) <- c("Observed", "Lower 95%", "Upper 95%") diff --git a/R/4_6_calibrate_external_method.R b/R/4_6_calibrate_external_method.R index be071fc..27be7fa 100644 --- a/R/4_6_calibrate_external_method.R +++ b/R/4_6_calibrate_external_method.R @@ -71,13 +71,14 @@ summary.hdnom.calibrate.external <- function(object, ...) { #' @export #' #' @importFrom ggplot2 ggplot aes_string geom_errorbar -#' geom_line geom_point geom_abline xlab ylab +#' @importFrom ggplot2 geom_line geom_point geom_abline xlab ylab #' #' @examples #' NULL plot.hdnom.calibrate.external <- function( - x, xlim = c(0, 1), ylim = c(0, 1), - col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ...) { + x, xlim = c(0, 1), ylim = c(0, 1), + col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ... +) { df <- data.frame( "pre" = x[, "Predicted"], "obs" = x[, "Observed"], "ll" = x[, "Lower 95%"], "ul" = x[, "Upper 95%"] diff --git a/R/4_7_kmplot.R b/R/4_7_kmplot.R index 3b7ca60..6d821da 100644 --- a/R/4_7_kmplot.R +++ b/R/4_7_kmplot.R @@ -64,8 +64,9 @@ #' time.at = 1:6 * 365 #' ) kmplot <- function( - object, group.name = NULL, time.at = NULL, - col.pal = c("JCO", "Lancet", "NPG", "AAAS")) { + object, group.name = NULL, time.at = NULL, + col.pal = c("JCO", "Lancet", "NPG", "AAAS") +) { if (!(any(c("hdnom.calibrate", "hdnom.calibrate.external") %in% class(object)))) { stop('object class must be "hdnom.calibrate" or "hdnom.calibrate.external"') } @@ -94,14 +95,15 @@ kmplot <- function( #' @importFrom stats pchisq #' @importFrom survival survdiff #' @importFrom gridExtra grid.arrange arrangeGrob -#' @importFrom ggplot2 geom_step geom_blank geom_text element_blank -#' element_line element_text element_rect scale_colour_manual -#' scale_y_discrete unit annotate theme_bw +#' @importFrom ggplot2 geom_step geom_blank geom_text element_blank element_line +#' @importFrom ggplot2 element_text element_rect scale_colour_manual +#' @importFrom ggplot2 scale_y_discrete unit annotate theme_bw #' #' @keywords internal kmplot_raw <- function( - fit, group.name = NULL, time.at = NULL, - surv.df = NULL, col.pal = NULL) { + fit, group.name = NULL, time.at = NULL, + surv.df = NULL, col.pal = NULL +) { if (is.null(group.name)) { group.name <- paste("Group", gsub("grp=", "", levels(summary(fit)$"strata"))) } diff --git a/R/5_1_compare_by_validate.R b/R/5_1_compare_by_validate.R index b25c5e0..3022dba 100644 --- a/R/5_1_compare_by_validate.R +++ b/R/5_1_compare_by_validate.R @@ -67,16 +67,17 @@ #' plot(cmp.val.cv) #' plot(cmp.val.cv, interval = TRUE) compare_by_validate <- function( - x, time, event, - model.type = c( - "lasso", "alasso", "flasso", "enet", "aenet", - "mcp", "mnet", "scad", "snet" - ), - method = c("bootstrap", "cv", "repeated.cv"), - boot.times = NULL, nfolds = NULL, rep.times = NULL, - tauc.type = c("CD", "SZ", "UNO"), tauc.time, - rule = c("lambda.min", "lambda.1se"), - seed = 1001, trace = TRUE) { + x, time, event, + model.type = c( + "lasso", "alasso", "flasso", "enet", "aenet", + "mcp", "mnet", "scad", "snet" + ), + method = c("bootstrap", "cv", "repeated.cv"), + boot.times = NULL, nfolds = NULL, rep.times = NULL, + tauc.type = c("CD", "SZ", "UNO"), tauc.time, + rule = c("lambda.min", "lambda.1se"), + seed = 1001, trace = TRUE +) { method <- match.arg(method) tauc.type <- match.arg(tauc.type) rule <- match.arg(rule) diff --git a/R/5_2_compare_by_validate_method.R b/R/5_2_compare_by_validate_method.R index a72a387..e0252cc 100644 --- a/R/5_2_compare_by_validate_method.R +++ b/R/5_2_compare_by_validate_method.R @@ -58,17 +58,18 @@ summary.hdnom.compare.validate <- function(object, silent = FALSE, ...) { #' #' @method plot hdnom.compare.validate #' -#' @importFrom ggplot2 ggplot aes_string geom_point geom_line -#' scale_x_continuous scale_colour_manual ylab coord_cartesian +#' @importFrom ggplot2 ggplot aes_string geom_point geom_line scale_x_continuous +#' @importFrom ggplot2 scale_colour_manual ylab coord_cartesian #' #' @export #' #' @examples #' NULL plot.hdnom.compare.validate <- function( - x, interval = FALSE, - col.pal = c("JCO", "Lancet", "NPG", "AAAS"), - ylim = NULL, ...) { + x, interval = FALSE, + col.pal = c("JCO", "Lancet", "NPG", "AAAS"), + ylim = NULL, ... +) { n <- length(x) dflist <- vector("list", n) diff --git a/R/5_3_compare_by_calibrate.R b/R/5_3_compare_by_calibrate.R index f2fb180..dac07e2 100644 --- a/R/5_3_compare_by_calibrate.R +++ b/R/5_3_compare_by_calibrate.R @@ -46,16 +46,17 @@ #' summary(cmp.cal.cv) #' plot(cmp.cal.cv) compare_by_calibrate <- function( - x, time, event, - model.type = c( - "lasso", "alasso", "flasso", "enet", "aenet", - "mcp", "mnet", "scad", "snet" - ), - method = c("fitting", "bootstrap", "cv", "repeated.cv"), - boot.times = NULL, nfolds = NULL, rep.times = NULL, - pred.at, ngroup = 5, - rule = c("lambda.min", "lambda.1se"), - seed = 1001, trace = TRUE) { + x, time, event, + model.type = c( + "lasso", "alasso", "flasso", "enet", "aenet", + "mcp", "mnet", "scad", "snet" + ), + method = c("fitting", "bootstrap", "cv", "repeated.cv"), + boot.times = NULL, nfolds = NULL, rep.times = NULL, + pred.at, ngroup = 5, + rule = c("lambda.min", "lambda.1se"), + seed = 1001, trace = TRUE +) { method <- match.arg(method) rule <- match.arg(rule) diff --git a/R/5_4_compare_by_calibrate_method.R b/R/5_4_compare_by_calibrate_method.R index bf56ea8..a6ba782 100644 --- a/R/5_4_compare_by_calibrate_method.R +++ b/R/5_4_compare_by_calibrate_method.R @@ -58,14 +58,15 @@ summary.hdnom.compare.calibrate <- function(object, ...) { #' @export #' #' @importFrom ggplot2 ggplot aes_string geom_errorbar -#' geom_line geom_point geom_abline scale_colour_manual -#' xlab ylab +#' @importFrom ggplot2 geom_line geom_point geom_abline scale_colour_manual +#' @importFrom ggplot2 xlab ylab #' #' @examples #' NULL plot.hdnom.compare.calibrate <- function( - x, xlim = c(0, 1), ylim = c(0, 1), - col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ...) { + x, xlim = c(0, 1), ylim = c(0, 1), + col.pal = c("JCO", "Lancet", "NPG", "AAAS"), ... +) { n <- length(x) dflist <- vector("list", n) diff --git a/R/rms_nomogram.R b/R/rms_nomogram.R index 4e68811..32cb284 100755 --- a/R/rms_nomogram.R +++ b/R/rms_nomogram.R @@ -15,7 +15,8 @@ as_nomogram_raw <- function( est.all = TRUE, abbrev = FALSE, minlength = 4, maxscale = 100, nint = 10, vnames = c("labels", "names"), varname.label = TRUE, varname.label.sep = "=", - omit = NULL, verbose = FALSE) { + omit = NULL, verbose = FALSE +) { conf.lp <- match.arg(conf.lp) vnames <- match.arg(vnames) @@ -88,8 +89,9 @@ as_nomogram_raw <- function( # Keep character variables intact lims <- unclass(lims) - for (i in 1:length(lims)) + for (i in 1:length(lims)) { if (is.factor(lims[[i]])) lims[[i]] <- as.character(lims[[i]]) + } attr(lims, "class") <- "data.frame" # so can subscript later # Find underlying categorical variables @@ -111,8 +113,7 @@ as_nomogram_raw <- function( Intercept <- if (nrp > 0) { fit$coefficients[kint] - } else - if (length(fit$center)) (-fit$center) else 0 + } else if (length(fit$center)) (-fit$center) else 0 intercept.offset <- fit$coefficients[kint] - fit$coefficients[ir] settings <- list() @@ -122,10 +123,9 @@ as_nomogram_raw <- function( lz <- length(z) if (lz < 2) { settings[[ni]] <- check_values(at, i, NA, -nint, Limval, type.range = "full") - } else - if (lz > 0 && any(is.na(z))) { - stop("may not specify NA as a variable value") - } + } else if (lz > 0 && any(is.na(z))) { + stop("may not specify NA as a variable value") + } if (lz == 1) { lims[2, i] <- z } else if (lz > 1) { @@ -133,9 +133,9 @@ as_nomogram_raw <- function( if (is.null(lims[[ni]]) || is.na(lims[2, ni])) { lims[[ni]] <- c(NA, z[1], NA) warning(paste("adjustment values for ", ni, - " not defined in datadist; taken to be first value specified (", - z[1], ")", - sep = "" + " not defined in datadist; taken to be first value specified (", + z[1], ")", + sep = "" )) } } @@ -174,7 +174,7 @@ as_nomogram_raw <- function( if (any(assume == 9)) { main.effects <- main.effects[order(10 * discrete[main.effects] + - (name[main.effects] %in% names(interact)))] + (name[main.effects] %in% names(interact)))] } # For each predictor, get vector of predictor numbers directly or @@ -230,20 +230,22 @@ as_nomogram_raw <- function( if (discrete[n]) { acombo[[n]] <- abbreviate(parms[[n]], - minlength = if (minlength == 1) { - 4 - } else { - minlength - } + minlength = if (minlength == 1) { + 4 + } else { + minlength + } )[combo[[n]]] # lucky that abbreviate function names its result } } } - for (n in names(combo)) if (is.factor(combo[[n]])) { - combo[[n]] <- as.character(combo[[n]]) - # so row insertion will work xadj - acombo[[n]] <- as.character(acombo[[n]]) # so format() will work + for (n in names(combo)) { + if (is.factor(combo[[n]])) { + combo[[n]] <- as.character(combo[[n]]) + # so row insertion will work xadj + acombo[[n]] <- as.character(acombo[[n]]) # so format() will work + } } entities <- entities + 1 already.done[namo] <- TRUE @@ -262,15 +264,15 @@ as_nomogram_raw <- function( for (j in 1:length(acombo)) { set.name <- paste(set.name, - if (varname.label) { - paste(namo[j], varname.label.sep, - sep = "" - ) - } else { - "" - }, - format(acombo[[j]][k]), + if (varname.label) { + paste(namo[j], varname.label.sep, sep = "" + ) + } else { + "" + }, + format(acombo[[j]][k]), + sep = "" ) if (j < length(acombo)) set.name <- paste(set.name, " ", sep = "") } @@ -278,8 +280,10 @@ as_nomogram_raw <- function( # Make list of all terms needing inclusion in calculation # Include interation term names - interactions.containing in rmsMisc.s ia.names <- NULL - for (j in r) ia.names <- - c(ia.names, name[interactions.containing(at, j)]) + for (j in r) { + ia.names <- + c(ia.names, name[interactions.containing(at, j)]) + } ia.names <- unique(ia.names) attr(x, "info") <- list( @@ -305,8 +309,9 @@ as_nomogram_raw <- function( j <- j + 1 ns <- names(S) nam <- names(S) - for (k in 1:length(nam)) + for (k in 1:length(nam)) { xadj[[nam[k]]][start[j]:(start[j] + len[j] - 1)] <- S[[k]] + } } xadj <- structure( xadj, @@ -332,8 +337,8 @@ as_nomogram_raw <- function( } R <- matrix(NA, - nrow = 2, ncol = length(main.effects), - dimnames = list(NULL, name[main.effects]) + nrow = 2, ncol = length(main.effects), + dimnames = list(NULL, name[main.effects]) ) R[1, ] <- 1e30 R[2, ] <- -1e30 @@ -473,8 +478,7 @@ as_nomogram_raw <- function( # median.se <- tapply(xse[i], deciles, median) # xc <- (mean.xxb - Intercept) * sc # sec <- sc * median.se - } - else { + } else { xc <- (xxb[i] - Intercept) * sc sec <- sc * xse[i] } @@ -482,8 +486,7 @@ as_nomogram_raw <- function( x = scaled.x, x.real = lp.at, conf = list(x = xc, se = sec, w = w, nlev = nlev) ) - } - else { + } else { set[[iset]] <- list(x = scaled.x, x.real = lp.at) } } @@ -552,11 +555,15 @@ num_intercepts <- function(fit, type = c("fit", "coef")) { nm1 <- names(fit$coef)[1] nrp <- 1 * (nm1 == "Intercept" | nm1 == "(Intercept)") } - if (type == "fit") return(nrp) + if (type == "fit") { + return(nrp) + } if (type == "coef") w <- fit$coefficients i <- attr(w, "intercepts") li <- length(i) - if (!li) return(nrp) + if (!li) { + return(nrp) + } if (li == 1 && i == 0) 0 else li } @@ -632,7 +639,9 @@ formati <- function(x) { interactions.containing <- function(at, pred) { ia <- at$interactions - if (length(ia) == 0) return(NULL) + if (length(ia) == 0) { + return(NULL) + } name <- at$name parms <- at$parms ic <- NULL @@ -681,7 +690,9 @@ replace.substring.wild <- function(text, old, new, test = NULL, front = FALSE, b } qual <- test(substring(text, st, en)) - if (!any(qual)) return(text) + if (!any(qual)) { + return(text) + } st <- (st[qual])[1] en <- (en[qual])[1] @@ -713,7 +724,9 @@ replace.substring.wild <- function(text, old, new, test = NULL, front = FALSE, b loc.before <- list(first = loc.before$first[1], last = loc.before$last[1]) } - if (sum(loc.before$first + loc.before$last) == 0) return(text) + if (sum(loc.before$first + loc.before$last) == 0) { + return(text) + } loc.after <- if (old.after.star == "") { list(first = 0, last = 0) @@ -721,7 +734,9 @@ replace.substring.wild <- function(text, old, new, test = NULL, front = FALSE, b la <- substring.location(text, old.after.star, restrict = c(loc.before$last + 1, 1e10)) lastpos <- length(la$first) la <- list(first = la$first[lastpos], last = la$last[lastpos]) - if (la$first + la$last == 0) return(text) + if (la$first + la$last == 0) { + return(text) + } la } @@ -766,15 +781,23 @@ substring.location <- function(text, string, restrict) { if (length(text) > 1) stop("only works with a single character string") l.text <- nchar(text) l.string <- nchar(string) - if (l.string > l.text) return(list(first = 0, last = 0)) - if (l.string == l.text) return(if (text == string) list(first = 1, last = l.text) else list(first = 0, last = 0)) + if (l.string > l.text) { + return(list(first = 0, last = 0)) + } + if (l.string == l.text) { + return(if (text == string) list(first = 1, last = l.text) else list(first = 0, last = 0)) + } is <- 1:(l.text - l.string + 1) ss <- substring(text, is, is + l.string - 1) k <- ss == string - if (!any(k)) return(list(first = 0, last = 0)) + if (!any(k)) { + return(list(first = 0, last = 0)) + } k <- is[k] if (!missing(restrict)) k <- k[k >= restrict[1] & k <= restrict[2]] - if (length(k) == 0) return(list(first = 0, last = 0)) + if (length(k) == 0) { + return(list(first = 0, last = 0)) + } list(first = k, last = k + l.string - 1) } @@ -793,12 +816,13 @@ substring2 <- function(text, first, last = 100000L) base::substring(text, first, last <- rep(last, length = lf) for (i in 1:lf) { - text <- paste(if (first[i] > 1) { - substring(text, 1, first[i] - 1) - }, - value, - substring(text, last[i] + 1), - sep = "" + text <- paste( + if (first[i] > 1) { + substring(text, 1, first[i] - 1) + }, + value, + substring(text, last[i] + 1), + sep = "" ) if (i < lf) { diff --git a/R/rms_nomogram_method.R b/R/rms_nomogram_method.R index a3eadd2..41011cb 100755 --- a/R/rms_nomogram_method.R +++ b/R/rms_nomogram_method.R @@ -45,6 +45,7 @@ print.nomogram.raw <- function(x, dec = 0, ...) { # originally written by Frank E Harrell Jr. #' @importFrom graphics axis lines par segments strwidth text +#' @export plot.nomogram.raw <- function( x, lplabel = "Linear Predictor", @@ -56,7 +57,8 @@ plot.nomogram.raw <- function( varname.label = TRUE, varname.label.sep = "=", ia.space = .7, tck = NA, tcl = -0.25, lmgp = .4, naxes, points.label = "Points", total.points.label = "Total Points", - total.sep.page = FALSE, total.fun, cap.labels = FALSE, ...) { + total.sep.page = FALSE, total.fun, cap.labels = FALSE, ... +) { set <- x info <- attr(set, "info") @@ -140,7 +142,8 @@ plot.nomogram.raw <- function( naxes, xl, maxscale, cex.var, nint, space.used, col.grid, cex.axis, tck, tck2, tcl, tcl2, label.every, force.label, - points = TRUE, points.label = "Points", usr) { + points = TRUE, points.label = "Points", usr + ) { y <- naxes - 1 plot( 0, 0, @@ -148,7 +151,9 @@ plot.nomogram.raw <- function( type = "n", axes = FALSE, xlab = "", ylab = "" ) if (!missing(usr)) par(usr = usr) - if (!points) return(y + 1) + if (!points) { + return(y + 1) + } ax <- c(0, maxscale) text(xl, y, points.label, adj = 0, cex = cex.var) @@ -374,21 +379,21 @@ plot.nomogram.raw <- function( text(xl, y, lplabel, adj = 0, cex = cex.var) axisf(1, - at = x, labels = formati(lp.at), pos = y, - cex = cex.axis, tck = tck, tcl = tcl, - label.every = label.every, force.label = force.label, - mgp = c(0, lmgp - 0.6, 0), padj = 1 + at = x, labels = formati(lp.at), pos = y, + cex = cex.axis, tck = tck, tcl = tcl, + label.every = label.every, force.label = force.label, + mgp = c(0, lmgp - 0.6, 0), padj = 1 ) axisf(1, - at = scaled.x2, labels = FALSE, tck = tck2, tcl = tcl2, - pos = y, cex = cex.axis + at = scaled.x2, labels = FALSE, tck = tck2, tcl = tcl2, + pos = y, cex = cex.axis ) conf <- S$conf if (length(conf)) { bar(conf$x, - y + c(conf.space[1], conf.space[1] + conf$w * diff(conf.space)), - zcrit, conf$se, col.conf, - nlev = conf$nlev + y + c(conf.space[1], conf.space[1] + conf$w * diff(conf.space)), + zcrit, conf$se, col.conf, + nlev = conf$nlev ) } } @@ -418,7 +423,7 @@ plot.nomogram.raw <- function( if (length(sides) != length(fat)) { stop("fun.side vector not same length as fun.at or fun.lp.at") } - for (jj in 1:length(fat)) + for (jj in 1:length(fat)) { axis( sides[jj], at = scaled[jj], labels = fat[jj], @@ -426,6 +431,7 @@ plot.nomogram.raw <- function( mgp = if (sides[jj] == 1) c(0, lmgp - 0.6, 0) else c(0, lmgp, 0), padj = if (sides[jj] == 1) 1 else 0 ) + } lines(range(scaled), rep(y, 2)) # make sure all ticks are connected } } @@ -444,12 +450,15 @@ capitalize <- function(string) { axisf <- function( side, at, labels = TRUE, pos, cex, tck, tcl, - label.every = 1, force.label = FALSE, disc = FALSE, ...) { + label.every = 1, force.label = FALSE, disc = FALSE, ... +) { ax <- function(..., cex) axis(..., cex.axis = cex) ax(side, at, labels = FALSE, pos = pos, cex = cex, tck = tck, tcl = tcl, ...) - if (is.logical(labels) && !labels) return(invisible()) + if (is.logical(labels) && !labels) { + return(invisible()) + } if (label.every > 1 && !disc) { sq <- seq(along = at, by = label.every) @@ -458,14 +467,14 @@ axisf <- function( if (is.logical(labels)) labels <- format(at, trim = TRUE) if (force.label) { - for (i in 1:length(labels)) + for (i in 1:length(labels)) { if (!is.na(at[i])) { ax(side, at[i], labels[i], pos = pos, cex = cex, tcl = 0, ...) } - } - else { + } + } else { ax(side, at[!is.na(at)], labels[!is.na(at)], - pos = pos, cex = cex, tcl = 0, ... + pos = pos, cex = cex, tcl = 0, ... ) } @@ -484,7 +493,8 @@ save_oldpar <- function() { str_graph_wrap <- function( x, width = 0.9 * getOption("width"), indent = 0, exdent = 0, - prefix = "", simplify = TRUE, units = "user", cex = NULL) { + prefix = "", simplify = TRUE, units = "user", cex = NULL +) { if (!is.character(x)) x <- as.character(x) spc.len <- strwidth(" ", units = units, cex = cex) @@ -553,11 +563,12 @@ str_graph_wrap <- function( exdentString, nBlocks - 1 )), sep = "") - for (k in (1:nBlocks)) + for (k in (1:nBlocks)) { s[k] <- paste( s[k], paste(words[lowerBlockIndex[k]:upperBlockIndex[k]], collapse = " "), sep = "" ) + } yi <- c(yi, s, prefix) } y <- if (length(yi)) { diff --git a/R/rms_nomogram_misc.R b/R/rms_nomogram_misc.R index 57e8d7c..3fb080e 100755 --- a/R/rms_nomogram_misc.R +++ b/R/rms_nomogram_misc.R @@ -7,7 +7,8 @@ rms_datadist <- function( ..., data, q.display, q.effect = c(.25, .75), - adjto.cat = c("mode", "first"), n.unique = 10) { + adjto.cat = c("mode", "first"), n.unique = 10 +) { adjto.cat <- match.arg(adjto.cat) X <- list(...) @@ -18,8 +19,7 @@ rms_datadist <- function( Values <- x$values X[[1]] <- NULL argnames <- argnames[-1] - } - else { + } else { Limits <- list() Values <- list() } @@ -27,33 +27,27 @@ rms_datadist <- function( if (is.data.frame(X[[1]])) { if (length(X) > 1) stop("when the first argument is a data frame, no other variables may be specified") X <- X[[1]] - } - - else - if (is.recursive(X[[1]]) && - length(Terms <- X[[1]]$terms) && length(D <- attr(Terms, "Design"))) { - n <- D$name[D$assume != "interaction"] - X <- list() - if (missing(data)) { - for (nm in n) X[[nm]] <- eval.parent(nm) - } else - if (length(names(data))) { - j <- match(n, names(data), 0) - if (any(j == 0)) { - stop(paste( - "variable(s)", - paste(n[j == 0], collapse = " "), - "in model not found on data=, \nwhich has variables", - paste(names(data), collapse = " ") - )) - } - for (nm in n) X[[nm]] <- data[[nm]] - } - else { - for (nm in n) X[[nm]] <- get(nm, data) + } else if (is.recursive(X[[1]]) && + length(Terms <- X[[1]]$terms) && length(D <- attr(Terms, "Design"))) { + n <- D$name[D$assume != "interaction"] + X <- list() + if (missing(data)) { + for (nm in n) X[[nm]] <- eval.parent(nm) + } else if (length(names(data))) { + j <- match(n, names(data), 0) + if (any(j == 0)) { + stop(paste( + "variable(s)", + paste(n[j == 0], collapse = " "), + "in model not found on data=, \nwhich has variables", + paste(names(data), collapse = " ") + )) } + for (nm in n) X[[nm]] <- data[[nm]] + } else { + for (nm in n) X[[nm]] <- get(nm, data) } - else { + } else { if (length(X) & !length(names(X))) names(X) <- argnames[1:length(X)] # NEED TO FIX: R has no database.object @@ -64,8 +58,7 @@ rms_datadist <- function( # if(is.numeric(data)) X <- c(X,database.object(data)) # else X <- c(X, data) - } - else { + } else { # if(is.numeric(data)) X <- database.object(data) # else X <- data @@ -97,9 +90,7 @@ rms_datadist <- function( levx[1], levx[ll] ) values <- levx - } - - else if (ll) { + } else if (ll) { adjto <- if (adjto.cat == "first") { lev[1] } else { @@ -108,8 +99,7 @@ rms_datadist <- function( } limits <- factor(c(NA, adjto, NA, lev[1], lev[ll], lev[1], lev[ll]), levels = lev) # non-ordered categorical - } - else { # regular numeric variable + } else { # regular numeric variable clx <- setdiff(class(x), c("integer", "numeric")) # above prevents rounding of quantiles to integers y <- x[!is.na(x)] @@ -123,8 +113,7 @@ rms_datadist <- function( if (nunique < 2) { warning(paste(nam[i], "is constant")) limits <- rep(y[1], 7) - } - else { + } else { r <- range(values) limits[6:7] <- r if (nunique < 4) { @@ -144,12 +133,11 @@ rms_datadist <- function( # use low category if binary var, middle if 3-level, median otherwise if (nunique < 3) { limits[2] <- values[1] - } else - if (nunique == 3) { - limits[2] <- values[2] - } else { - limits[2] <- median(unclass(y)) - } + } else if (nunique == 3) { + limits[2] <- values[2] + } else { + limits[2] <- median(unclass(y)) + } if (nunique < 4) { q <- r @@ -191,7 +179,9 @@ all_numeric <- function(x, what = c("test", "vector"), extras = c(".", "NA")) { x <- sub("[[:space:]]+$", "", x) x <- sub("^[[:space:]]+", "", x) xs <- x[x %nin% c("", extras)] - if (!length(xs)) return(if (what == "test") FALSE else x) + if (!length(xs)) { + return(if (what == "test") FALSE else x) + } isnum <- suppressWarnings(!any(is.na(as.numeric(xs)))) if (what == "test") { isnum @@ -213,7 +203,9 @@ all_numeric <- function(x, what = c("test", "vector"), extras = c(".", "NA")) { # for handling `...` arguments to nomogram(). rms_args <- function(.object, envir = parent.frame(2)) { - if (length(.object) < 2) return(NULL) + if (length(.object) < 2) { + return(NULL) + } .names <- names(.object)[-1] # see if no variables given with = after their names if (!length(.names)) .names <- rep("", length(.object) - 1) @@ -225,8 +217,7 @@ rms_args <- function(.object, envir = parent.frame(2)) { if (.names[.i] == "") { .names[.i] <- .vars[.i] .res[[.i]] <- NA - } - else { + } else { .res[[.i]] <- eval(.object[[.i + 1]], envir = envir) } } @@ -293,8 +284,7 @@ get_lim <- function(at, x, allow.null = FALSE, need.all = TRUE) { } else { limits[[n]] <- rep(NA, 7) } # Added 28 Jul 94 - } - else { + } else { limits[[n]] <- u } } @@ -412,7 +402,9 @@ related_predictors <- function(at, type = c("all", "direct")) { } x[[i]] <- r } - if (type == "direct") return(x) + if (type == "direct") { + return(x) + } while (TRUE) { bigger <- FALSE @@ -456,7 +448,7 @@ check_values <- function(f, i, x, n, limval, type.range = "plot") { charval <- length(values) && is.character(values) if (isna & as != 7) { if (!length(limval) || match(name, dimnames(limval$limits)[[2]], 0) == 0 || - is.na(limval$limits["Adjust to", name])) { + is.na(limval$limits["Adjust to", name])) { stop(paste("variable", name, "does not have limits defined by datadist")) } @@ -516,8 +508,7 @@ check_values <- function(f, i, x, n, limval, type.range = "plot") { } x } - } - else if (as == 7) { + } else if (as == 7) { if (isna) { x <- parms } else if (is.character(x)) { @@ -559,7 +550,8 @@ rms_predict <- function( conf.type = c("mean", "individual", "simultaneous"), kint = NULL, na.action = na.keep, expand.na = TRUE, - center.terms = type == "terms", ref.zero = FALSE, ...) { + center.terms = type == "terms", ref.zero = FALSE, ... +) { type <- match.arg(type) conf.type <- match.arg(conf.type) if (conf.type == "simultaneous") { @@ -667,20 +659,20 @@ rms_predict <- function( xi <- get_limi(name[i], Limval, need.all = TRUE)[2L] if (assume[i] %in% c(5L, 8L)) { xi <- factor(xi, parms[[name[i]]]) - } else - if (assume[i] == 7L) { - stop("scored() is not implemented in hdnom") - # xi <- scored(xi, name = name[i]) - } else - if (assume[i] == 10L) { - xi <- matrix(parms[[name[i]]], nrow = 1) - } # matrx col medians + } else if (assume[i] == 7L) { + stop("scored() is not implemented in hdnom") + # xi <- scored(xi, name = name[i]) + } else if (assume[i] == 10L) { + xi <- matrix(parms[[name[i]]], nrow = 1) + } # matrx col medians adjto[[ii]] <- xi } names(adjto) <- name[non.ia] attr(adjto, "row.names") <- "1" class(adjto) <- "data.frame" - if (type == "adjto.data.frame") return(adjto) + if (type == "adjto.data.frame") { + return(adjto) + } adjto <- model.frame(Terms, adjto) adjto <- model.matrix(Terms.ns, adjto)[, -1, drop = FALSE] if (type == "adjto") { @@ -715,34 +707,32 @@ rms_predict <- function( } if (!se.fit && !conf.int) { return(LP) - } else - if (length(fit$se.fit)) { - if (nrp > 1L) { - warning("se.fit is retrieved from the fit but it corresponded to kint") - } - retlist <- list(linear.predictors = LP) - if (se.fit) retlist$se.fit <- naresid(naa, fit$se.fit) - if (conf.int) { - plminus <- zcrit * sqrt(retlist$se.fit^2 + vconstant) - retlist$lower <- LP - plminus - retlist$upper <- LP + plminus - } - return(retlist) + } else if (length(fit$se.fit)) { + if (nrp > 1L) { + warning("se.fit is retrieved from the fit but it corresponded to kint") } + retlist <- list(linear.predictors = LP) + if (se.fit) retlist$se.fit <- naresid(naa, fit$se.fit) + if (conf.int) { + plminus <- zcrit * sqrt(retlist$se.fit^2 + vconstant) + retlist$lower <- LP - plminus + retlist$upper <- LP + plminus + } + return(retlist) + } } # end type='lp' - else - if (type == "x") { - return( - structure( - naresid(naa, fit$x), - strata = if (length(stra <- fit$strata)) { - naresid(naa, stra) - } else { - NULL - } - ) + else if (type == "x") { + return( + structure( + naresid(naa, fit$x), + strata = if (length(stra <- fit$strata)) { + naresid(naa, stra) + } else { + NULL + } ) - } + ) + } X <- fit[["x"]] rnam <- dimnames(X)[[1]] if (!length(X)) { @@ -773,8 +763,7 @@ rms_predict <- function( xi <- as.integer(xi) levels(xi) <- parms[[name[i]]] class(xi) <- "factor" - } - else if (as == 7L) { + } else if (as == 7L) { stop("scored() is not implemented in hdnom") # xi <- scored(xi, name = name[i]) } else if (as == 10L) { @@ -788,8 +777,7 @@ rms_predict <- function( if (allna) { xi <- matrix(double(1L), nrow = length(xi), ncol = ncols) for (j in 1L:ncol(xi)) xi[, j] <- parms[[name[i]]][j] - } - else { + } else { xi <- matrix(xi, nrow = length(xi), ncol = ncols) } } @@ -802,7 +790,9 @@ rms_predict <- function( class(X) <- "data.frame" newdata <- X # Note: data.frame() converts matrix variables to individual variables - if (type == "data.frame") return(newdata) + if (type == "data.frame") { + return(newdata) + } } # end !is.data.frame(newdata) else { # Need to convert any factors to have all levels in original fit @@ -816,8 +806,8 @@ rms_predict <- function( w <- newdata[, i] V <- NULL if (asj %in% c(5L, 7L, 8L) | - (name[j] %in% names(Values) && - length(V <- Values[[name[j]]]) && is.character(V))) { + (name[j] %in% names(Values) && + length(V <- Values[[name[j]]]) && is.character(V))) { if (length(Pa <- parms[[name[j]]])) V <- Pa newdata[, i] <- factor(w, V) # Handles user specifying numeric values without quotes, that are levels @@ -835,7 +825,9 @@ rms_predict <- function( } } # is.data.frame(newdata) X <- model.frame(Terms, newdata, na.action = na.action, ...) - if (type == "model.frame") return(X) + if (type == "model.frame") { + return(X) + } naa <- attr(X, "na.action") rnam <- row.names(X) @@ -893,7 +885,9 @@ rms_predict <- function( } } - if (type %in% c("adjto.data.frame", "adjto")) return(adj_to(type)) + if (type %in% c("adjto.data.frame", "adjto")) { + return(adj_to(type)) + } if (type == "x") { return( @@ -910,19 +904,19 @@ rms_predict <- function( if (somex) { xb <- matxv(X, coeff, kint = kint) - Center + offset names(xb) <- rnam - } - else { + } else { xb <- if (offpres) offset else numeric(0) if (nstrata > 0) attr(xb, "strata") <- naresid(naa, strata) - return(structure(if (se.fit) { - list( - linear.predictors = xb, - se.fit = rep(NA, length(xb)) - ) - } else { - xb - }, - na.action = if (expand.na) NULL else naa + return(structure( + if (se.fit) { + list( + linear.predictors = xb, + se.fit = rep(NA, length(xb)) + ) + } else { + xb + }, + na.action = if (expand.na) NULL else naa )) } xb <- naresid(naa, xb) @@ -958,8 +952,7 @@ rms_predict <- function( } else { list(linear.predictors = xb - ycenter) } - } - else { + } else { xb - ycenter } retlist <- structure(ww, na.action = if (expand.na) NULL else naa) @@ -984,8 +977,7 @@ rms_predict <- function( } } return(retlist) - } - else { + } else { return(structure(xb - ycenter, na.action = if (expand.na) NULL else naa)) } } # end if type = "lp" @@ -1005,7 +997,7 @@ rms_predict <- function( if (!length(adjto)) adjto <- adj_to(type) if (ncol(adjto) != ncol(X)) { if (dimnames(adjto)[[2L]][1L] %in% c("Intercept", "(Intercept)") && - dimnames(X)[[2L]][1L] %nin% c("Intercept", "(Intercept)")) { + dimnames(X)[[2L]][1L] %nin% c("Intercept", "(Intercept)")) { adjto <- adjto[, -1L, drop = FALSE] } if (ncol(adjto) != ncol(X)) stop("program logic error") @@ -1023,7 +1015,7 @@ rms_predict <- function( if (se.fit) { se[, j] <- (((X[, ko, drop = FALSE] %*% cov[k, k, drop = FALSE]) * - X[, ko, drop = FALSE]) %*% rep(1., length(ko)))^.5 + X[, ko, drop = FALSE]) %*% rep(1., length(ko)))^.5 } } } @@ -1053,8 +1045,7 @@ rms_predict <- function( if (se.fit) { return(structure(list(fitted = fitted, se.fit = naresid(naa, se)), na.action = if (expand.na) NULL else naa)) - } - else { + } else { return(structure(fitted, na.action = if (expand.na) NULL else naa)) } } @@ -1156,7 +1147,9 @@ matxv <- function(a, b, kint = 1, bmat = FALSE) { ca <- ncol(a) cb <- ncol(b) if (cb < ca) stop("number of columns in b must be >= number in a") - if (cb == ca) return(a %*% t(b)) + if (cb == ca) { + return(a %*% t(b)) + } excess <- cb - ca xx <- matrix(0, nrow = nrow(a), ncol = excess) if (lbi && lkint) { @@ -1169,8 +1162,7 @@ matxv <- function(a, b, kint = 1, bmat = FALSE) { stop("b intercepts attribute do not match kint") } xx[] <- 1. - } - else if (lkint) { + } else if (lkint) { if (kint > excess) { stop("kint > number of excess elements in b") } @@ -1189,7 +1181,9 @@ matxv <- function(a, b, kint = 1, bmat = FALSE) { stop(paste("columns in a (", nc, ") must be <= length of b (", length(b), ")", sep = "")) } - if (nc == lb) return(drop(a %*% b)) + if (nc == lb) { + return(drop(a %*% b)) + } excess <- lb - nc if (lbi && lkint) { @@ -1202,15 +1196,13 @@ matxv <- function(a, b, kint = 1, bmat = FALSE) { stop("b intercepts attribute do not match kint") } bkint <- b[1] - } - else if (lkint) { + } else if (lkint) { if (kint > excess) { stop("kint > number excess elements in b") } bkint <- b[kint] - } - else { + } else { bkint <- 0. } drop(bkint + (a %*% b[(lb - nc + 1L):lb])) diff --git a/man/as_nomogram.Rd b/man/as_nomogram.Rd index 28fcb0a..350c8ca 100644 --- a/man/as_nomogram.Rd +++ b/man/as_nomogram.Rd @@ -48,7 +48,8 @@ y <- survival::Surv(time, event) 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" ) diff --git a/man/hdnom-package.Rd b/man/hdnom-package.Rd index 2a86c9b..c44be45 100644 --- a/man/hdnom-package.Rd +++ b/man/hdnom-package.Rd @@ -24,6 +24,7 @@ Useful links: Authors: \itemize{ + \item Nan Xiao \email{me@nanx.me} (\href{https://orcid.org/0000-0002-0250-5673}{ORCID}) \item Qing-Song Xu \email{qsxu@csu.edu.cn} \item Miao-Zhu Li \email{miaozhu.li@duke.edu} }