├── ..Rcheck ├── 00check.log └── R_check_bin │ ├── R │ └── Rscript ├── .Rbuildignore ├── .gitignore ├── .travis.yml ├── CRAN-SUBMISSION ├── DESCRIPTION ├── NAMESPACE ├── NEWS.md ├── R ├── aaa.R ├── flexsurvcure.R ├── helper.r ├── mixture.r └── nonmixture.R ├── codecov.yml ├── cran-comments.md ├── flexsurvcure.Rproj ├── man ├── flexsurvcure.Rd ├── mixsurv.Rd └── nmixsurv.Rd ├── readme.md ├── tests ├── testthat.R └── testthat │ ├── test_match_stata.R │ ├── test_surv_funcs.R │ └── testthat-problems.rds └── vignettes ├── flexsurvcure.R ├── flexsurvcure.Rmd └── flexsurvcure.html /..Rcheck/00check.log: -------------------------------------------------------------------------------- 1 | * using log directory ‘/Users/jamdahl/Documents/Code/flexsurvcure/..Rcheck’ 2 | * using R version 4.3.1 (2023-06-16) 3 | * using platform: aarch64-apple-darwin20 (64-bit) 4 | * R was compiled by 5 | Apple clang version 14.0.0 (clang-1400.0.29.202) 6 | GNU Fortran (GCC) 12.2.0 7 | * running under: macOS 15.2 8 | * using session charset: UTF-8 9 | * using option ‘--as-cran’ 10 | * checking for file ‘./DESCRIPTION’ ... ERROR 11 | Required field missing or empty: 12 | ‘Author’ 13 | * DONE 14 | Status: 1 ERROR 15 | -------------------------------------------------------------------------------- /..Rcheck/R_check_bin/R: -------------------------------------------------------------------------------- 1 | echo "'R' should not be used without a path -- see par. 1.6 of the manual" 2 | exit 1 3 | -------------------------------------------------------------------------------- /..Rcheck/R_check_bin/Rscript: -------------------------------------------------------------------------------- 1 | echo "'Rscript' should not be used without a path -- see par. 1.6 of the manual" 2 | exit 1 3 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | README.md 4 | ^cran-comments\.md$ 5 | ^.travis.yml$ 6 | ^codecov.yml$ 7 | ^\.travis\.yml$ 8 | ^codecov\.yml$ 9 | ^revdep$ 10 | ^CRAN-SUBMISSION$ 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | inst/doc 6 | revdep 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | sudo: false 5 | cache: packages 6 | r_packages: 7 | - covr 8 | install: 9 | - R -e 'install.packages("devtools")' 10 | - R -e 'devtools::install_deps(dep = T)' 11 | script: 12 | - R CMD build . 13 | - R -e 'devtools::test()' 14 | - R CMD check *tar.gz 15 | after_success: 16 | - Rscript -e 'library(covr); codecov()' 17 | -------------------------------------------------------------------------------- /CRAN-SUBMISSION: -------------------------------------------------------------------------------- 1 | Version: 1.3.3 2 | Date: 2025-02-15 05:36:11 UTC 3 | SHA: 7854c8f757b562ba49d88c7f8af9286afd6b56ae 4 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: flexsurvcure 2 | Title: Flexible Parametric Cure Models 3 | Version: 1.3.3 4 | Date: 2025-02-013 5 | Authors@R: person("Jordan", "Amdahl", email = "jrdnmdhl@gmail.com", role = c("aut", "cre")) 6 | Maintainer: Jordan Amdahl 7 | Description: Flexible parametric mixture and non-mixture cure models for time-to-event data. 8 | Depends: survival , flexsurv 9 | Suggests: 10 | testthat, 11 | knitr, 12 | rmarkdown, 13 | covr 14 | URL: https://github.com/jrdnmdhl/flexsurvcure 15 | BugReports: https://github.com/jrdnmdhl/flexsurvcure/issues 16 | Imports: boot 17 | License: GPL (>= 2) 18 | Encoding: UTF-8 19 | LazyData: true 20 | RoxygenNote: 7.3.1 21 | VignetteBuilder: knitr 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(Hmixsurv) 4 | export(Hnmixsurv) 5 | export(dmixsurv) 6 | export(dnmixsurv) 7 | export(flexsurvcure) 8 | export(hmixsurv) 9 | export(hnmixsurv) 10 | export(mean_mixsurv) 11 | export(mean_nmixsurv) 12 | export(pmixsurv) 13 | export(pnmixsurv) 14 | export(qmixsurv) 15 | export(qnmixsurv) 16 | export(rmixsurv) 17 | export(rmst_mixsurv) 18 | export(rmst_nmixsurv) 19 | export(rnmixsurv) 20 | import(flexsurv) 21 | import(survival) 22 | importFrom(boot,inv.logit) 23 | importFrom(boot,logit) 24 | importFrom(flexsurv,flexsurv.dists) 25 | importFrom(flexsurv,flexsurvreg) 26 | importFrom(stats,pnorm) 27 | importFrom(stats,qnorm) 28 | importFrom(stats,runif) 29 | importFrom(survival,Surv) 30 | importFrom(survival,survfit) 31 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # flexsurvcure 1.3.3 2 | - Fixes issue with quantile function generation that led to incorrect results when generating quantiles through summary.flexsurvreg 3 | 4 | # flexsurvcure 1.3.2 5 | - Fixes issue with incompatible vector length in quantile functions 6 | 7 | # flexsurvcure 1.3.1 8 | - Fixes bug where wrong function was used in quantile calculations for summary.flexsurvreg 9 | - Fixes issue with vectorization of quantile functions 10 | 11 | # flexsurvcure 1.3.0 12 | - Updated to include vectorized versions of mean_mixsurv and mean_nmixsurv 13 | 14 | # flexsurvcure 1.2.0 15 | - Changed p function to satisfy convention that p function is P[X <= x] when lower.tail=TRUE, rather than P[X < x] 16 | - Adds random sampling function to object returned by flexsurvcure 17 | 18 | # flexsurvcure 1.1.0 19 | - Added probit link option 20 | 21 | # flexsurvcure 1.0.0 22 | - Fixes and performance improvements to quantile & random generation functions 23 | 24 | # flexsurvcure 0.0.2 25 | - Fixes to cumulative hazard and RMST functions 26 | 27 | # flexsurvcure 0.0.1 28 | - Initial release 29 | -------------------------------------------------------------------------------- /R/aaa.R: -------------------------------------------------------------------------------- 1 | #' @import survival flexsurv 2 | #' @importFrom stats runif pnorm qnorm 3 | #' @importFrom boot logit inv.logit 4 | #' @importFrom survival Surv survfit 5 | #' @importFrom flexsurv flexsurvreg flexsurv.dists 6 | NULL 7 | -------------------------------------------------------------------------------- /R/flexsurvcure.R: -------------------------------------------------------------------------------- 1 | # Taken from flexsurv, needed to wrap init functions of base distributions 2 | 3 | expand.inits.args <- function(inits) { 4 | inits2 <- inits 5 | formals(inits2) <- alist(t=,mf=,mml=,aux=) 6 | body(inits2) <- body(inits) 7 | inits2 8 | } 9 | 10 | #' Mixture and Non-Mixture Parametric Cure Models 11 | ##' 12 | ##' Mixture and non-mixture cure models using flexible base distributions 13 | ##' from the flexsurv package. 14 | ##' 15 | ##' This function works as a wrapper around \code{\link[flexsurv:flexsurvreg]{flexsurv::flexsurvreg()}} by 16 | ##' dynamically constructing a custom distribution using wrappers to the 17 | ##' pdf and cdf functions. 18 | ##' 19 | ##' In a parametric mixture model, it is assumed that there exists a group of individuals 20 | ##' who experience no excess mortality, with the proportion of such individuals being given 21 | ##' by the cure fraction parameter, and a parametric distribution representing the excess 22 | ##' mortality for the remaining individuals. 23 | ##' 24 | ##' By contrast, a parametric non-mixture model simply rescales an existing parametric 25 | ##' distribution such that the probability of survival asymptotically approaches the 26 | ##' cure fraction parameter as time approaches infinity. 27 | ##' 28 | ##' @param formula A formula expression in conventional R linear modeling 29 | ##' syntax. The response must be a survival object as returned by the 30 | ##' \code{\link[survival:Surv]{survival::Surv()}} function, and any covariates are given on the right-hand 31 | ##' side. For example, 32 | ##' 33 | ##' \code{Surv(time, dead) ~ age + sex} 34 | ##' 35 | ##' \code{Surv} objects of \code{type="right"},\code{"counting"}, 36 | ##' \code{"interval1"} or \code{"interval2"} are supported, corresponding to 37 | ##' right-censored, left-truncated or interval-censored observations. 38 | ##' 39 | ##' If there are no covariates, specify \code{1} on the right hand side, for 40 | ##' example \code{Surv(time, dead) ~ 1}. 41 | ##' 42 | ##' By default, covariates are placed on the ``theta'' parameter of the 43 | ##' distribution, representing the cure fraction, through a linear 44 | ##' model with the selected link function. 45 | ##' 46 | ##' Covariates can be placed on parameters of the base distribution by using the 47 | ##' name of the parameter as a ``function'' in the formula. For example, in a 48 | ##' Weibull model, the following expresses the scale parameter in terms of age 49 | ##' and a treatment variable \code{treat}, and the shape parameter in terms of 50 | ##' sex and treatment. 51 | ##' 52 | ##' \code{Surv(time, dead) ~ age + treat + shape(sex) + shape(treat)} 53 | ##' 54 | ##' However, if the names of the ancillary parameters clash with any real 55 | ##' functions that might be used in formulae (such as \code{I()}, or 56 | ##' \code{factor()}), then those functions will not work in the formula. A 57 | ##' safer way to model covariates on ancillary parameters is through the 58 | ##' \code{anc} argument to \code{\link[flexsurv:flexsurvreg]{flexsurv::flexsurvreg}}. 59 | ##' 60 | ##' \code{\link[survival:survreg]{survival::survreg()}} users should also note that the function 61 | ##' \code{strata()} is ignored, so that any covariates surrounded by 62 | ##' \code{strata()} are applied to the location parameter. 63 | ##' @param data A data frame in which to find variables supplied in 64 | ##' \code{formula}. If not given, the variables should be in the working 65 | ##' environment. 66 | ##' @param weights Optional variable giving case weights. 67 | ##' @param bhazard Optional variable giving expected hazards for relative 68 | ##' survival models. 69 | ##' @param subset Vector of integers or logicals specifying the subset of the 70 | ##' observations to be used in the fit. 71 | ##' @param na.action a missing-data filter function, applied after any 'subset' 72 | ##' argument has been used. Default is \code{options()$na.action}. 73 | ##' @param dist A string representing one of the built-in distributions of flexsurv. 74 | ##' \code{Surv(time, dead) ~ age + treat, anc = list(shape = ~ sex + treat)} 75 | ##' @param link A string representing the link function to use for estimation of the 76 | ##' cure fraction. Defaults to "logistic", but also supports "loglog", "probit", and "identity". 77 | ##' @param mixture optional TRUE/FALSE to specify whether a mixture model should be fitted. Defaults to TRUE. 78 | ##' @param ... other arguments to be passed to \code{\link[flexsurv:flexsurvreg]{flexsurv::flexsurvreg}}. 79 | ##' @examples 80 | ##' flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="weibull", anc=list(scale=~group)) 81 | ##' flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="lnorm", mixture = FALSE) 82 | ##' flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="weibull", link="loglog") 83 | ##' @export 84 | flexsurvcure <- function(formula, data, weights, bhazard, subset, dist, na.action, link = "logistic", mixture = T, ...) { 85 | call <- match.call() 86 | indx <- match(c("formula", "data", "weights", "bhazard", "subset", "na.action"), names(call), nomatch = 0) 87 | if (indx[1] == 0) 88 | stop("A \"formula\" argument is required") 89 | temp <- call[c(1, indx)] 90 | temp[[1]] <- as.name("model.frame") 91 | if (missing(data)) temp[["data"]] <- environment(formula) 92 | if (missing(data)) data <- environment(formula) 93 | if (missing(dist)) stop("Must provide dist") 94 | optim = list() 95 | 96 | # Patch the transformations based on link argument 97 | if ("character" %in% class(dist)) { 98 | dist_list <- flexsurv.dists[[dist]] 99 | } else if("list" %in% class(dist)){ 100 | dist_list <- dist 101 | dist <- dist_list$name 102 | } else { 103 | stop("Argument 'dist' must be a string or list.") 104 | } 105 | dist_list$name <- paste0(dist_list$name, "_mix") 106 | n_base_par <- length(dist_list$pars) 107 | dist_list$pars <- c("theta", dist_list$pars) 108 | dist_list$location <- "theta" 109 | if(is.null(dist_list)) stop("Distribution not found") 110 | if (link == "logistic") { 111 | dist_list$transforms <- append(list(logit), dist_list$transforms) 112 | dist_list$inv.transforms <- append(list(inv.logit), dist_list$inv.transforms) 113 | } else if(link == "loglog") { 114 | dist_list$transforms <- append(list(function(x) log(-log(x))), dist_list$transforms) 115 | dist_list$inv.transforms <- append(list(function(x) exp(-exp(x))), dist_list$inv.transforms) 116 | } else if (link == "probit") { 117 | dist_list$transforms <- append(list(qnorm), dist_list$transforms) 118 | dist_list$inv.transforms <- append(list(pnorm), dist_list$inv.transforms) 119 | } else if(link == "identity") { 120 | dist_list$transforms <- append(list(identity), dist_list$transforms) 121 | dist_list$inv.transforms <- append(list(identity), dist_list$inv.transforms) 122 | optim$method <- "L-BFGS-B" 123 | optim$lower = c(0, rep(-Inf, n_base_par)) 124 | optim$upper = c(1, rep(Inf, n_base_par)) 125 | } else { 126 | stop("Link must be 'logistic', 'loglog', 'probit', or 'identity'") 127 | } 128 | 129 | base_init <- expand.inits.args(dist_list$inits) 130 | 131 | dist_list$inits <- function(t, mf, mml, aux) { 132 | # To estimate initial values: 133 | # -Cure fraction based on minimum KM survival 134 | # -Other parameters based on normal initial values 135 | # run only on events. 136 | surv <- as.matrix(mf[ ,1]) 137 | weights <- mf[ ,ncol(mf)] 138 | selector <- surv[ ,2] == 1 139 | aux_sf <- list( 140 | formula = aux$forms[[1]], 141 | data = aux$data, 142 | weights = aux$weights 143 | ) 144 | sf <- do.call(survfit, aux_sf) 145 | # Can't allow value of 0 146 | theta = max(min(sf$surv), 0.01) 147 | aux_events <- aux 148 | aux_events$data = aux$data[selector, ] 149 | out <- c(theta, base_init(t=t[selector], mf=mf[selector, ], mml=mml[selector, ], aux=aux_events)) 150 | return(out) 151 | } 152 | 153 | # Build function list 154 | pfun = get(paste0("p", dist)) 155 | dfun = get(paste0("d", dist)) 156 | qfun = get(paste0("q", dist)) 157 | if(mixture) { 158 | dfns_list = list( 159 | p = function(q, ...) pmixsurv(pfun, q, ...), 160 | d = function(x, ...) dmixsurv(dfun, pfun, x, ...), 161 | H = function(x, ...) Hmixsurv(pfun, x, ...), 162 | h = function(x, ...) hmixsurv(dfun, pfun, x, ...), 163 | q = function(p, ...) qmixsurv(qfun, p, ...), 164 | r = function(n, ...) rmixsurv(qfun, n, ...), 165 | mean = function(...) mean_mixsurv(pfun, ...), 166 | rmst = function(t, ...) rmst_mixsurv(pfun, t, ...) 167 | ) 168 | } else { 169 | dfns_list = list( 170 | p = function(q, ...) pnmixsurv(pfun, q, ...), 171 | d = function(x, ...) dnmixsurv(dfun, pfun, x, ...), 172 | H = function(x, ...) Hnmixsurv(pfun, x, ...), 173 | h = function(x, ...) hnmixsurv(dfun, x, ...), 174 | q = function(p, ...) qnmixsurv(qfun, p, ...), 175 | r = function(n, ...) rnmixsurv(qfun, n, ...), 176 | mean = function(...) mean_nmixsurv(pfun, ...), 177 | rmst = function(t, ...) rmst_nmixsurv(pfun, t, ...) 178 | ) 179 | } 180 | 181 | # Generate fit 182 | out <- do.call( 183 | "flexsurvreg", 184 | append( 185 | list( 186 | formula, 187 | data = data, 188 | weights = temp$weights, 189 | subset = temp$subset, 190 | bhazard = temp$bhazard, 191 | dist = dist_list, 192 | dfns = dfns_list, 193 | ... 194 | ), 195 | optim 196 | ) 197 | ) 198 | 199 | # Use top-level call and set additional properties/attributes 200 | out$call <- call 201 | class(out) <- c("flexsurvcure", class(out)) 202 | out$link <- link 203 | out$mixture <- mixture 204 | out 205 | } 206 | 207 | -------------------------------------------------------------------------------- /R/helper.r: -------------------------------------------------------------------------------- 1 | get_param_length_and_check <- function(theta, args) { 2 | param_lengths <- c(length(theta), sapply(args, length)) 3 | max_length <- max(param_lengths) 4 | valid_lengths <- (param_lengths <= 1) | (param_lengths == max_length) 5 | 6 | # If any two parameters with length > 1 have different lengths 7 | # then throw an error. 8 | if (!all(valid_lengths)) { 9 | stop('Parameter values provided were of incompatible length') 10 | } 11 | 12 | max_length 13 | } 14 | -------------------------------------------------------------------------------- /R/mixture.r: -------------------------------------------------------------------------------- 1 | ##' Mixture cure models 2 | ##' 3 | ##' Probability density, distribution, quantile, random generation, hazard 4 | ##' cumulative hazard, mean, and restricted mean functions for generic 5 | ##' mixture cure models. These distribution functions take as arguments 6 | ##' the corresponding functions of the base distribution used. 7 | ##' 8 | ##' @aliases dmixsurv pmixsurv qmixsurv rmixsurv 9 | ##' hmixsurv Hmixsurv mean_mixsurv rmst_mixsurv 10 | ##' @param pfun The base distribution's cumulative distribution function. 11 | ##' @param dfun The base distribution's probability density function. 12 | ##' @param qfun The base distribution's quantile function. 13 | ##' @param x,q,t Vector of times. 14 | ##' @param p Vector of probabilities. 15 | ##' @param n Number of random numbers to simulate. 16 | ##' @param theta The estimated cure fraction. 17 | ##' @param ... additional parameters to be passed to the pdf or cdf of the base 18 | ##' distribution. 19 | ##' @return \code{dmixsurv} gives the density, \code{pmixsurv} gives the 20 | ##' distribution function, \code{hmixsurv} gives the hazard and 21 | ##' \code{Hmixsurv} gives the cumulative hazard. 22 | ##' 23 | ##' \code{qmixsurv} gives the quantile function, which is computed by crude 24 | ##' numerical inversion. 25 | ##' 26 | ##' \code{rmixsurv} generates random survival times by using \code{qmixsurv} 27 | ##' on a sample of uniform random numbers. Due to the numerical root-finding 28 | ##' involved in \code{qmixsurv}, it is slow compared to typical random number 29 | ##' generation functions. 30 | ##' 31 | ##' \code{mean_mixsurv} and \code{rmst_mixsurv} give the mean and restricted 32 | ##' mean survival times, respectively. 33 | ##' @author Jordan Amdahl 34 | ##' @keywords distribution 35 | ##' @name mixsurv 36 | NULL 37 | 38 | ##' @export 39 | ##' @rdname mixsurv 40 | pmixsurv = function(pfun, q, theta, ...) { 41 | dots <- list(...) 42 | args <- dots 43 | args$lower.tail <- F 44 | args$log.p <- F 45 | out <- theta + (1 - theta) * do.call(pfun, append(list(q), args)) 46 | if (is.null(dots$lower.tail) || dots$lower.tail) { 47 | pos_inf <- is.infinite(q) & (q > 0) 48 | out[pos_inf] <- 0 49 | out <- 1 - out 50 | } 51 | if (!is.null(dots$log.p) && dots$log.p) { 52 | out <- log(out) 53 | } 54 | return(out) 55 | } 56 | 57 | ##' @export 58 | ##' @rdname mixsurv 59 | hmixsurv = function(dfun, pfun, x, theta, ...) { 60 | dots <- list(...) 61 | pargs <- dots 62 | pargs$lower.tail <- F 63 | pargs$log.p <- F 64 | pargs$log <- NULL 65 | dargs <- dots 66 | dargs$log <- F 67 | u_surv <- do.call(pfun, append(list(x), pargs)) 68 | u_pdf <- do.call(dfun, append(list(x), dargs)) 69 | out <- ((1 - theta) * u_pdf) / (theta + (1 - theta) * u_surv) 70 | if (!is.null(dots$log) && dots$log) { 71 | out <- log(out) 72 | } 73 | return(out) 74 | } 75 | 76 | ##' @export 77 | ##' @rdname mixsurv 78 | Hmixsurv = function(pfun, x, theta, ...) { 79 | dots <- list(...) 80 | pargs <- dots 81 | pargs$lower.tail <- F 82 | pargs$log.p <- F 83 | pargs$log <- NULL 84 | surv <- do.call(pmixsurv, append(list(pfun, x, theta), pargs)) 85 | out <- -log(surv) 86 | if (!is.null(dots$log) && dots$log) { 87 | out <- log(out) 88 | } 89 | return(out) 90 | } 91 | 92 | ##' @export 93 | ##' @rdname mixsurv 94 | dmixsurv = function(dfun, pfun, x, theta, ...) { 95 | dots <- list(...) 96 | pargs <- dots 97 | pargs$lower.tail <- F 98 | pargs$log.p <- F 99 | pargs$log <- NULL 100 | hargs <- dots 101 | hargs$log <- F 102 | u_surv <- do.call(pmixsurv, append(list(pfun, x, theta), pargs)) 103 | u_haz <- do.call(hmixsurv, append(list(dfun, pfun, x, theta), hargs)) 104 | out <- u_surv * u_haz 105 | if (!is.null(dots$log) && dots$log) { 106 | out <- log(out) 107 | } 108 | return(out) 109 | } 110 | 111 | ##' @export 112 | ##' @rdname mixsurv 113 | qmixsurv = function(qfun, p, theta, ...) { 114 | inv_p <- 1 - p 115 | dots <- list(...) 116 | args <- dots 117 | args$lower.tail <- F 118 | args$log.p <- F 119 | uncured <- inv_p > theta 120 | out <- rep(Inf, length(inv_p)) 121 | out[uncured] <- do.call(qfun, append(list(pmax((inv_p - theta) / (1 - theta),0)), args))[uncured] 122 | return(out) 123 | } 124 | 125 | 126 | ##' @export 127 | ##' @rdname mixsurv 128 | rmixsurv = function(qfun, n, theta, ...) { 129 | 130 | # Plug random uniform into quantile function 131 | out <- qmixsurv(qfun, runif(n = n), theta, ...) 132 | 133 | return(out) 134 | } 135 | 136 | ##' @export 137 | ##' @rdname mixsurv 138 | rmst_mixsurv = function(pfun, t, theta, ...) { 139 | args <- list(...) 140 | out <- do.call( 141 | rmst_generic, 142 | append( 143 | list( 144 | function(q, ...) pmixsurv(pfun, q, ...), 145 | t = t, 146 | theta = theta 147 | ), 148 | args 149 | ) 150 | ) 151 | return(out) 152 | } 153 | 154 | ##' @export 155 | ##' @rdname mixsurv 156 | mean_mixsurv = function(pfun, theta, ...) { 157 | 158 | # Put together arguments for call to rmst_generic 159 | args <- append( 160 | list( 161 | pfun, 162 | t = Inf, 163 | start = 0 164 | ), 165 | list(...) 166 | ) 167 | 168 | # Figure out what length the output should be and create 169 | # a vector to store result 170 | out_length <- get_param_length_and_check(theta, args) 171 | out <- numeric(length(out_length)) 172 | 173 | 174 | # Identify indices where mean survival will be infinite 175 | # cure fraction is > 0. 176 | inf_indices <- (theta > 0) & rep(T, out_length) 177 | out[inf_indices] <- Inf 178 | 179 | # Create arguments to call rmst_generic to estimate mean 180 | # for indices where cure fraction is zero. 181 | non_inf_args <- lapply(args, function(x) { 182 | 183 | # Handle x is length 1 and shouldn't be indexed on 184 | if (length(x) == 1) { 185 | return(x) 186 | } 187 | 188 | return(x[!inf_indices]) 189 | }) 190 | 191 | # Set output for indices where theta is zero 192 | non_inf_res <- do.call(rmst_generic, non_inf_args) 193 | 194 | out[!inf_indices] <- non_inf_res 195 | 196 | out 197 | } 198 | 199 | -------------------------------------------------------------------------------- /R/nonmixture.R: -------------------------------------------------------------------------------- 1 | ##' Non-Mixture Cure Models 2 | ##' 3 | ##' Probability density, distribution, quantile, random generation, hazard 4 | ##' cumulative hazard, mean, and restricted mean functions for generic 5 | ##' non-mixture cure models. These distribution functions take as arguments 6 | ##' the corresponding functions of the base distribution used. 7 | ##' 8 | ##' es dnmixsurv pnmixsurv qnmixsurv rnmixsurv 9 | ##' hnmixsurv Hnmixsurv mean_nmixsurv rmst_nmixsurv 10 | ##' @param pfun The base distribution's cumulative distribution function. 11 | ##' @param dfun The base distribution's probability density function. 12 | ##' @param qfun The base distribution's quantile function. 13 | ##' @param x,q,t Vector of times. 14 | ##' @param p Vector of probabilities. 15 | ##' @param n Number of random numbers to simulate. 16 | ##' @param theta The estimated cure fraction. 17 | ##' @param ... Parameters to be passed to the pdf or cdf of the base 18 | ##' distribution. 19 | ##' @return \code{dnmixsurv} gives the density, \code{pnmixsurv} gives the 20 | ##' distribution function, \code{hnmixsurv} gives the hazard and 21 | ##' \code{Hnmixsurv} gives the cumulative hazard. 22 | ##' 23 | ##' \code{qnmixsurv} gives the quantile function, which is computed by crude 24 | ##' numerical inversion. 25 | ##' 26 | ##' \code{rnmixsurv} generates random survival times by using \code{qnmixsurv} 27 | ##' on a sample of uniform random numbers. Due to the numerical root-finding 28 | ##' involved in \code{qnmixsurv}, it is slow compared to typical random number 29 | ##' generation functions. 30 | ##' 31 | ##' \code{mean_nmixsurv} and \code{rmst_nmixsurv} give the mean and restricted 32 | ##' mean survival times, respectively. 33 | ##' @author Jordan Amdahl 34 | ##' @keywords distribution 35 | ##' @name nmixsurv 36 | NULL 37 | 38 | ##' @export 39 | ##' @rdname nmixsurv 40 | pnmixsurv = function(pfun, q, theta, ...) { 41 | dots <- list(...) 42 | args <- dots 43 | args$lower.tail <- T 44 | args$log.p <- F 45 | out <- theta ^ do.call(pfun, append(list(q), args)) 46 | if (is.null(dots$lower.tail) || dots$lower.tail) { 47 | pos_inf <- is.infinite(q) & (q > 0) 48 | out[pos_inf] <- 0 49 | out <- 1 - out 50 | } 51 | if (!is.null(dots$log.p) && dots$log.p) { 52 | out <- log(out) 53 | } 54 | return(out) 55 | } 56 | 57 | ##' @export 58 | ##' @rdname nmixsurv 59 | hnmixsurv = function(dfun,x, theta, ...) { 60 | dots <- list(...) 61 | args <- dots 62 | args$log <- F 63 | out <- -log(theta) * do.call(dfun, append(list(x), args)) 64 | if (!is.null(dots$log) && dots$log) { 65 | out <- log(out) 66 | } 67 | return(out) 68 | } 69 | 70 | ##' @export 71 | ##' @rdname nmixsurv 72 | Hnmixsurv = function(pfun, x, theta, ...) { 73 | dots <- list(...) 74 | pargs <- dots 75 | pargs$lower.tail <- F 76 | pargs$log.p <- F 77 | pargs$log <- NULL 78 | surv <- do.call(pnmixsurv, append(list(pfun, x, theta), pargs)) 79 | out <- -log(surv) 80 | if (!is.null(dots$log) && dots$log) { 81 | out <- log(out) 82 | } 83 | return(out) 84 | } 85 | 86 | ##' @export 87 | ##' @rdname nmixsurv 88 | dnmixsurv = function(dfun, pfun, x, theta, ...) { 89 | dots <- list(...) 90 | pargs <- dots 91 | pargs$lower.tail <- F 92 | pargs$log.p <- F 93 | pargs$log <- NULL 94 | hargs <- dots 95 | hargs$log <- F 96 | u_surv <- do.call(pnmixsurv, append(list(pfun, x, theta), pargs)) 97 | u_haz <- do.call(hnmixsurv, append(list(dfun, x, theta), hargs)) 98 | out <- u_surv * u_haz 99 | if (!is.null(dots$log) && dots$log) { 100 | out <- log(out) 101 | } 102 | return(out) 103 | } 104 | 105 | ##' @export 106 | ##' @rdname nmixsurv 107 | qnmixsurv = function(qfun, p, theta, ...) { 108 | inv_p <- 1 - p 109 | dots <- list(...) 110 | args <- dots 111 | args$lower.tail <- F 112 | args$log.p <- F 113 | uncured <- inv_p > theta 114 | out <- rep(Inf, length(inv_p)) 115 | if (length(theta)==1) { 116 | theta <- rep(theta, length(out)) 117 | } 118 | 119 | zeroThetaInd = uncured & theta == 0 120 | 121 | if (any(zeroThetaInd)) { 122 | # If no cure then just use base qfun 123 | out[zeroThetaInd] <- do.call(qfun, append(list(inv_p[zeroThetaInd]), args)) 124 | } else { 125 | # Calculations below are meant to map the quantile distribution of the base 126 | # distribution to the quantile distribution of the cure model using the 127 | # following algebra: 128 | # 129 | # S(t) = theta ^ (1 - Su(t)) 130 | # ln[S(t)] = ln[theta ^ (1 - Su(t))] 131 | # ln[S(t)] = (1 - Su(t)) * ln[theta] 132 | # ln[S(t)] / ln[theta] = 1 - Su(t) 133 | # Su(t) = 1 - ln[S(t)] / ln[theta] 134 | # 135 | # Where Su(t) is the baseline survival distribution 136 | p_surv_to_lookup <- 1 - (log(inv_p) / log(theta)) 137 | out[uncured] <- do.call(qfun, append(list(p_surv_to_lookup), args))[uncured] 138 | } 139 | return(out) 140 | } 141 | 142 | 143 | ##' @export 144 | ##' @rdname nmixsurv 145 | rnmixsurv = function(qfun, n, theta, ...) { 146 | 147 | # Plug random uniform into quantile function 148 | out <- qnmixsurv(qfun, runif(n = n), theta, ...) 149 | 150 | return(out) 151 | } 152 | 153 | ##' @export 154 | ##' @rdname nmixsurv 155 | rmst_nmixsurv = function(pfun, t, theta, ...) { 156 | args <- list(...) 157 | out <- do.call( 158 | rmst_generic, 159 | append( 160 | list( 161 | function(q, ...) pnmixsurv(pfun, q, ...), 162 | t = t, 163 | theta = theta 164 | ), 165 | args 166 | ) 167 | ) 168 | return(out) 169 | } 170 | 171 | ##' @export 172 | ##' @rdname nmixsurv 173 | mean_nmixsurv = function(pfun, theta, ...) { 174 | 175 | # This is a very silly function because if theta is greater 176 | # than zero then the mean is infinite and if theta is zero 177 | # then the mean is zero. Still need to have it since all 178 | # flexsurv models should support getting means through 179 | # summary.flexsurv. 180 | 181 | # Put together arguments for call to rmst_generic 182 | args <- append( 183 | list( 184 | pfun, 185 | t = Inf, 186 | start = 0 187 | ), 188 | list(...) 189 | ) 190 | 191 | # Figure out what length the output should be and create 192 | # a vector to store result 193 | out_length <- get_param_length_and_check(theta, args) 194 | out <- numeric(length(out_length)) 195 | 196 | 197 | # Identify indices where mean survival will be infinite 198 | # cure fraction is > 0. 199 | inf_indices <- (theta > 0) & rep(T, out_length) 200 | out[inf_indices] <- Inf 201 | 202 | out[!inf_indices] <- 0 203 | 204 | out 205 | 206 | } 207 | 208 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Test environments 2 | * local OS X install, R 4.3.1 3 | * win-builder 4 | * Travis-CI 5 | 6 | ## R CMD check results 7 | 8 | 0 errors | 0 warnings | 0 note 9 | 10 | ## Reverse dependencies 11 | * easysurv, hdcuremodels 12 | -------------------------------------------------------------------------------- /flexsurvcure.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --as-cran 22 | PackageRoxygenize: rd,collate,namespace,vignette 23 | -------------------------------------------------------------------------------- /man/flexsurvcure.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/flexsurvcure.R 3 | \name{flexsurvcure} 4 | \alias{flexsurvcure} 5 | \title{Mixture and Non-Mixture Parametric Cure Models} 6 | \usage{ 7 | flexsurvcure( 8 | formula, 9 | data, 10 | weights, 11 | bhazard, 12 | subset, 13 | dist, 14 | na.action, 15 | link = "logistic", 16 | mixture = T, 17 | ... 18 | ) 19 | } 20 | \arguments{ 21 | \item{formula}{A formula expression in conventional R linear modeling 22 | syntax. The response must be a survival object as returned by the 23 | \code{\link[survival:Surv]{survival::Surv()}} function, and any covariates are given on the right-hand 24 | side. For example, 25 | 26 | \code{Surv(time, dead) ~ age + sex} 27 | 28 | \code{Surv} objects of \code{type="right"},\code{"counting"}, 29 | \code{"interval1"} or \code{"interval2"} are supported, corresponding to 30 | right-censored, left-truncated or interval-censored observations. 31 | 32 | If there are no covariates, specify \code{1} on the right hand side, for 33 | example \code{Surv(time, dead) ~ 1}. 34 | 35 | By default, covariates are placed on the ``theta'' parameter of the 36 | distribution, representing the cure fraction, through a linear 37 | model with the selected link function. 38 | 39 | Covariates can be placed on parameters of the base distribution by using the 40 | name of the parameter as a ``function'' in the formula. For example, in a 41 | Weibull model, the following expresses the scale parameter in terms of age 42 | and a treatment variable \code{treat}, and the shape parameter in terms of 43 | sex and treatment. 44 | 45 | \code{Surv(time, dead) ~ age + treat + shape(sex) + shape(treat)} 46 | 47 | However, if the names of the ancillary parameters clash with any real 48 | functions that might be used in formulae (such as \code{I()}, or 49 | \code{factor()}), then those functions will not work in the formula. A 50 | safer way to model covariates on ancillary parameters is through the 51 | \code{anc} argument to \code{\link[flexsurv:flexsurvreg]{flexsurv::flexsurvreg}}. 52 | 53 | \code{\link[survival:survreg]{survival::survreg()}} users should also note that the function 54 | \code{strata()} is ignored, so that any covariates surrounded by 55 | \code{strata()} are applied to the location parameter.} 56 | 57 | \item{data}{A data frame in which to find variables supplied in 58 | \code{formula}. If not given, the variables should be in the working 59 | environment.} 60 | 61 | \item{weights}{Optional variable giving case weights.} 62 | 63 | \item{bhazard}{Optional variable giving expected hazards for relative 64 | survival models.} 65 | 66 | \item{subset}{Vector of integers or logicals specifying the subset of the 67 | observations to be used in the fit.} 68 | 69 | \item{dist}{A string representing one of the built-in distributions of flexsurv. 70 | \code{Surv(time, dead) ~ age + treat, anc = list(shape = ~ sex + treat)}} 71 | 72 | \item{na.action}{a missing-data filter function, applied after any 'subset' 73 | argument has been used. Default is \code{options()$na.action}.} 74 | 75 | \item{link}{A string representing the link function to use for estimation of the 76 | cure fraction. Defaults to "logistic", but also supports "loglog", "probit", and "identity".} 77 | 78 | \item{mixture}{optional TRUE/FALSE to specify whether a mixture model should be fitted. Defaults to TRUE.} 79 | 80 | \item{...}{other arguments to be passed to \code{\link[flexsurv:flexsurvreg]{flexsurv::flexsurvreg}}.} 81 | } 82 | \description{ 83 | Mixture and non-mixture cure models using flexible base distributions 84 | from the flexsurv package. 85 | } 86 | \details{ 87 | This function works as a wrapper around \code{\link[flexsurv:flexsurvreg]{flexsurv::flexsurvreg()}} by 88 | dynamically constructing a custom distribution using wrappers to the 89 | pdf and cdf functions. 90 | 91 | In a parametric mixture model, it is assumed that there exists a group of individuals 92 | who experience no excess mortality, with the proportion of such individuals being given 93 | by the cure fraction parameter, and a parametric distribution representing the excess 94 | mortality for the remaining individuals. 95 | 96 | By contrast, a parametric non-mixture model simply rescales an existing parametric 97 | distribution such that the probability of survival asymptotically approaches the 98 | cure fraction parameter as time approaches infinity. 99 | } 100 | \examples{ 101 | flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="weibull", anc=list(scale=~group)) 102 | flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="lnorm", mixture = FALSE) 103 | flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="weibull", link="loglog") 104 | } 105 | -------------------------------------------------------------------------------- /man/mixsurv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mixture.r 3 | \name{mixsurv} 4 | \alias{mixsurv} 5 | \alias{dmixsurv} 6 | \alias{pmixsurv} 7 | \alias{qmixsurv} 8 | \alias{rmixsurv} 9 | \alias{hmixsurv} 10 | \alias{Hmixsurv} 11 | \alias{mean_mixsurv} 12 | \alias{rmst_mixsurv} 13 | \title{Mixture cure models} 14 | \usage{ 15 | pmixsurv(pfun, q, theta, ...) 16 | 17 | hmixsurv(dfun, pfun, x, theta, ...) 18 | 19 | Hmixsurv(pfun, x, theta, ...) 20 | 21 | dmixsurv(dfun, pfun, x, theta, ...) 22 | 23 | qmixsurv(qfun, p, theta, ...) 24 | 25 | rmixsurv(qfun, n, theta, ...) 26 | 27 | rmst_mixsurv(pfun, t, theta, ...) 28 | 29 | mean_mixsurv(pfun, theta, ...) 30 | } 31 | \arguments{ 32 | \item{pfun}{The base distribution's cumulative distribution function.} 33 | 34 | \item{theta}{The estimated cure fraction.} 35 | 36 | \item{...}{additional parameters to be passed to the pdf or cdf of the base 37 | distribution.} 38 | 39 | \item{dfun}{The base distribution's probability density function.} 40 | 41 | \item{x, q, t}{Vector of times.} 42 | 43 | \item{qfun}{The base distribution's quantile function.} 44 | 45 | \item{p}{Vector of probabilities.} 46 | 47 | \item{n}{Number of random numbers to simulate.} 48 | } 49 | \value{ 50 | \code{dmixsurv} gives the density, \code{pmixsurv} gives the 51 | distribution function, \code{hmixsurv} gives the hazard and 52 | \code{Hmixsurv} gives the cumulative hazard. 53 | 54 | \code{qmixsurv} gives the quantile function, which is computed by crude 55 | numerical inversion. 56 | 57 | \code{rmixsurv} generates random survival times by using \code{qmixsurv} 58 | on a sample of uniform random numbers. Due to the numerical root-finding 59 | involved in \code{qmixsurv}, it is slow compared to typical random number 60 | generation functions. 61 | 62 | \code{mean_mixsurv} and \code{rmst_mixsurv} give the mean and restricted 63 | mean survival times, respectively. 64 | } 65 | \description{ 66 | Probability density, distribution, quantile, random generation, hazard 67 | cumulative hazard, mean, and restricted mean functions for generic 68 | mixture cure models. These distribution functions take as arguments 69 | the corresponding functions of the base distribution used. 70 | } 71 | \author{ 72 | Jordan Amdahl 73 | } 74 | \keyword{distribution} 75 | -------------------------------------------------------------------------------- /man/nmixsurv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nonmixture.R 3 | \name{nmixsurv} 4 | \alias{nmixsurv} 5 | \alias{pnmixsurv} 6 | \alias{hnmixsurv} 7 | \alias{Hnmixsurv} 8 | \alias{dnmixsurv} 9 | \alias{qnmixsurv} 10 | \alias{rnmixsurv} 11 | \alias{rmst_nmixsurv} 12 | \alias{mean_nmixsurv} 13 | \title{Non-Mixture Cure Models} 14 | \usage{ 15 | pnmixsurv(pfun, q, theta, ...) 16 | 17 | hnmixsurv(dfun, x, theta, ...) 18 | 19 | Hnmixsurv(pfun, x, theta, ...) 20 | 21 | dnmixsurv(dfun, pfun, x, theta, ...) 22 | 23 | qnmixsurv(qfun, p, theta, ...) 24 | 25 | rnmixsurv(qfun, n, theta, ...) 26 | 27 | rmst_nmixsurv(pfun, t, theta, ...) 28 | 29 | mean_nmixsurv(pfun, theta, ...) 30 | } 31 | \arguments{ 32 | \item{pfun}{The base distribution's cumulative distribution function.} 33 | 34 | \item{theta}{The estimated cure fraction.} 35 | 36 | \item{...}{Parameters to be passed to the pdf or cdf of the base 37 | distribution.} 38 | 39 | \item{dfun}{The base distribution's probability density function.} 40 | 41 | \item{x, q, t}{Vector of times.} 42 | 43 | \item{qfun}{The base distribution's quantile function.} 44 | 45 | \item{p}{Vector of probabilities.} 46 | 47 | \item{n}{Number of random numbers to simulate.} 48 | } 49 | \value{ 50 | \code{dnmixsurv} gives the density, \code{pnmixsurv} gives the 51 | distribution function, \code{hnmixsurv} gives the hazard and 52 | \code{Hnmixsurv} gives the cumulative hazard. 53 | 54 | \code{qnmixsurv} gives the quantile function, which is computed by crude 55 | numerical inversion. 56 | 57 | \code{rnmixsurv} generates random survival times by using \code{qnmixsurv} 58 | on a sample of uniform random numbers. Due to the numerical root-finding 59 | involved in \code{qnmixsurv}, it is slow compared to typical random number 60 | generation functions. 61 | 62 | \code{mean_nmixsurv} and \code{rmst_nmixsurv} give the mean and restricted 63 | mean survival times, respectively. 64 | } 65 | \description{ 66 | Probability density, distribution, quantile, random generation, hazard 67 | cumulative hazard, mean, and restricted mean functions for generic 68 | non-mixture cure models. These distribution functions take as arguments 69 | the corresponding functions of the base distribution used. 70 | } 71 | \details{ 72 | es dnmixsurv pnmixsurv qnmixsurv rnmixsurv 73 | hnmixsurv Hnmixsurv mean_nmixsurv rmst_nmixsurv 74 | } 75 | \author{ 76 | Jordan Amdahl 77 | } 78 | \keyword{distribution} 79 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | flexsurvcure 2 | ============ 3 | 4 | 5 | [![Travis build status](https://travis-ci.com/jrdnmdhl/flexsurvcure.svg?branch=master#1)](https://travis-ci.com/jrdnmdhl/flexsurvcure) 6 | [![codecov](https://codecov.io/gh/jrdnmdhl/flexsurvcure/branch/master/graph/badge.svg#1)](https://codecov.io/gh/jrdnmdhl/flexsurvcure) 7 | 8 | 9 | The development repository for flexsurvcure, an R package for parametric mixture and non-mixture cure models. Flexsurvcure is based on [flexsurv](http://cran.r-project.org/package=flexsurv), the R package for parametric survival modelling. 10 | 11 | ## Installation (development version) 12 | 13 | ```r 14 | install.packages("flexsurv") 15 | install.packages("devtools") 16 | devtools::install_github('jrdnmdhl/flexsurvcure') 17 | ``` 18 | 19 | ## Supported Distributions 20 | 21 | All of the built-in distribution with flexsurvreg are supported, though some currently have issues with convergence and numerical instability. The following distributions currently seem reliable: 22 | 23 | - Exponential (exp) 24 | - Weibull (weibull, weibullPH) 25 | - Lognormal (lnorm) 26 | - Log-Logistic (llogis) 27 | 28 | The following distributions are supported, but may not be reliable: 29 | 30 | - Gompertz (gompertz) 31 | - Generalized Gamma (gengamma, gengamma.orig) 32 | - Generalized F (genf, genf.orig) 33 | 34 | Custom distributions can also be used by passing a distribution list (see [flexsurv examples](https://cran.r-project.org/web/packages/flexsurv/vignettes/flexsurv-examples.pdf)). 35 | 36 | ## Fitting a mixture cure model 37 | ```r 38 | mixture = flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="weibullPH", link="logistic", mixture = T) 39 | plot(mixture) 40 | ``` 41 | 42 | 43 | ## Fitting a non-mixture cure model 44 | ```r 45 | non_mixture = flexsurvcure(Surv(rectime,censrec)~group, data=bc, dist="weibullPH", link="loglog", mixture = F) 46 | plot(non_mixture) 47 | ``` 48 | 49 | ## Covariates on parameters other than cure fraction 50 | ```r 51 | non_mixture_covarite_scale = flexsurvcure(Surv(rectime,censrec)~group, data=bc, anc=list(scale=~group), dist="weibullPH", link="loglog", mixture = F) 52 | plot(non_mixture_covarite_scale) 53 | ``` 54 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(flexsurvcure) 3 | 4 | test_check("flexsurvcure") 5 | -------------------------------------------------------------------------------- /tests/testthat/test_match_stata.R: -------------------------------------------------------------------------------- 1 | test_that("Weibull Mixture matches stata", { 2 | 3 | # Weibull, Logistic 4 | # ------------------------------------------------------------------------------ 5 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 6 | # -------------+---------------------------------------------------------------- 7 | # pi | 8 | # _cons | -.4731367 .1641441 -2.88 0.004 -.7948533 -.1514202 9 | # -------------+---------------------------------------------------------------- 10 | # ln_lambda | 11 | # _cons | -11.10519 .5901206 -18.82 0.000 -12.2618 -9.948572 12 | # -------------+---------------------------------------------------------------- 13 | # ln_gamma | 14 | # _cons | .448163 .0576425 7.77 0.000 .3351858 .5611403 15 | # ------------------------------------------------------------------------------ 16 | logistic_params <- c( -.4731367, .448163, -11.10519) 17 | logistic_lower <- c( -.7948533, .3351858, -12.2618) 18 | logistic_upper <- c(-.1514202, .5611403, -9.948572) 19 | logistic_se <- c(.1641441 , .0576425 , .5901206) 20 | # Suppress unimportant NaN warnings from WeibullPH functions. 21 | logistic_null <- suppressWarnings(flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="weibullPH")) 22 | 23 | # Tolerance here is very permissive 24 | expect_equal(logistic_params, unname(logistic_null$res.t[ ,1]), tolerance=1e-2) 25 | expect_equal(logistic_lower, unname(logistic_null$res.t[ ,2]), tolerance=1e-2) 26 | expect_equal(logistic_upper, unname(logistic_null$res.t[ ,3]), tolerance=1e-2) 27 | expect_equal(logistic_se, unname(logistic_null$res.t[ ,4]), tolerance=1e-2) 28 | 29 | # Weibull, Identity Link 30 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 31 | # -------------+---------------------------------------------------------------- 32 | # pi | 33 | # _cons | .3838745 .0388224 9.89 0.000 .3077839 .4599651 34 | # -------------+---------------------------------------------------------------- 35 | # ln_lambda | 36 | # _cons | -11.10519 .5901226 -18.82 0.000 -12.26181 -9.948572 37 | # -------------+---------------------------------------------------------------- 38 | # ln_gamma | 39 | # _cons | .4481635 .0576427 7.77 0.000 .3351859 .561141 40 | # ------------------------------------------------------------------------------ 41 | ident_params <- c(.3838745, .4481635, -11.10519) 42 | ident_lower <- c(.3077839, .3351859, -12.26181) 43 | ident_upper <- c(.4599651, .561141, -9.948572) 44 | ident_se <- c(.0388224, .0576427, .5901226) 45 | ident_null <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="identity", dist="weibullPH") 46 | 47 | # Tolerance here is very permissive 48 | expect_equal(ident_params, unname(ident_null$res.t[ ,1]), tolerance=1e-2) 49 | expect_equal(ident_lower, unname(ident_null$res.t[ ,2]), tolerance=1e-2) 50 | expect_equal(ident_upper, unname(ident_null$res.t[ ,3]), tolerance=1e-2) 51 | expect_equal(ident_se, unname(ident_null$res.t[ ,4]), tolerance=1e-2) 52 | 53 | }) 54 | test_that("Lognormal Mixture matches stata", { 55 | 56 | 57 | # Lognormal, Loglog 58 | # ------------------------------------------------------------------------------ 59 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 60 | # -------------+---------------------------------------------------------------- 61 | # pi | 62 | # _cons | .2484884 .1977661 1.26 0.209 -.1391261 .6361029 63 | # -------------+---------------------------------------------------------------- 64 | # mu | 65 | # _cons | 6.982434 .1304159 53.54 0.000 6.726824 7.238045 66 | # -------------+---------------------------------------------------------------- 67 | # ln_sigma | 68 | # _cons | -.0933944 .0800745 -1.17 0.243 -.2503376 .0635487 69 | # ------------------------------------------------------------------------------ 70 | loglog_params <- c(.2484884, 6.982434, -.0933944) 71 | loglog_lower <- c( -.1391261, 6.726824, -.2503376) 72 | loglog_upper <- c(.6361029, 7.238045, .0635487) 73 | loglog_se <- c(.1977661, .1304159, .0800745) 74 | loglog_null <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="loglog", dist="lnorm") 75 | 76 | # Tolerance here is very permissive 77 | expect_equal(loglog_params, unname(loglog_null$res.t[ ,1]), tolerance=1e-2) 78 | expect_equal(loglog_lower, unname(loglog_null$res.t[ ,2]), tolerance=1e-2) 79 | expect_equal(loglog_upper, unname(loglog_null$res.t[ ,3]), tolerance=1e-2) 80 | expect_equal(loglog_se, unname(loglog_null$res.t[ ,4]), tolerance=1e-2) 81 | 82 | # Lognormal, Identity Link 83 | # ------------------------------------------------------------------------------ 84 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 85 | # -------------+---------------------------------------------------------------- 86 | # pi | 87 | # _cons | .2774585 .0703503 3.94 0.000 .1395744 .4153425 88 | # -------------+---------------------------------------------------------------- 89 | # mu | 90 | # _cons | 6.982433 .1304159 53.54 0.000 6.726823 7.238044 91 | # -------------+---------------------------------------------------------------- 92 | # ln_sigma | 93 | # _cons | -.093395 .0800746 -1.17 0.243 -.2503383 .0635482 94 | # ------------------------------------------------------------------------------ 95 | ident_params <- c(.2774585, 6.982433, -.093395) 96 | ident_lower <- c(.1395744, 6.726823, -.2503383) 97 | ident_upper <- c(.4153425, 7.238044, .0635482) 98 | ident_se <- c(.0703503, .1304159, .0800746) 99 | ident_null <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="identity", dist="lnorm") 100 | 101 | # Tolerance here is very permissive 102 | expect_equal(ident_params, unname(ident_null$res.t[ ,1]), tolerance=1e-2) 103 | expect_equal(ident_lower, unname(ident_null$res.t[ ,2]), tolerance=1e-2) 104 | expect_equal(ident_upper, unname(ident_null$res.t[ ,3]), tolerance=1e-2) 105 | expect_equal(ident_se, unname(ident_null$res.t[ ,4]), tolerance=1e-2) 106 | 107 | }) 108 | test_that("Weibull Non-Mixture matches stata", { 109 | 110 | # Weibull, Logistic 111 | # ------------------------------------------------------------------------------ 112 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 113 | # -------------+---------------------------------------------------------------- 114 | # pi | 115 | # _cons | -.5151878 .1806544 -2.85 0.004 -.8692639 -.1611116 116 | # -------------+---------------------------------------------------------------- 117 | # ln_lambda | 118 | # _cons | -12.16467 .6119361 -19.88 0.000 -13.36405 -10.9653 119 | # -------------+---------------------------------------------------------------- 120 | # ln_gamma | 121 | # _cons | .5110451 .0585201 8.73 0.000 .3963477 .6257425 122 | # ------------------------------------------------------------------------------ 123 | logistic_params <- c( -.5151878, .5110451, -12.16467) 124 | logistic_lower <- c( -.8692639, .3963477, -13.36405) 125 | logistic_upper <- c(-.1611116, .6257425, -10.9653) 126 | logistic_se <- c(.1806544 , .0585201 , .6119361) 127 | # Suppress Nan Warnings 128 | logistic_null <- suppressWarnings(flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="weibullPH", mixture=F)) 129 | 130 | # Tolerance here is very permissive 131 | expect_equal(logistic_params, unname(logistic_null$res.t[ ,1]), tolerance=1e-2) 132 | expect_equal(logistic_lower, unname(logistic_null$res.t[ ,2]), tolerance=1e-2) 133 | expect_equal(logistic_upper, unname(logistic_null$res.t[ ,3]), tolerance=1e-2) 134 | expect_equal(logistic_se, unname(logistic_null$res.t[ ,4]), tolerance=1e-2) 135 | 136 | # Weibull, Loglog 137 | # ------------------------------------------------------------------------------ 138 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 139 | # -------------+---------------------------------------------------------------- 140 | # pi | 141 | # _cons | -.0165781 .1149836 -0.14 0.885 -.2419419 .2087857 142 | # -------------+---------------------------------------------------------------- 143 | # ln_lambda | 144 | # _cons | -12.16465 .6119389 -19.88 0.000 -13.36402 -10.96527 145 | # -------------+---------------------------------------------------------------- 146 | # ln_gamma | 147 | # _cons | .5110431 .0585205 8.73 0.000 .3963451 .6257412 148 | # ------------------------------------------------------------------------------ 149 | 150 | loglog_params <- c(-.0165781, .5110431, -12.16465) 151 | loglog_lower <- c( -.2419419, .3963451, -13.36402) 152 | loglog_upper <- c(.2087857, .6257412, -10.96527) 153 | loglog_se <- c(.1149836, .0585205, .6119389) 154 | # Supress NaN Warnings 155 | loglog_null <- suppressWarnings(flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="loglog", dist="weibullPH", mixture=F)) 156 | 157 | # Tolerance here is very permissive 158 | expect_equal(loglog_params, unname(loglog_null$res.t[ ,1]), tolerance=1e-2) 159 | expect_equal(loglog_lower, unname(loglog_null$res.t[ ,2]), tolerance=1e-2) 160 | expect_equal(loglog_upper, unname(loglog_null$res.t[ ,3]), tolerance=1e-2) 161 | expect_equal(loglog_se, unname(loglog_null$res.t[ ,4]), tolerance=1e-2) 162 | }) 163 | test_that("Weibull Mixture w/ covariate matches stata", { 164 | 165 | good_data <- bc 166 | good_data$good <- ifelse(good_data$group == "Good", 1, 0) 167 | 168 | # Weibull, loglog 169 | # ------------------------------------------------------------------------------ 170 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 171 | # -------------+---------------------------------------------------------------- 172 | # pi | 173 | # good | -1.304919 .1775218 -7.35 0.000 -1.652856 -.9569831 174 | # _cons | .360375 .1384624 2.60 0.009 .0889936 .6317564 175 | # -------------+---------------------------------------------------------------- 176 | # ln_lambda | 177 | # _cons | -11.05986 .5894734 -18.76 0.000 -12.2152 -9.90451 178 | # -------------+---------------------------------------------------------------- 179 | # ln_gamma | 180 | # _cons | .4434316 .0580233 7.64 0.000 .329708 .5571553 181 | # ------------------------------------------------------------------------------ 182 | 183 | loglog_params <- c(.360375, .4434316, -11.05986, -1.304919) 184 | loglog_lower <- c(.0889936, .329708, -12.2152, -1.652856) 185 | loglog_upper <- c(.6317564, .5571553,-9.90451, -.9569831) 186 | loglog_se <- c(.1384624, .0580233, .5894734, .1775218) 187 | # Suppress NaN Warnings 188 | loglog_cov <- suppressWarnings(flexsurvcure(Surv(rectime, censrec)~good,data=good_data,link="loglog", dist="weibullPH")) 189 | 190 | # Tolerance here is very permissive 191 | expect_equal(loglog_params, unname(loglog_cov$res.t[ ,1]), tolerance=1e-2) 192 | expect_equal(loglog_lower, unname(loglog_cov$res.t[ ,2]), tolerance=1e-2) 193 | expect_equal(loglog_upper, unname(loglog_cov$res.t[ ,3]), tolerance=1e-2) 194 | expect_equal(loglog_se, unname(loglog_cov$res.t[ ,4]), tolerance=1e-2) 195 | 196 | }) 197 | 198 | 199 | test_that("Weibull Mixture w/ baseline hazard", { 200 | # Weibull, Logistic 201 | # ------------------------------------------------------------------------------ 202 | # _t | Coef. Std. Err. z P>|z| [95% Conf. Interval] 203 | # -------------+---------------------------------------------------------------- 204 | # pi | 205 | # _cons | -.4589729 .1644206 -2.79 0.005 -.7812314 -.1367144 206 | # -------------+---------------------------------------------------------------- 207 | # ln_lambda | 208 | # _cons | -1.871874 .1175981 -15.92 0.000 -2.102362 -1.641386 209 | # -------------+---------------------------------------------------------------- 210 | # ln_gamma | 211 | # _cons | .4501334 .0579905 7.76 0.000 .3364742 .5637926 212 | # ------------------------------------------------------------------------------ 213 | # 214 | logistic_params <- c( -.4589729, .4501334, -1.871874) 215 | logistic_lower <- c( -.7812314, .3364742, -2.102362) 216 | logistic_upper <- c(-.1367144, .5637926, -1.641386) 217 | logistic_se <- c(.1644206 , .0579905 , .1175981) 218 | # Suppress NaN Warnings 219 | logistic_null <- suppressWarnings(flexsurvcure(Surv(recyrs, censrec)~1,data=bc,link="logistic", dist="weibullPH", bhazard=rep(0.001,686))) 220 | 221 | # Tolerance here is very permissive 222 | expect_equal(logistic_params, unname(logistic_null$res.t[ ,1]), tolerance=1e-2) 223 | expect_equal(logistic_lower, unname(logistic_null$res.t[ ,2]), tolerance=1e-2) 224 | expect_equal(logistic_upper, unname(logistic_null$res.t[ ,3]), tolerance=1e-2) 225 | expect_equal(logistic_se, unname(logistic_null$res.t[ ,4]), tolerance=1e-2) 226 | 227 | }) 228 | -------------------------------------------------------------------------------- /tests/testthat/test_surv_funcs.R: -------------------------------------------------------------------------------- 1 | test_that("Mean survival works", { 2 | 3 | # MIXTURE MODELS 4 | # Mean should be infinite for models with positive cure fraction 5 | mix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="llogis") 6 | mix_some_cured_res <- summary(mix_some_cured, type = "mean", tidy=T) 7 | expect_equal(as.numeric(mix_some_cured_res), c(Inf, Inf, Inf)) 8 | 9 | # For cure fraction = 0, mean should equal that of base distribution 10 | mix_none_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="identity", dist="exp") 11 | mix_none_cured_res <- summary(mix_none_cured, type = "mean", tidy=T) 12 | mix_none_cured_base_res <- mean_exp(mix_none_cured$res[2,1]) 13 | expect_equal(mix_none_cured_res[1,1], mix_none_cured_base_res) 14 | 15 | # NON-MIXTURE MODELS 16 | # Mean should be infinite for models with positive cure fraction 17 | nmix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="llogis", mixture = F) 18 | nmix_some_cured_res <- summary(nmix_some_cured, type = "mean", tidy=T) 19 | expect_equal(as.numeric(nmix_some_cured_res), c(Inf, Inf, Inf)) 20 | 21 | 22 | # Test case where theta is zero 23 | expect_equal( 24 | mean_nmixsurv(pgenf, 0, mu = 1.2, sigma = 0.8, Q = 0.2, P = 0.3), 25 | 0 26 | ) 27 | expect_equal( 28 | mean_mixsurv(pgenf, 0, mu = 1.2, sigma = 0.8, Q = 0.2, P = 0.3), 29 | mean_genf(1.2, 0.8, 0.2, 0.3) 30 | ) 31 | 32 | # Test with vector arguments 33 | # expect_equal( 34 | # mean_nmixsurv(pweibull, c(0.1, 0.1, 0.1), shape=c(1.2, 1.3, 1.5), scale=c(20, 21, 50)), 35 | # c(Inf, Inf, Inf) 36 | # ) 37 | # expect_equal( 38 | # mean_nmixsurv(pweibull, c(0.1), shape=c(1.2, 1.3, 1.5), scale=c(20, 21, 50)), 39 | # c(Inf, Inf, Inf) 40 | # ) 41 | # expect_equal( 42 | # mean_nmixsurv(pweibull, c(0), shape=c(1.2, 1.3, 1.5), scale=c(20, 21, 50)), 43 | # c(0, 0, 0) 44 | # ) 45 | # expect_equal( 46 | # mean_nmixsurv(pweibull, c(0, 1, 1), shape=c(1.2), scale=c(20)), 47 | # c(0, Inf, Inf) 48 | # ) 49 | # expect_error( 50 | # mean_nmixsurv(pweibull, c(0, 1, 1), shape=c(1.2, 1.3), scale=c(20, 21)), 51 | # 'Parameter values provided were of incompatible length' 52 | # ) 53 | # expect_equal( 54 | # mean_mixsurv(pweibull, c(0.1, 0.1, 0.1), shape=c(1.2, 1.3, 1.5), scale=c(20, 21, 50)), 55 | # c(Inf, Inf, Inf) 56 | # ) 57 | # expect_equal( 58 | # mean_mixsurv(pweibull, c(0.1), shape=c(1.2, 1.3, 1.5), scale=c(20, 21, 50)), 59 | # c(Inf, Inf, Inf) 60 | # ) 61 | # expect_equal( 62 | # mean_mixsurv(pweibull, c(0, 0, 0), shape=c(1.2, 1.3, 1.5), scale=c(20, 21, 50)), 63 | # c(18.81311716, 19.39511074, 45.13726464) 64 | # ) 65 | # expect_equal( 66 | # mean_mixsurv(pweibull, c(0), shape=c(1.2, 1.3, 1.5), scale=c(20, 21, 50)), 67 | # c(18.81311716, 19.39511074, 45.13726464) 68 | # ) 69 | # expect_equal( 70 | # mean_mixsurv(pweibull, c(0, 1, 1), shape=c(1.2), scale=c(20)), 71 | # c(18.81311716, Inf, Inf) 72 | # ) 73 | # expect_error( 74 | # mean_mixsurv(pweibull, c(0, 1, 1), shape=c(1.2, 1.3), scale=c(20, 21)), 75 | # 'Parameter values provided were of incompatible length' 76 | # ) 77 | 78 | }) 79 | 80 | test_that("RMST Works", { 81 | # MIXTURE MODELS 82 | # RMST should be equal to duration * theta + (1-theta) * uncured_rmst 83 | t_rmst <- 10000 84 | mix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="gompertz") 85 | mix_some_cured_res <- summary(mix_some_cured, t=t_rmst, type = "rmst", tidy=T) 86 | mix_some_cured_res_u <- rmst_gompertz( 87 | t = t_rmst, 88 | shape=mix_some_cured$res[2,1], 89 | rate=mix_some_cured$res[3,1] 90 | ) 91 | expect_equal( 92 | mix_some_cured_res$est, 93 | (1 - mix_some_cured$res[1,1]) * mix_some_cured_res_u + mix_some_cured$res[1,1] * t_rmst 94 | ) 95 | 96 | nmix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="gompertz", mix = F) 97 | nmix_some_cured_res <- summary(nmix_some_cured, t=t_rmst, type = "rmst", tidy=T) 98 | expect_equal( 99 | nmix_some_cured_res$est, 100 | integrate(function(x) pnmixsurv( 101 | pgompertz, 102 | x, 103 | nmix_some_cured$res[1,1], 104 | shape = nmix_some_cured$res[2,1], 105 | rate = nmix_some_cured$res[3,1], 106 | lower.tail = F), 0, t_rmst 107 | )$value 108 | ) 109 | }) 110 | 111 | test_that("Survival projections", { 112 | 113 | # MIXTURE MODELS 114 | # Survival should be equal to cure fraction for large values of t 115 | mix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="loglog", dist="lnorm") 116 | mix_some_cured_res <- summary(mix_some_cured, t=1e99, type = "survival", tidy=T) 117 | expect_equal(as.numeric(mix_some_cured_res)[2], as.numeric(mix_some_cured$res[1])) 118 | 119 | # NON-MIXTURE MODELS 120 | # Survival should be equal to cure fraction for large values of t 121 | nmix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="loglog", dist="lnorm", mixture=F) 122 | nmix_some_cured_res <- summary(nmix_some_cured, t=1e99, type = "survival", tidy=T) 123 | expect_equal(as.numeric(nmix_some_cured_res)[2], as.numeric(nmix_some_cured$res[1])) 124 | }) 125 | 126 | test_that("Cumulative hazard projections", { 127 | 128 | # MIXTURE MODELS 129 | # Cumulative hazard should equal -log(cure fraction) for large values of t 130 | mix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="identity", dist="weibull") 131 | mix_some_cured_res <- summary(mix_some_cured, t=1e99, type = "cumhaz", tidy=T) 132 | expect_equal(as.numeric(mix_some_cured_res)[2], -log(as.numeric(mix_some_cured$res[1]))) 133 | 134 | # NON-MIXTURE MODELS 135 | # Cumulative hazard should equal -log(cure fraction) for large values of t 136 | nmix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="identity", dist="weibull", mixture=F) 137 | nmix_some_cured_res <- summary(nmix_some_cured, t=1e99, type = "cumhaz", tidy=T) 138 | expect_equal(as.numeric(nmix_some_cured_res)[2], -log(as.numeric(nmix_some_cured$res[1]))) 139 | 140 | # MIXTURE MODELS 141 | # Cumulative hazard should flatten 142 | mix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="exp") 143 | mix_some_cured_res <- summary(mix_some_cured, t=c(9999999, 1e99), type = "cumhaz", tidy=T) 144 | expect_equal(mix_some_cured_res$est[1], mix_some_cured_res$est[2]) 145 | 146 | # NON-MIXTURE MODELS 147 | # Cumulative hazard should flatten 148 | nmix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="exp", mixture=F) 149 | nmix_some_cured_res <- summary(nmix_some_cured, t=c(9999999, 1e99), type = "cumhaz", tidy=T) 150 | expect_equal(nmix_some_cured_res$est[1], nmix_some_cured_res$est[2]) 151 | }) 152 | 153 | test_that("Hazard rate projections", { 154 | 155 | # MIXTURE MODELS 156 | # Hazard at t = Inf should be zero 157 | mix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="exp") 158 | mix_some_cured_res <- summary(mix_some_cured, t=Inf, type = "hazard", tidy=T) 159 | expect_equal(as.numeric(mix_some_cured_res)[2], 0) 160 | 161 | # NON-MIXTURE MODELS 162 | # Hazard at t = Inf should be zero 163 | nmix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="exp", mixture=F) 164 | nmix_some_cured_res <- summary(nmix_some_cured, t=Inf, type = "hazard", tidy=T) 165 | expect_equal(as.numeric(nmix_some_cured_res)[2], 0) 166 | }) 167 | 168 | test_that("Random sampling", { 169 | 170 | # MIXTURE MODELS 171 | expect_equal(mean(rmixsurv(qexp, n = 1000000, theta = 0.0, rate = 1/50)), 50, tolerance = 1e-2) 172 | expect_equal(median(rmixsurv(qexp, n = 10000000, theta = 0.20, rate = 1/50)), qexp(0.625, rate = 1/50), tolerance = 1e-1) 173 | 174 | # NON-MIXTURE MODELS 175 | expect_equal(mean(rnmixsurv(qexp, n = 1000000, theta = 0.0, rate = 1/50)), 50, tolerance = 1e-2) 176 | 177 | }) 178 | 179 | test_that("P function works with infinite input", { 180 | 181 | # MIXTURE MODELS 182 | # Hazard at t = Inf should be zero 183 | mix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="exp") 184 | mix_some_cured_res <- summary(mix_some_cured, t=Inf, type = "survival", tidy=T) 185 | expect_equal(as.numeric(mix_some_cured_res)[2], 0) 186 | 187 | # NON-MIXTURE MODELS 188 | # Hazard at t = Inf should be zero 189 | nmix_some_cured <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="logistic", dist="exp", mixture=F) 190 | nmix_some_cured_res <- summary(nmix_some_cured, t=Inf, type = "survival", tidy=T) 191 | expect_equal(as.numeric(nmix_some_cured_res)[2], 0) 192 | }) 193 | 194 | test_that("Quantile functions", { 195 | 196 | # MIXTURE MODELS 197 | expect_equal( 198 | qmixsurv(qexp, c(0.25, 0.5, 0.75), theta = 0.2, rate = 1/50), 199 | qgeneric(function(...) pmixsurv(pexp, ...), c(0.25, 0.5, 0.75), theta = 0.2, rate = 1/50), 200 | tolerance = 1e-4 201 | ) 202 | 203 | expect_equal( 204 | qmixsurv(qweibull, c(0.25, 0.5, 0.75), theta = 0.15, shape = 1.2, scale = 50), 205 | qgeneric(function(...) pmixsurv(pweibull, ...), c(0.25, 0.5, 0.75), theta = 0.15, shape = 1.2, scale = 50), 206 | tolerance = 1e-4 207 | ) 208 | 209 | # NON-MIXTURE MODELS 210 | expect_equal( 211 | qnmixsurv(qexp, c(0.25, 0.5, 0.75), theta = 0.2, rate = 1/50), 212 | qgeneric(function(...) pnmixsurv(pexp, ...), c(0.25, 0.5, 0.75), theta = 0.2, rate = 1/50), 213 | tolerance = 1e-4 214 | ) 215 | 216 | expect_equal( 217 | qnmixsurv(qweibull, c(0.25, 0.5, 0.75), theta = 0.15, shape = 1.2, scale = 50), 218 | qgeneric(function(...) pnmixsurv(pweibull, ...), c(0.25, 0.5, 0.75), theta = 0.15, shape = 1.2, scale = 50), 219 | tolerance = 1e-4 220 | ) 221 | 222 | }) 223 | 224 | test_that("Probit link works", { 225 | probit_model <- flexsurvcure(Surv(rectime, censrec)~1,data=bc,link="probit", dist="llogis") 226 | expect_equal(probit_model$res.t[1,1], qnorm(probit_model$res[1,1])) 227 | expect_equal(probit_model$res[1,1], pnorm(probit_model$res.t[1,1])) 228 | }) 229 | 230 | 231 | -------------------------------------------------------------------------------- /tests/testthat/testthat-problems.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jrdnmdhl/flexsurvcure/eec8afa4d180a9aeed0d23854fa135159b064d48/tests/testthat/testthat-problems.rds -------------------------------------------------------------------------------- /vignettes/flexsurvcure.R: -------------------------------------------------------------------------------- 1 | ## ---- warning=FALSE, message=FALSE--------------------------------------- 2 | library(flexsurvcure) 3 | cure_model <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="logistic", dist="weibullPH", mixture=T) 4 | print(cure_model) 5 | 6 | ## ---- warning=FALSE, message=FALSE--------------------------------------- 7 | plot(cure_model) 8 | 9 | ## ---- warning=FALSE, message=FALSE--------------------------------------- 10 | summary(cure_model, t=seq(from=0,to=3000,by=1000), type="survival", tidy=T) 11 | 12 | ## ---- warning=FALSE, message=FALSE--------------------------------------- 13 | cure_model_complex <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="logistic", dist="weibullPH", mixture=T, anc=list(scale=~group)) 14 | print(cure_model_complex) 15 | plot(cure_model_complex) 16 | 17 | ## ---- warning=FALSE, message=FALSE--------------------------------------- 18 | library(flexsurvcure) 19 | cure_model_nmix <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="loglog", dist="weibullPH", mixture=F) 20 | print(cure_model_nmix) 21 | 22 | -------------------------------------------------------------------------------- /vignettes/flexsurvcure.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Parametric Cure Models" 3 | author: "Jordan Amdahl" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Parametric Cure Models} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | # Introduction 13 | 14 | Parametric cure models are a type of parametric survival model model in which it is assumed that there are a proportion of subjects who will not experience the event. In a mixture cure model, these 'cured' and 'uncured' subjects are modeled separately, with the cured individuals subject to no excess risk and the uncured individuals subject to excess risk modeled using a parametric survival distribution. In a non-mixture model, a parametric survival distribution is scaled such that survival asymptotically approaches the cure fraction. 15 | 16 | 17 | # Mixture Cure Model 18 | 19 | The following code fits a mixture cure model to the `bc` dataset from `flexsurv` using a Weibull distribution and a logistic link function for the cure fraction: 20 | 21 | ```{r, warning=FALSE, message=FALSE} 22 | library(flexsurvcure) 23 | cure_model <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="logistic", dist="weibullPH", mixture=T) 24 | print(cure_model) 25 | ``` 26 | 27 | Model results can be displayed graphically using the `plot` S3 method: 28 | ```{r, warning=FALSE, message=FALSE} 29 | plot(cure_model) 30 | ``` 31 | 32 | Predicted survival probabilities can also be generated using the `summary` S3 method: 33 | ```{r, warning=FALSE, message=FALSE} 34 | summary(cure_model, t=seq(from=0,to=3000,by=1000), type="survival", tidy=T) 35 | ``` 36 | 37 | More complex models may be fitted by adding covariates to the parametric distribution used to model the uncured individuals. This is done by passing a list of formula, named according to the parameters affected, through the anc argument: 38 | ```{r, warning=FALSE, message=FALSE} 39 | cure_model_complex <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="logistic", dist="weibullPH", mixture=T, anc=list(scale=~group)) 40 | print(cure_model_complex) 41 | plot(cure_model_complex) 42 | ``` 43 | 44 | # Non-Mixture Cure Model 45 | 46 | Non-mixture cure models can be fit by passing `mixture=FALSE` to `flexsurvcure`: 47 | 48 | ```{r, warning=FALSE, message=FALSE} 49 | library(flexsurvcure) 50 | cure_model_nmix <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="loglog", dist="weibullPH", mixture=F) 51 | print(cure_model_nmix) 52 | ``` 53 | -------------------------------------------------------------------------------- /vignettes/flexsurvcure.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | Parametric Cure Models 18 | 19 | 20 | 21 | 22 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 |

Parametric Cure Models

72 |

Jordan Amdahl

73 |

2017-05-13

74 | 75 | 76 | 77 |
78 |

Introduction

79 |

Parametric cure models are a type of parametric survival model model in wich it is assumed that there are a proportion of subjects who will not experience the event. In a mixture cure model, these ‘cured’ and ‘uncured’ subjects are modeled separately, with the cured individuals subject to no excess risk and the uncured individuals subject to excess risk modeled using a parametric survival distribution. In a non-mixture model, a parametric survival distribution is scaled such that survival asymtpotically approaches the cure fraction.

80 |
81 |
82 |

Mixture Cure Model

83 |

The following code fits a mixture cure model to the bc dataset from flexsurv using a Weibull distribution and a logistic link function for the cure fraction:

84 | 
library(flexsurvcure)
 85 | cure_model <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="logistic", dist="weibullPH", mixture=T)
 86 | print(cure_model)
87 | 
## Call:
 88 | ## flexsurvcure(formula = Surv(rectime, censrec) ~ group, data = bc, 
 89 | ##     dist = "weibullPH", link = "logistic", mixture = T)
 90 | ## 
 91 | ## Estimates: 
 92 | ##              data mean  est        L95%       U95%       se       
 93 | ## theta               NA   6.73e-01   5.84e-01   7.52e-01         NA
 94 | ## shape               NA   1.55e+00   1.38e+00   1.74e+00   9.07e-02
 95 | ## scale               NA   1.61e-05   5.10e-06   5.11e-05   9.50e-06
 96 | ## groupMedium   3.34e-01  -1.23e+00  -1.74e+00  -7.09e-01   2.64e-01
 97 | ## groupPoor     3.32e-01  -3.48e+00  -5.56e+00  -1.40e+00   1.06e+00
 98 | ##              exp(est)   L95%       U95%     
 99 | ## theta               NA         NA         NA
100 | ## shape               NA         NA         NA
101 | ## scale               NA         NA         NA
102 | ## groupMedium   2.93e-01   1.75e-01   4.92e-01
103 | ## groupPoor     3.08e-02   3.85e-03   2.47e-01
104 | ## 
105 | ## N = 686,  Events: 299,  Censored: 387
106 | ## Total time at risk: 771400
107 | ## Log-likelihood = -2580.012, df = 5
108 | ## AIC = 5170.025
109 |

Model results can be displayed graphically using the plot S3 method:

110 | 
plot(cure_model)
111 |

112 |

Predicted survival probabilities can also be generated using the summary S3 method:

113 | 
summary(cure_model, t=seq(from=0,to=3000,by=1000), type="survival", tidy=T)
114 | 
##    time        est        lcl       ucl  group
115 | ## 1     0 1.00000000 1.00000000 1.0000000   Good
116 | ## 2  1000 0.83251996 0.78794893 0.8682121   Good
117 | ## 3  2000 0.71313032 0.64254969 0.7730739   Good
118 | ## 4  3000 0.67959584 0.59365701 0.7532308   Good
119 | ## 5     0 1.00000000 1.00000000 1.0000000 Medium
120 | ## 6  1000 0.68057306 0.63324324 0.7252038 Medium
121 | ## 7  2000 0.45286672 0.38958039 0.5329925 Medium
122 | ## 8  3000 0.38890796 0.31082558 0.4938763 Medium
123 | ## 9     0 1.00000000 1.00000000 1.0000000   Poor
124 | ## 10 1000 0.51803653 0.46976241 0.6316741   Poor
125 | ## 11 2000 0.17446456 0.12733565 0.4040555   Poor
126 | ## 12 3000 0.07796116 0.03767643 0.3615323   Poor
127 |

More complex models may be fitted by adding covariates to the parametric distribution used to model the uncured individuals. This is done by passing a list of formula, named according to the parameters affected, through the anc argument:

128 | 
cure_model_complex <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="logistic", dist="weibullPH", mixture=T, anc=list(scale=~group))
129 | print(cure_model_complex)
130 | 
## Call:
131 | ## flexsurvcure(formula = Surv(rectime, censrec) ~ group, data = bc, 
132 | ##     dist = "weibullPH", link = "logistic", mixture = T, anc = list(scale = ~group))
133 | ## 
134 | ## Estimates: 
135 | ##                     data mean  est        L95%       U95%       se       
136 | ## theta                      NA   2.62e-02         NA         NA         NA
137 | ## shape                      NA   1.49e+00         NA         NA         NA
138 | ## scale                      NA   4.65e-06         NA         NA         NA
139 | ## groupMedium          3.34e-01  -1.78e+00         NA         NA         NA
140 | ## groupPoor            3.32e-01   2.07e+00         NA         NA         NA
141 | ## scale(groupMedium)   3.34e-01   8.29e-01         NA         NA         NA
142 | ## scale(groupPoor)     3.32e-01   2.11e+00         NA         NA         NA
143 | ##                     exp(est)   L95%       U95%     
144 | ## theta                      NA         NA         NA
145 | ## shape                      NA         NA         NA
146 | ## scale                      NA         NA         NA
147 | ## groupMedium          1.69e-01         NA         NA
148 | ## groupPoor            7.96e+00         NA         NA
149 | ## scale(groupMedium)   2.29e+00         NA         NA
150 | ## scale(groupPoor)     8.22e+00         NA         NA
151 | ## 
152 | ## N = 686,  Events: 299,  Censored: 387
153 | ## Total time at risk: 771400
154 | ## Log-likelihood = -2571.857, df = 7
155 | ## AIC = 5157.713
156 | 
plot(cure_model_complex)
157 |

158 |
159 |
160 |

Non-Mixture Cure Model

161 |

Non-mixture cure models can be fit by passing mixture=FALSE to flexsurvcure:

162 | 
library(flexsurvcure)
163 | cure_model_nmix <- flexsurvcure(Surv(rectime, censrec)~group, data=bc, link="loglog", dist="weibullPH", mixture=F)
164 | print(cure_model_nmix)
165 | 
## Call:
166 | ## flexsurvcure(formula = Surv(rectime, censrec) ~ group, data = bc, 
167 | ##     dist = "weibullPH", link = "loglog", mixture = F)
168 | ## 
169 | ## Estimates: 
170 | ##              data mean  est       L95%      U95%      se        exp(est)
171 | ## theta              NA   6.35e-01  7.31e-01  5.17e-01        NA        NA
172 | ## shape              NA   1.72e+00  1.53e+00  1.92e+00  1.01e-01        NA
173 | ## scale              NA   3.07e-06  9.19e-07  1.03e-05  1.89e-06        NA
174 | ## groupMedium  3.34e-01   8.35e-01  4.99e-01  1.17e+00  1.71e-01  2.31e+00
175 | ## groupPoor    3.32e-01   1.63e+00  1.31e+00  1.95e+00  1.64e-01  5.09e+00
176 | ##              L95%      U95%    
177 | ## theta              NA        NA
178 | ## shape              NA        NA
179 | ## scale              NA        NA
180 | ## groupMedium  1.65e+00  3.22e+00
181 | ## groupPoor    3.69e+00  7.02e+00
182 | ## 
183 | ## N = 686,  Events: 299,  Censored: 387
184 | ## Total time at risk: 771400
185 | ## Log-likelihood = -2567.8, df = 5
186 | ## AIC = 5145.6
187 |
188 | 189 | 190 | 191 | 192 | 200 | 201 | 202 | 203 | --------------------------------------------------------------------------------