From 3e4f6121a7c7bb38ae43c8ff492ec7bd5f7c0232 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 11:00:08 +1100 Subject: [PATCH 001/225] Add surv.stan with Stan hazard functions --- .../functions/hazard_functions.stan | 112 +++ src/stan_files/surv.stan | 790 ++++++++++++++++++ 2 files changed, 902 insertions(+) create mode 100644 src/stan_files/functions/hazard_functions.stan create mode 100644 src/stan_files/surv.stan diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan new file mode 100644 index 000000000..710bfbcd7 --- /dev/null +++ b/src/stan_files/functions/hazard_functions.stan @@ -0,0 +1,112 @@ + /** + * Log hazard for exponential distribution + * + * @param eta Vector, linear predictor + * @return A vector + */ + vector exponential_log_haz(vector eta) { + return eta; + } + + /** + * Log hazard for Weibull distribution + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param shape Real, Weibull shape + * @return A vector + */ + vector weibull_log_haz(vector eta, vector t, real shape) { + vector[rows(eta)] res; + res = log(shape) + (shape - 1) * log(t) + eta; + return res; + } + + /** + * Log hazard for Gompertz distribution + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param scale Real, Gompertz scale + * @return A vector + */ + vector gompertz_log_haz(vector eta, vector t, real scale) { + vector[rows(eta)] res; + res = scale * t + eta; + return res; + } + + /** + * Log hazard for M-spline model + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param coefs Vector, M-spline coefficients + * @return A vector + */ + vector mspline_log_haz(vector eta, matrix basis, vector coefs) { + vector[rows(eta)] res; + res = log(basis * coefs) + eta; + return res; + } + + /** + * Log hazard for B-spline model + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param coefs Vector, B-spline coefficients + * @return A vector + */ + vector bspline_log_haz(vector eta, matrix basis, vector coefs) { + vector[rows(eta)] res; + res = basis * coefs + eta; + return res; + } + + /** + * Evaluate log survival or log CDF from the log hazard evaluated at + * quadrature points and a corresponding vector of quadrature weights + * + * @param qwts Vector, the quadrature weights + * @param log_hazard Vector, log hazard at the quadrature points + * @param qnodes Integer, the number of quadrature points for each individual + * @return A vector + */ + real quadrature_log_surv(vector qwts, vector log_hazard) { + real res; + res = - dot_product(qwts, exp(log_hazard)); // sum across all individuals + return res; + } + + vector quadrature_log_cdf(vector qwts, vector log_hazard, int qnodes) { + int M = rows(log_hazard); + int N = M / qnodes; // num of individuals + vector[M] hazard = exp(log_hazard); + matrix[N,qnodes] qwts_mat = to_matrix(qwts, N, qnodes); + matrix[N,qnodes] haz_mat = to_matrix(hazard, N, qnodes); + vector[N] chaz = rows_dot_product(qwts_mat, haz_mat); + vector[N] res; + res = log(1 - exp(- chaz)); + return res; + } + + vector quadrature_log_cdf2(vector qwts_lower, vector log_hazard_lower, + vector qwts_upper, vector log_hazard_upper, + int qnodes) { + int M = rows(log_hazard_lower); + int N = M / qnodes; // num of individuals + vector[M] hazard_lower = exp(log_hazard_lower); + vector[M] hazard_upper = exp(log_hazard_upper); + matrix[N,qnodes] qwts_lower_mat = to_matrix(qwts_lower, N, qnodes); + matrix[N,qnodes] qwts_upper_mat = to_matrix(qwts_lower, N, qnodes); + matrix[N,qnodes] haz_lower_mat = to_matrix(hazard_lower, N, qnodes); + matrix[N,qnodes] haz_upper_mat = to_matrix(hazard_upper, N, qnodes); + vector[N] chaz_lower = rows_dot_product(qwts_lower_mat, haz_lower_mat); + vector[N] chaz_upper = rows_dot_product(qwts_upper_mat, haz_upper_mat); + vector[N] surv_lower = exp(- chaz_lower); + vector[N] surv_upper = exp(- chaz_upper); + vector[N] res; + res = log(surv_lower - surv_upper); + return res; + } diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan new file mode 100644 index 000000000..97e1959fe --- /dev/null +++ b/src/stan_files/surv.stan @@ -0,0 +1,790 @@ +#include /pre/Columbia_copyright.stan +#include /pre/Brilleman_copyright.stan +#include /pre/license.stan + +functions { + +#include /functions/hazard_functions.stan + + /** + * Hierarchical shrinkage parameterization + * + * @param z_beta A vector of primitive coefficients + * @param global A real array of positive numbers + * @param local A vector array of positive numbers + * @param global_prior_scale A positive real number + * @param error_scale 1 or sigma in the Gaussian case + * @param c2 A positive real number + * @return A vector of coefficientes + */ + vector hs_prior(vector z_beta, real[] global, vector[] local, + real global_prior_scale, real error_scale, real c2) { + int K = rows(z_beta); + vector[K] lambda = local[1] .* sqrt(local[2]); + real tau = global[1] * sqrt(global[2]) * global_prior_scale * error_scale; + vector[K] lambda2 = square(lambda); + vector[K] lambda_tilde = sqrt( c2 * lambda2 ./ (c2 + square(tau) * lambda2) ); + return z_beta .* lambda_tilde * tau; + } + + /** + * Hierarchical shrinkage plus parameterization + * + * @param z_beta A vector of primitive coefficients + * @param global A real array of positive numbers + * @param local A vector array of positive numbers + * @param global_prior_scale A positive real number + * @param error_scale 1 or sigma in the Gaussian case + * @param c2 A positive real number + * @return A vector of coefficientes + */ + vector hsplus_prior(vector z_beta, real[] global, vector[] local, + real global_prior_scale, real error_scale, real c2) { + int K = rows(z_beta); + vector[K] lambda = local[1] .* sqrt(local[2]); + vector[K] eta = local[3] .* sqrt(local[4]); + real tau = global[1] * sqrt(global[2]) * global_prior_scale * error_scale; + vector[K] lambda_eta2 = square(lambda .* eta); + vector[K] lambda_tilde = sqrt( c2 * lambda_eta2 ./ + ( c2 + square(tau) * lambda_eta2) ); + return z_beta .* lambda_tilde * tau; + } + + /** + * Cornish-Fisher expansion for standard normal to Student t + * + * See result 26.7.5 of + * http://people.math.sfu.ca/~cbm/aands/page_949.htm + * + * @param z A scalar distributed standard normal + * @param df A scalar degrees of freedom + * @return An (approximate) Student t variate with df degrees of freedom + */ + real CFt(real z, real df) { + real z2 = square(z); + real z3 = z2 * z; + real z5 = z2 * z3; + real z7 = z2 * z5; + real z9 = z2 * z7; + real df2 = square(df); + real df3 = df2 * df; + real df4 = df2 * df2; + return z + (z3 + z) / (4 * df) + (5 * z5 + 16 * z3 + 3 * z) / (96 * df2) + + (3 * z7 + 19 * z5 + 17 * z3 - 15 * z) / (384 * df3) + + (79 * z9 + 776 * z7 + 1482 * z5 - 1920 * z3 - 945 * z) / (92160 * df4); + } + + /** + * Return the lower bound for the baseline hazard parameters + * + * @param type An integer indicating the type of baseline hazard + * @return A real + */ + real coefs_lb(int type) { + real lb; + if (type == 2) // B-splines, on log haz scale + lb = negative_infinity(); + else if (type == 3) // piecewise constant, on log haz scale + lb = negative_infinity(); + else + lb = 0; + return lb; + } + + /** + * Return the required number of local hs parameters + * + * @param prior_dist An integer indicating the prior distribution + * @return An integer + */ + int get_nvars_for_hs(int prior_dist) { + int hs = 0; + if (prior_dist == 3) hs = 2; + else if (prior_dist == 4) hs = 4; + return hs; + } + + /** + * Scale the primitive population level parameters based on prior information + * + * @param z_beta A vector of primitive parameters + * @param prior_dist Integer, the type of prior distribution + * @param prior_mean,prior_scale Vectors of mean and scale parameters + * for the prior distributions + * @return A vector containing the population level parameters (coefficients) + */ + vector make_beta(vector z_beta, int prior_dist, vector prior_mean, + vector prior_scale, vector prior_df, real global_prior_scale, + real[] global, vector[] local, real[] ool, vector[] mix, + real[] aux, int family, real slab_scale, real[] caux) { + vector[rows(z_beta)] beta; + if (prior_dist == 0) beta = z_beta; + else if (prior_dist == 1) beta = z_beta .* prior_scale + prior_mean; + else if (prior_dist == 2) for (k in 1:rows(prior_mean)) { + beta[k] = CFt(z_beta[k], prior_df[k]) * prior_scale[k] + prior_mean[k]; + } + else if (prior_dist == 3) { + real c2 = square(slab_scale) * caux[1]; + if (family == 1) // don't need is_continuous since family == 1 is gaussian in mvmer + beta = hs_prior(z_beta, global, local, global_prior_scale, aux[1], c2); + else + beta = hs_prior(z_beta, global, local, global_prior_scale, 1, c2); + } + else if (prior_dist == 4) { + real c2 = square(slab_scale) * caux[1]; + if (family == 1) // don't need is_continuous since family == 1 is gaussian in mvmer + beta = hsplus_prior(z_beta, global, local, global_prior_scale, aux[1], c2); + else + beta = hsplus_prior(z_beta, global, local, global_prior_scale, 1, c2); + } + else if (prior_dist == 5) // laplace + beta = prior_mean + prior_scale .* sqrt(2 * mix[1]) .* z_beta; + else if (prior_dist == 6) // lasso + beta = prior_mean + ool[1] * prior_scale .* sqrt(2 * mix[1]) .* z_beta; + return beta; + } + + /** + * Log-prior for coefficients + * + * @param z_beta Vector of primative coefficients + * @param prior_dist Integer, the type of prior distribution + * @param prior_scale Real, scale for the prior distribution + * @param prior_df Real, df for the prior distribution + * @param global_prior_df Real, df for the prior for the global hs parameter + * @param local Vector of hs local parameters + * @param global Real, the global parameter + * @param mix Vector of shrinkage parameters + * @param one_over_lambda Real + * @return nothing + */ + void beta_lp(vector z_beta, int prior_dist, vector prior_scale, + vector prior_df, real global_prior_df, vector[] local, + real[] global, vector[] mix, real[] one_over_lambda, + real slab_df, real[] caux) { + if (prior_dist == 1) target += normal_lpdf(z_beta | 0, 1); + else if (prior_dist == 2) target += normal_lpdf(z_beta | 0, 1); // Student t + else if (prior_dist == 3) { // hs + target += normal_lpdf(z_beta | 0, 1); + target += normal_lpdf(local[1] | 0, 1); + target += inv_gamma_lpdf(local[2] | 0.5 * prior_df, 0.5 * prior_df); + target += normal_lpdf(global[1] | 0, 1); + target += inv_gamma_lpdf(global[2] | 0.5 * global_prior_df, 0.5 * global_prior_df); + target += inv_gamma_lpdf(caux | 0.5 * slab_df, 0.5 * slab_df); + } + else if (prior_dist == 4) { // hs+ + target += normal_lpdf(z_beta | 0, 1); + target += normal_lpdf(local[1] | 0, 1); + target += inv_gamma_lpdf(local[2] | 0.5 * prior_df, 0.5 * prior_df); + target += normal_lpdf(local[3] | 0, 1); + // unorthodox useage of prior_scale as another df hyperparameter + target += inv_gamma_lpdf(local[4] | 0.5 * prior_scale, 0.5 * prior_scale); + target += normal_lpdf(global[1] | 0, 1); + target += inv_gamma_lpdf(global[2] | 0.5 * global_prior_df, 0.5 * global_prior_df); + target += inv_gamma_lpdf(caux | 0.5 * slab_df, 0.5 * slab_df); + } + else if (prior_dist == 5) { // laplace + target += normal_lpdf(z_beta | 0, 1); + target += exponential_lpdf(mix[1] | 1); + } + else if (prior_dist == 6) { // lasso + target += normal_lpdf(z_beta | 0, 1); + target += exponential_lpdf(mix[1] | 1); + target += chi_square_lpdf(one_over_lambda[1] | prior_df[1]); + } + else if (prior_dist == 7) { // product_normal + target += normal_lpdf(z_beta | 0, 1); + } + /* else prior_dist is 0 and nothing is added */ + } + + /** + * Log-prior for intercept parameters + * + * @param gamma Real, the intercept parameter + * @param dist Integer, the type of prior distribution + * @param mean Real, mean of prior distribution + * @param scale Real, scale for the prior distribution + * @param df Real, df for the prior distribution + * @return nothing + */ + void gamma_lp(real gamma, int dist, real mean, real scale, real df) { + if (dist == 1) // normal + target += normal_lpdf(gamma | mean, scale); + else if (dist == 2) // student_t + target += student_t_lpdf(gamma | df, mean, scale); + /* else dist is 0 and nothing is added */ + } + + /** + * Log-prior for baseline hazard parameters + * + * @param aux_unscaled Vector (potentially of length 1) of unscaled + * auxiliary parameter(s) + * @param dist Integer specifying the type of prior distribution + * @param df Real specifying the df for the prior distribution + * @return nothing + */ + void basehaz_lp(vector aux_unscaled, int dist, vector df) { + if (dist > 0) { + if (dist == 1) + target += normal_lpdf(aux_unscaled | 0, 1); + else if (dist == 2) + target += student_t_lpdf(aux_unscaled | df, 0, 1); + else + target += exponential_lpdf(aux_unscaled | 1); + } + } + + /** + * Log-prior for tde spline coefficients and their smoothing parameters + * + * @param z_beta_tde Vector of unscaled spline coefficients + * @param smooth_sd_raw Vector (potentially of length 1) of smoothing sds + * @param dist Integer specifying the type of prior distribution for the + * smoothing sds + * @param df Vector of reals specifying the df for the prior distribution + * for the smoothing sds + * @return nothing + */ + void smooth_lp(vector z_beta_tde, vector smooth_sd_raw, int dist, vector df) { + target += normal_lpdf(z_beta_tde | 0, 1); + if (dist > 0) { + real log_half = -0.693147180559945286; + if (dist == 1) + target += normal_lpdf(smooth_sd_raw | 0, 1) - log_half; + else if (dist == 2) + target += student_t_lpdf(smooth_sd_raw | df, 0, 1) - log_half; + else if (dist == 3) + target += exponential_lpdf(smooth_sd_raw | 1); + } + } + + /** + * Raise each element of x to the power of y + * + * @param x Vector + * @param y Real, the power to raise to + * @return vector + */ + vector pow_vec(vector x, real y) { + int N = rows(x); + vector[N] res; + for (n in 1:N) + res[n] = pow(x[n], y); + return res; + } + + /** + * Log survival and log CDF for exponential distribution + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @return A vector + */ + vector exponential_log_surv(vector eta, vector t) { + vector[rows(eta)] res; + res = - t .* exp(eta); + return res; + } + + vector exponential_log_cdf(vector eta, vector t) { + vector[rows(eta)] res; + res = log(1 - exp(-t .* exp(eta))); + return res; + } + + vector exponential_log_cdf2(vector eta, vector t_lower, vector t_upper) { + int N = rows(eta); + vector[N] exp_eta = exp(eta); + vector[N] surv_lower = exp(-t_lower .* exp_eta); + vector[N] surv_upper = exp(-t_upper .* exp_eta); + vector[N] res; + res = log(surv_lower - surv_upper); + return res; + } + + /** + * Log survival and log CDF for Weibull distribution + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param shape Real, Weibull shape + * @return A vector + */ + vector weibull_log_surv(vector eta, vector t, real shape) { + vector[rows(eta)] res; + res = - pow_vec(t, shape) .* exp(eta); + return res; + } + + vector weibull_log_cdf(vector eta, vector t, real shape) { + vector[rows(eta)] res; + res = log(1 - exp(- pow_vec(t, shape) .* exp(eta))); + return res; + } + + vector weibull_log_cdf2(vector eta, vector t_lower, vector t_upper, real shape) { + int N = rows(eta); + vector[N] exp_eta = exp(eta); + vector[N] surv_lower = exp(- pow_vec(t_lower, shape) .* exp_eta); + vector[N] surv_upper = exp(- pow_vec(t_upper, shape) .* exp_eta); + vector[N] res; + res = log(surv_lower - surv_upper); + return res; + } + + /** + * Log survival and log CDF for Gompertz distribution + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param scale Real, Gompertz scale + * @return A vector + */ + vector gompertz_log_surv(vector eta, vector t, real scale) { + vector[rows(eta)] res; + res = inv(scale) * -(exp(scale * t) - 1) .* exp(eta); + return res; + } + + vector gompertz_log_cdf(vector eta, vector t, real scale) { + vector[rows(eta)] res; + res = log(1 - exp(inv(scale) * -(exp(scale * t) - 1) .* exp(eta))); + return res; + } + + vector gompertz_log_cdf2(vector eta, vector t_lower, vector t_upper, real scale) { + int N = rows(eta); + real inv_scale = inv(scale); + vector[N] exp_eta = exp(eta); + vector[N] surv_lower = exp(inv_scale * -(exp(scale * t_lower) - 1) .* exp_eta); + vector[N] surv_upper = exp(inv_scale * -(exp(scale * t_upper) - 1) .* exp_eta); + vector[N] res; + res = log(surv_lower - surv_upper); + return res; + } + + /** + * Log survival and log CDF for M-spline model + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param coefs Vector, M-spline coefficients + * @return A vector + */ + vector mspline_log_surv(vector eta, matrix ibasis, vector coefs) { + vector[rows(eta)] res; + res = - (ibasis * coefs) .* exp(eta); + return res; + } + + vector mspline_log_cdf(vector eta, matrix ibasis, vector coefs) { + vector[rows(eta)] res; + res = log(1 - exp(-(ibasis * coefs) .* exp(eta))); + return res; + } + + vector mspline_log_cdf2(vector eta, matrix ibasis_lower, matrix ibasis_upper, vector coefs) { + int N = rows(eta); + vector[N] exp_eta = exp(eta); + vector[N] surv_lower = exp(-(ibasis_lower * coefs) .* exp_eta); + vector[N] surv_upper = exp(-(ibasis_upper * coefs) .* exp_eta); + vector[N] res; + res = log(surv_lower - surv_upper); + return res; + } + +} + +data { + + // dimensions + int K; // num. cols in predictor matrix (time-fixed) + int S; // num. cols in predictor matrix (time-varying) + int nevent; // num. rows w/ an event (ie. not censored) + int nlcens; // num. rows w/ left censoring + int nrcens; // num. rows w/ right censoring + int nicens; // num. rows w/ interval censoring + int ndelay; // num. rows w/ delayed entry + int qnodes; // num. nodes for GK quadrature + int Nevent; // num. rows w/ an event, used only in model w/ quadrature + int qevent; // num. quadrature points for rows w/ an event + int qlcens; // num. quadrature points for rows w/ left censoring + int qrcens; // num. quadrature points for rows w/ right censoring + int qicens; // num. quadrature points for rows w/ interval censoring + int qdelay; // num. quadrature points for rows w/ delayed entry + int nvars; // num. aux parameters for baseline hazard + int smooth_map[S]; // indexing of smooth sds for tde spline coefs + int smooth_idx[S > 0 ? max(smooth_map) : 0, 2]; + int idx_cpts[7,2]; // index for breaking cpts into epts,qpts_event,etc + int len_cpts; + + // response and time variables + vector[nevent] t_event; // time of events + vector[nlcens] t_lcens; // time of left censoring + vector[nrcens] t_rcens; // time of right censoring + vector[nicens] t_icenl; // time of lower limit for interval censoring + vector[nicens] t_icenu; // time of upper limit for interval censoring + vector[ndelay] t_delay; // time of entry for delayed entry + vector[len_cpts] cpts; // time at events and all quadrature points + + // predictor matrices (time-fixed) + matrix[nevent,K] x_event; // for rows with events + matrix[nlcens,K] x_lcens; // for rows with left censoring + matrix[nrcens,K] x_rcens; // for rows with right censoring + matrix[nicens,K] x_icens; // for rows with interval censoring + matrix[ndelay,K] x_delay; // for rows with delayed entry + matrix[len_cpts,K] x_cpts; // for rows at events and all quadrature points + + // predictor matrices (time-varying) + matrix[len_cpts,S] s_cpts; // for rows at events and all quadrature points + + // basis matrices for M-splines + matrix[nevent,nvars] basis_event; // at event time + matrix[len_cpts,nvars] basis_cpts; // at event times and all quadrature points + + // basis matrices for I-splines + matrix[nevent,nvars] ibasis_event; // at event time + matrix[nlcens,nvars] ibasis_lcens; // at left censoring time + matrix[nrcens,nvars] ibasis_rcens; // at right censoring time + matrix[nicens,nvars] ibasis_icenl; // at lower limit of interval censoring + matrix[nicens,nvars] ibasis_icenu; // at upper limit of interval censoring + matrix[ndelay,nvars] ibasis_delay; // at delayed entry time + + // baseline hazard type: + // 1 = weibull + // 2 = B-splines + // 3 = piecewise + // 4 = M-splines + // 5 = exponential + // 6 = gompertz + int type; + + // GK quadrature weights, with (b-a)/2 scaling already incorporated + vector[qevent] qwts_event; + vector[qlcens] qwts_lcens; + vector[qrcens] qwts_rcens; + vector[qicens] qwts_icenl; + vector[qicens] qwts_icenu; + vector[qdelay] qwts_delay; + + // flags + int has_quadrature;// log surv is calculated using quadrature + int has_intercept; // basehaz requires intercept + int prior_PD; // draw only from prior predictive dist. + + // prior family: + // 0 = none + // 1 = normal + // 2 = student_t + // 3 = hs + // 4 = hs_plus + // 5 = laplace + // 6 = lasso + int prior_dist; + + // prior family: + // 0 = none + // 1 = normal + // 2 = student_t + int prior_dist_for_intercept; + + // prior family: + // 0 = none + // 1 = normal + // 2 = student_t + // 3 = exponential + int prior_dist_for_aux; + + // prior family: + // 0 = none + // 1 = normal + // 2 = student_t + // 3 = exponential + int prior_dist_for_smooth; + + // hyperparameter (log hazard ratios), set to 0 if there is no prior + vector[K] prior_mean; + vector[K] prior_scale; + vector[K] prior_df; + real global_prior_scale; // for hs priors only + real global_prior_df; + real slab_scale; + real slab_df; + + // hyperparameters (intercept), set to 0 if there is no prior + real prior_mean_for_intercept; + real prior_scale_for_intercept; + real prior_df_for_intercept; + + // hyperparameters (basehaz pars), set to 0 if there is no prior + vector[nvars] prior_scale_for_aux; + vector[nvars] prior_df_for_aux; + + // hyperparameters (tde smooths), set to 0 if there is no prior + vector [S > 0 ? max(smooth_map) : 0] prior_mean_for_smooth; + vector[S > 0 ? max(smooth_map) : 0] prior_scale_for_smooth; + vector[S > 0 ? max(smooth_map) : 0] prior_df_for_smooth; + +} + +transformed data { + + int hs = get_nvars_for_hs(prior_dist); + +} + +parameters { + + // primitive log hazard ratios + vector[K] z_beta; + + // intercept + real gamma[has_intercept == 1]; + + // unscaled basehaz parameters + // exp model: nvars = 0, ie. no aux parameter + // weibull model: nvars = 1, ie. shape parameter + // gompertz model: nvars = 1, ie. scale parameter + // M-spline model: nvars = number of basis terms, ie. spline coefs + // B-spline model: nvars = number of basis terms, ie. spline coefs + vector[nvars] z_coefs; + + // unscaled tde spline coefficients + vector[S] z_beta_tde; + + // hyperparameter, the prior sd for the tde spline coefs + vector[S > 0 ? max(smooth_map) : 0] smooth_sd_raw; + + // parameters for priors + real global[hs]; + vector[hs > 0 ? K : 0] local[hs]; + real caux[hs > 0]; + vector[K] mix[prior_dist == 5 || prior_dist == 6]; + real ool[prior_dist == 6]; +} + +transformed parameters { + + // log hazard ratios + vector[K] beta; + + // basehaz parameters + vector[nvars] coefs; + + // tde spline coefficients and their hyperparameters + vector[S] beta_tde; + vector[S > 0 ? max(smooth_map) : 0] smooth_sd; // sd for tde splines + + // define log hazard ratios + if (K > 0) { + beta = make_beta(z_beta, prior_dist, prior_mean, + prior_scale, prior_df, global_prior_scale, + global, local, ool, mix, rep_array(1.0, 0), 0, + slab_scale, caux); + } + + // define basehaz parameters + if (nvars > 0) { + coefs = z_coefs .* prior_scale_for_aux; + } + + // define tde spline coefficients using random walk + if (S > 0) { + smooth_sd = smooth_sd_raw .* prior_scale_for_smooth + prior_mean_for_smooth; + for (i in 1:max(smooth_map)) { + int beg = smooth_idx[i,1]; // index of first spline coef + int end = smooth_idx[i,2]; // index of last spline coef + beta_tde[beg] = z_beta_tde[beg]; // define first spline coef + if (end > beg) { // define subsequent spline coefs + for (j in (beg+1):end) { + beta_tde[j] = beta_tde[j-1] + z_beta_tde[j] * smooth_sd[smooth_map[j]]; + } + } + } + } + +} + +model { + + if (prior_PD == 0) { + + //-------- models without quadrature + + if (has_quadrature == 0) { + + vector[nevent] eta_event; // linear predictor for events + vector[nlcens] eta_lcens; // linear predictor for left censored + vector[nrcens] eta_rcens; // linear predictor for right censored + vector[nicens] eta_icens; // linear predictor for interval censored + vector[ndelay] eta_delay; // linear predictor for delayed entry + + // linear predictor + if (K > 0) { + if (nevent > 0) eta_event = x_event * beta; + if (nlcens > 0) eta_lcens = x_lcens * beta; + if (nrcens > 0) eta_rcens = x_rcens * beta; + if (nicens > 0) eta_icens = x_icens * beta; + if (ndelay > 0) eta_delay = x_delay * beta; + } + else { + if (nevent > 0) eta_event = rep_vector(0.0, nevent); + if (nlcens > 0) eta_lcens = rep_vector(0.0, nlcens); + if (nrcens > 0) eta_rcens = rep_vector(0.0, nrcens); + if (nicens > 0) eta_icens = rep_vector(0.0, nicens); + if (ndelay > 0) eta_delay = rep_vector(0.0, ndelay); + } + + // add intercept + if (has_intercept == 1) { + if (nevent > 0) eta_event = eta_event + gamma[1]; + if (nlcens > 0) eta_lcens = eta_lcens + gamma[1]; + if (nrcens > 0) eta_rcens = eta_rcens + gamma[1]; + if (nicens > 0) eta_icens = eta_icens + gamma[1]; + if (ndelay > 0) eta_delay = eta_delay + gamma[1]; + } + + // evaluate log hazard and log survival + if (type == 5) { // exponential model + if (nevent > 0) target += exponential_log_haz (eta_event); + if (nevent > 0) target += exponential_log_surv(eta_event, t_event); + if (nlcens > 0) target += exponential_log_cdf (eta_lcens, t_lcens); + if (nrcens > 0) target += exponential_log_surv(eta_rcens, t_rcens); + if (nicens > 0) target += exponential_log_cdf2(eta_icens, t_icenl, t_icenu); + if (ndelay > 0) target += -exponential_log_surv(eta_delay, t_delay); + } + else if (type == 1) { // weibull model + real shape = coefs[1]; + if (nevent > 0) target += weibull_log_haz (eta_event, t_event, shape); + if (nevent > 0) target += weibull_log_surv(eta_event, t_event, shape); + if (nlcens > 0) target += weibull_log_cdf (eta_lcens, t_lcens, shape); + if (nrcens > 0) target += weibull_log_surv(eta_rcens, t_rcens, shape); + if (nicens > 0) target += weibull_log_cdf2(eta_icens, t_icenl, t_icenu, shape); + if (ndelay > 0) target += -weibull_log_surv(eta_delay, t_delay, shape); + } + else if (type == 6) { // gompertz model + real scale = coefs[1]; + if (nevent > 0) target += gompertz_log_haz (eta_event, t_event, scale); + if (nevent > 0) target += gompertz_log_surv(eta_event, t_event, scale); + if (nlcens > 0) target += gompertz_log_cdf (eta_lcens, t_lcens, scale); + if (nrcens > 0) target += gompertz_log_surv(eta_rcens, t_rcens, scale); + if (nicens > 0) target += gompertz_log_cdf2(eta_icens, t_icenl, t_icenu, scale); + if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); + } + else if (type == 4) { // M-splines, on haz scale + if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs); + if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs); + if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs); + if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs); + if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs); + if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs); + } + else { + reject("Bug found: invalid baseline hazard (without quadrature)."); + } + } + + //-------- models with quadrature + + else { + + vector[len_cpts] eta; // linear predictor at event and quadrature times + vector[len_cpts] lhaz; // log hazard at event and quadrature times + + vector[Nevent] lhaz_epts_event; + vector[qevent] lhaz_qpts_event; + vector[qlcens] lhaz_qpts_lcens; + vector[qrcens] lhaz_qpts_rcens; + vector[qicens] lhaz_qpts_icenl; + vector[qicens] lhaz_qpts_icenu; + vector[qdelay] lhaz_qpts_delay; + + // linear predictor (time-fixed part) + if (K > 0) { + eta = x_cpts * beta; + } + else { + eta = rep_vector(0.0, len_cpts); + } + + // add on time-varying part to linear predictor + if (S > 0) { + eta = eta + s_cpts * beta_tde; + } + + // add on intercept to linear predictor + if (has_intercept == 1) { + eta = eta + gamma[1]; + } + + // evaluate log hazard + if (type == 5) { // exponential model + lhaz = exponential_log_haz(eta); + } + else if (type == 1) { // weibull model + real shape = coefs[1]; + lhaz = weibull_log_haz(eta, cpts, shape); + } + else if (type == 6) { // gompertz model + real scale = coefs[1]; + lhaz = gompertz_log_haz(eta, cpts, scale); + } + else if (type == 4) { // M-splines, on haz scale + lhaz = mspline_log_haz(eta, basis_cpts, coefs); + } + else if (type == 2) { // B-splines, on log haz scale + lhaz = bspline_log_haz(eta, basis_cpts, coefs); + } + else { + reject("Bug found: invalid baseline hazard (with quadrature)."); + } + + // split log hazard vector based on event types + if (Nevent > 0) lhaz_epts_event = lhaz[idx_cpts[1,1]:idx_cpts[1,2]]; + if (qevent > 0) lhaz_qpts_event = lhaz[idx_cpts[2,1]:idx_cpts[2,2]]; + if (qlcens > 0) lhaz_qpts_lcens = lhaz[idx_cpts[3,1]:idx_cpts[3,2]]; + if (qrcens > 0) lhaz_qpts_rcens = lhaz[idx_cpts[4,1]:idx_cpts[4,2]]; + if (qicens > 0) lhaz_qpts_icenl = lhaz[idx_cpts[5,1]:idx_cpts[5,2]]; + if (qicens > 0) lhaz_qpts_icenu = lhaz[idx_cpts[6,1]:idx_cpts[6,2]]; + if (qdelay > 0) lhaz_qpts_delay = lhaz[idx_cpts[7,1]:idx_cpts[7,2]]; + + // increment target with log-lik contributions for event submodel + if (Nevent > 0) target += lhaz_epts_event; + if (qevent > 0) target += quadrature_log_surv(qwts_event, lhaz_qpts_event); + if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, qnodes); + if (qrcens > 0) target += quadrature_log_surv(qwts_rcens, lhaz_qpts_rcens); + if (qicens > 0) target += quadrature_log_cdf2(qwts_icenl, lhaz_qpts_icenl, + qwts_icenu, lhaz_qpts_icenu, qnodes); + if (qdelay > 0) target += -quadrature_log_surv(qwts_delay, lhaz_qpts_delay); + + } + + } + + //-------- log priors + + // log priors for coefficients + if (K > 0) { + beta_lp(z_beta, prior_dist, prior_scale, prior_df, global_prior_df, + local, global, mix, ool, slab_df, caux); + } + + // log prior for intercept + if (has_intercept == 1) { + gamma_lp(gamma[1], prior_dist_for_intercept, prior_mean_for_intercept, + prior_scale_for_intercept, prior_df_for_intercept); + } + + // log priors for baseline hazard parameters + if (nvars > 0) { + basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); + } + + // log priors for tde spline coefficients and their smoothing parameters + if (S > 0) { + smooth_lp(z_beta_tde, smooth_sd_raw, prior_dist_for_smooth, prior_df_for_smooth); + } + +} From 7c28f6418f6f5524c272acc82d99d24d46233055 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 11:01:18 +1100 Subject: [PATCH 002/225] Add stan_surv function --- R/stan_surv.R | 1343 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1343 insertions(+) create mode 100644 R/stan_surv.R diff --git a/R/stan_surv.R b/R/stan_surv.R new file mode 100644 index 000000000..f74028202 --- /dev/null +++ b/R/stan_surv.R @@ -0,0 +1,1343 @@ +# Part of the rstanarm package for estimating model parameters +# Copyright (C) 2018 Sam Brilleman +# Copyright (C) 2018 Trustees of Columbia University +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 3 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +#' Bayesian survival models via Stan +#' +#' \if{html}{\figure{stanlogo.png}{options: width="25px" alt="http://mc-stan.org/about/logo/"}} +#' Bayesian inference for proportional or non-proportional hazards regression +#' models. The user can specify a variety of standard parametric distributions +#' for the baseline hazard, or a flexible parametric model (using either +#' M-splines for modelling the baseline hazard, or B-splines for modelling +#' the log baseline hazard). Covariate effects can be accommodated under +#' proportional hazards or non-proportional hazards (i.e. time-dependent +#' effects). +#' +#' @export +#' @importFrom splines bs +#' +#' @template args-prior_intercept +#' @template args-priors +#' @template args-prior_PD +#' @template args-algorithm +#' @template args-adapt_delta +#' +#' @param formula A two-sided formula object describing the model. +#' The left hand side of the formula should be a \code{Surv()} +#' object. See \code{\link[survival]{Surv}}. If you wish to include +#' time-dependent effect (i.e. time-dependent coefficients) in the model +#' then the covariate(s) that you wish to estimate a time-dependent for +#' should be specified as \code{tde(varname)} where \code{varname} is the +#' name of the covariate. See the \strong{Details} section for more +#' information on how the time-dependent effects are formulated, as well +#' as the \strong{Examples} section. +#' @param data A data frame containing the variables specified in +#' \code{formula}. +#' @param basehaz A character string indicating which baseline hazard to use +#' for the event submodel. Current options are: +#' \itemize{ +#' \item \code{"ms"}: a flexible parametric model using M-splines to +#' model the baseline hazard. The default locations for the internal knots, +#' as well as the basis terms for the splines, are calculated with respect +#' to time. If the model does \emph{not} include any time-dependendent +#' effects then a closed form solution is available for both the hazard +#' and cumulative hazard and so this approach should be relatively fast. +#' On the other hand, if the model does include time-dependent effects then +#' quadrature is used to evaluate the cumulative hazard at each MCMC +#' iteration and, therefore, estimation of the model will be slower. +#' \item \code{"bs"}: a flexible parametric model using B-splines to model +#' the \emph{log} baseline hazard. The default locations for the internal +#' knots, as well as the basis terms for the splines, are calculated with +#' respect to time. A closed form solution for the cumulative hazard +#' is \strong{not} available (regardless of whether or not the model includes +#' time-dependent effects) and therefore quadrature is used to evaluate +#' the cumulative hazard at each MCMC iteration. Therefore, if the model +#' does not include any time-dependent effects, then estimation using the +#' \code{"ms"} baseline will be faster. +#' \item \code{"exp"}: an exponential distribution for the event times. +#' (i.e. a constant baseline hazard) +#' \item \code{"weibull"}: a Weibull distribution for the event times. +#' \item \code{"gompertz"}: a Gompertz distribution for the event times. +#' } +#' Note that all spline-based models use splines of degree 3 (i.e. cubic +#' splines). +#' @param basehaz_ops a named list specifying options related to the baseline +#' hazard. Currently this can include: \cr +#' \itemize{ +#' \item \code{df}: a positive integer specifying the degrees of freedom +#' for the M-splines / I-splines. The default is 6. +#' \item \code{knots}: An optional numeric vector specifying the internal +#' knot locations for the splines if \code{basehaz = "ms"}. Knots cannot be +#' specified if \code{df} is specified. If not specified, then the +#' default is to use \code{df - 4} knots, which are +#' placed at equally spaced percentiles of the distribution of +#' uncensored event times. +#' \item \code{bknots}: an optional numeric vector specifying the boundary +#' knot locations for the splines if \code{basehaz = "ms"}. +#' If not specified, then the default is to place the boundary knots at the +#' minimum and maximum of the event times (including both censored and +#' uncensored events). +#' } +#' @param qnodes The number of nodes to use for the Gauss-Kronrod quadrature +#' that is used to evaluate the cumulative hazard when \code{basehaz = "bs"} +#' or when time-dependent effects (i.e. non-proportional hazards) are +#' specified. Options are 15 (the default), 11 or 7. +#' @param prior_aux The prior distribution for the parameters related to the +#' baseline hazard. The relevant "auxiliary" parameters differ depending on +#' on the type of baseline hazard specified in the \code{basehaz} +#' argument. The following applies: +#' \itemize{ +#' \item \code{basehaz = "exp"}: there is \strong{no} auxiliary parameter, +#' since the log scale parameter for the exponential distribution is +#' incorporated as an intercept in the linear predictor. +#' \item \code{basehaz = "weibull"}: the auxiliary parameter is the Weibull +#' shape parameter, while the log scale parameter for the Weibull +#' distribution is incorporated as an intercept in the linear predictor. +#' The auxiliary parameter has a lower bound at zero. +#' \item \code{basehaz = "gompertz"}: the auxiliary parameter is the Gompertz +#' scale parameter, while the log shape parameter for the Gompertz +#' distribution is incorporated as an intercept in the linear predictor. +#' The auxiliary parameter has a lower bound at zero. +#' \item \code{basehaz = "ms"}: the auxiliary parameters are the coefficients +#' for the M-spline basis terms on the baseline hazard. These parameters +#' have a lower bound at zero. +#' \item \code{basehaz = "bs"}: the auxiliary parameters are the coefficients +#' for the B-spline basis terms on the log baseline hazard. These parameters +#' are unbounded. +#' } +#' Currently, \code{prior_aux} can be a call to \code{normal}, \code{student_t} +#' or \code{cauchy}. See \code{\link{priors}} for details on these functions. +#' To omit a prior ---i.e., to use a flat (improper) uniform prior--- set +#' \code{prior_aux} to \code{NULL}. +#' @param prior_smooth This is only relevant when time-dependent effects are +#' specified in the model (i.e. the \code{tde()} function is used in the +#' model formula. When that is the case, \code{prior_smooth} determines the +#' prior distribution for the hyperparameter of the smoothing function +#' for the time-dependent coefficients (specifically the standard deviation +#' of the cubic B-spline coefficients). Lower values for the hyperparameter +#' yield a less flexible smooth function. \code{prior_smooth} can be a call +#' to \code{exponential} to +#' use an exponential distribution, or \code{normal}, \code{student_t} or +#' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy +#' prior. See \code{\link{priors}} for details on these functions. To omit a +#' prior ---i.e., to use a flat (improper) uniform prior--- set +#' \code{prior_smooth} to \code{NULL}. The number of hyperparameters depends +#' on the model specification but a scalar prior will be recylced as necessary +#' to the appropriate length. +#' +#' @details +#' By default, any covariate effects specified in the \code{formula} are +#' included in the model under a proportional hazards assumption. To relax +#' this assumption, it is possible to estimate a time-dependent coefficient +#' for a given covariate. This can be specified in the model \code{formula} +#' by wrapping the covariate name in the \code{tde()} function (note that +#' this function is not an exported function, rather it is an internal function +#' that can only be evaluated within the formula of a \code{stan_surv} call). +#' For example, if we wish to estimate a time-dependent effect for the +#' covariate \code{sex} then we can specify \code{tde(sex)} in the +#' \code{formula}, e.g. \code{Surv(time, status) ~ tde(sex) + age + trt}. +#' The coefficient for \code{sex} will then be modelled +#' using a flexible smooth function based on a cubic B-spline expansion of +#' time. The flexibility of the smooth function can be controlled through +#' the hyperparameters related the B-spline coefficients; see the +#' \code{prior_smooth} argument. Also, by default the cubic B-spline basis is +#' evaluated with 3 degrees of freedom (that is a cubic spline basis with +#' boundary knots at the limits of the time range, but no internal knots). If +#' you wish to increase the flexibility of the smooth function by using a +#' greater number of degrees of freedom, then you can specify this as part +#' of the \code{tde} function call. For example, to use cubic B-splines with +#' 7 degrees of freedom we could specify \code{tde(sex, df = 7)} in the +#' model formula. See the \strong{Examples} section below for more details. +#' +#' @examples +#' +#' #---------- Proportional hazards +#' +#' # Simulated data +#' library(simsurv) +#' covs <- data.frame(id = 1:1000, +#' trt = stats::rbinom(1000, 1L, 0.5)) +#' dat1 <- simsurv(lambdas = 0.1, +#' gammas = 1.5, +#' betas = c(trt = -0.5), +#' x = covs, +#' maxt = 5) +#' dat1 <- merge(dat1, covs) +#' fm1 <- Surv(eventtime, status) ~ trt +#' mod1a <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "ms") +#' mod1b <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "bs") +#' mod1c <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "exp") +#' mod1d <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "weibull") +#' #mod1e <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "gompertz") +#' do.call(cbind, lapply(list(mod1a, mod1b, mod1c, mod1d), fixef)) +#' bayesplot::bayesplot_grid(plot(mod1a), plot(mod1b), +#' plot(mod1c), plot(mod1d), +#' ylim = c(0, 0.8)) +#' +#' # Breast cancer data +#' library(flexsurv) +#' dat2 <- flexsurv::bc +#' fm2 <- Surv(rectime, censrec) ~ group +#' mod2a <- stan_surv(fm2, dat2, chains = 1, iter = 1000) +#' mod2z <- flexsurv::flexsurvspline(fm2, dat2, k = 3) +#' print(mod2a, 4) +#' mod2z +#' +#' # PBC data +#' dat3 <- survival::pbc +#' dat3$timeYears <- dat3$time / 365.25 +#' dat3$death <- (dat3$status == 2) +#' fm3 <- Surv(timeYears, death) ~ sex + trt +#' mod3a <- stan_surv(fm3, dat3, chains = 1, iter = 1000) +#' mod3z <- flexsurv::flexsurvspline(fm3, dat3, k = 3) +#' print(mod3a, 4) +#' mod3z +#' +#' #---------- Non-proportional hazards +#' +#' # Simulated data +#' library(simsurv) +#' library(rstpm2) +#' covs <- data.frame(id = 1:1000, +#' trt = stats::rbinom(1000, 1L, 0.5)) +#' dat4 <- simsurv(lambdas = 0.1, +#' gammas = 1.5, +#' betas = c(trt = -0.5), +#' tde = c(trt = 0.2), +#' x = covs, +#' maxt = 5) +#' dat4 <- merge(dat4, covs) +#' fm4 <- Surv(eventtime, status) ~ tde(trt) +#' mod4a <- stan_surv(Surv(eventtime, status) ~ tde(trt), +#' dat4, chains = 1, iter = 1000) +#' mod4z <- rstpm2::stpm2(Surv(eventtime, status) ~ trt, +#' dat4, tvc = list(trt = 5)) +#' print(mod4a, 4) +#' mod4z +#' plot(mod4a, "tde") +#' plot(mod4z, newdata = data.frame(trt = 0), type = "hr", var = "trt") +#' +stan_surv <- function(formula, + data, + basehaz = "ms", + basehaz_ops, + qnodes = 15, + prior = normal(), + prior_intercept = normal(), + prior_aux = normal(), + prior_smooth = exponential(autoscale = FALSE), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = 0.95, ...) { + + #----------------------------- + # Pre-processing of arguments + #----------------------------- + + if (!requireNamespace("survival")) + stop("the 'survival' package must be installed to use this function.") + + if (missing(basehaz_ops)) + basehaz_ops <- NULL + + dots <- list(...) + algorithm <- match.arg(algorithm) + + formula <- parse_formula(formula, data) + data <- make_model_data(formula$tf_form, data) # row subsetting etc. + + #---------------- + # Construct data + #---------------- + + #----- model frame stuff + + mf_stuff <- make_model_frame(formula$tf_form, data) + + mf <- mf_stuff$mf # model frame + mt <- mf_stuff$mt # model terms + + #----- dimensions and response vectors + + # entry and exit times for each row of data + t_beg <- make_t(mf, type = "beg") # entry time + t_end <- make_t(mf, type = "end") # exit time + t_upp <- make_t(mf, type = "upp") # upper time for interval censoring + + # event indicator for each row of data + status <- make_d(mf) + + if (any(status < 0 || status > 3)) + stop2("Invalid status indicator in Surv object.") + + # delayed entry indicator for each row of data + delayed <- as.logical(!t_beg == 0) + + # time variables for stan + t_event <- t_end[status == 1] # exact event time + t_lcens <- t_end[status == 2] # left censoring time + t_rcens <- t_end[status == 0] # right censoring time + t_icenl <- t_end[status == 3] # lower limit of interval censoring time + t_icenu <- t_upp[status == 3] # upper limit of interval censoring time + t_delay <- t_beg[delayed] # delayed entry time + + # dimensions + nevent <- sum(status == 1) + nrcens <- sum(status == 0) + nlcens <- sum(status == 2) + nicens <- sum(status == 3) + ndelay <- sum(delayed) + + #----- baseline hazard + + ok_basehaz <- c("exp", "weibull", "gompertz", "ms", "bs") + ok_basehaz_ops <- get_ok_basehaz_ops(basehaz) + basehaz <- handle_basehaz(basehaz = basehaz, + basehaz_ops = basehaz_ops, + ok_basehaz = ok_basehaz, + ok_basehaz_ops = ok_basehaz_ops, + times = t_end, + status = status, + min_t = min(t_beg), + max_t = max(c(t_end,t_upp), na.rm = TRUE)) + nvars <- basehaz$nvars # number of basehaz aux parameters + + # flag if intercept is required for baseline hazard + has_intercept <- ai(has_intercept(basehaz)) + + #----- define dimensions and times for quadrature + + # flag if formula uses time-dependent effects + has_tde <- !is.null(formula$td_form) + + # flag if closed form available for cumulative baseline hazard + has_closed_form <- check_for_closed_form(basehaz) + + # flag for quadrature + has_quadrature <- has_tde || !has_closed_form + + if (has_quadrature) { # model uses quadrature + + # standardised weights and nodes for quadrature + qq <- get_quadpoints(nodes = qnodes) + qp <- qq$points + qw <- qq$weights + + # quadrature points & weights, evaluated for each row of data + qpts_event <- uapply(qp, unstandardise_qpts, 0, t_event) + qpts_lcens <- uapply(qp, unstandardise_qpts, 0, t_lcens) + qpts_rcens <- uapply(qp, unstandardise_qpts, 0, t_rcens) + qpts_icenl <- uapply(qp, unstandardise_qpts, 0, t_icenl) + qpts_icenu <- uapply(qp, unstandardise_qpts, 0, t_icenu) + qpts_delay <- uapply(qp, unstandardise_qpts, 0, t_delay) + + qwts_event <- uapply(qw, unstandardise_qwts, 0, t_event) + qwts_lcens <- uapply(qw, unstandardise_qwts, 0, t_lcens) + qwts_rcens <- uapply(qw, unstandardise_qwts, 0, t_rcens) + qwts_icenl <- uapply(qw, unstandardise_qwts, 0, t_icenl) + qwts_icenu <- uapply(qw, unstandardise_qwts, 0, t_icenu) + qwts_delay <- uapply(qw, unstandardise_qwts, 0, t_delay) + + # times at events and all quadrature points + cpts_list <- list(t_event, + qpts_event, + qpts_lcens, + qpts_rcens, + qpts_icenl, + qpts_icenu, + qpts_delay) + idx_cpts <- get_idx_array(sapply(cpts_list, length)) + cpts <- unlist(cpts_list) # as vector for stan + len_cpts <- length(cpts) + + # number of quadrature points + qevent <- length(qwts_event) + qlcens <- length(qwts_lcens) + qrcens <- length(qwts_rcens) + qicens <- length(qwts_icenl) + qdelay <- length(qwts_delay) + + } else { + + cpts <- rep(0,0) + len_cpts <- 0L + idx_cpts <- matrix(0,7,2) + + } + + #----- basis terms for baseline hazard + + if (has_quadrature) { + + basis_cpts <- make_basis(cpts, basehaz) + + } else { + + basis_event <- make_basis(t_event, basehaz) + + ibasis_event <- make_basis(t_event, basehaz, integrate = TRUE) + ibasis_lcens <- make_basis(t_lcens, basehaz, integrate = TRUE) + ibasis_rcens <- make_basis(t_rcens, basehaz, integrate = TRUE) + ibasis_icenl <- make_basis(t_icenl, basehaz, integrate = TRUE) + ibasis_icenu <- make_basis(t_icenu, basehaz, integrate = TRUE) + ibasis_delay <- make_basis(t_delay, basehaz, integrate = TRUE) + + } + + #----- predictor matrices + + # time-fixed predictor matrix + x <- make_x(formula$tf_form, mf)$x + x_event <- keep_rows(x, status == 1) + x_lcens <- keep_rows(x, status == 2) + x_rcens <- keep_rows(x, status == 0) + x_icens <- keep_rows(x, status == 3) + x_delay <- keep_rows(x, delayed) + K <- ncol(x) + if (has_quadrature) { + x_cpts <- rbind(x_event, + rep_rows(x_event, times = qnodes), + rep_rows(x_lcens, times = qnodes), + rep_rows(x_rcens, times = qnodes), + rep_rows(x_icens, times = qnodes), + rep_rows(x_delay, times = qnodes)) + } + + # time-varying predictor matrix + if (has_tde) { + tdfm <- formula$td_form + xlevs <- .getXlevels(mt, mf) + data_event <- keep_rows(data, status == 1) + data_lcens <- keep_rows(data, status == 2) + data_rcens <- keep_rows(data, status == 0) + data_icens <- keep_rows(data, status == 3) + data_delay <- keep_rows(data, delayed) + data_cpts <- rbind(data_event, + rep_rows(data_event, times = qnodes), + rep_rows(data_lcens, times = qnodes), + rep_rows(data_rcens, times = qnodes), + rep_rows(data_icens, times = qnodes), + rep_rows(data_icens, times = qnodes), + rep_rows(data_delay, times = qnodes)) + s_cpts <- make_s(tdfm, data_cpts, times = cpts, xlevs = xlevs) + smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") + smooth_idx <- get_idx_array(table(smooth_map)) + S <- ncol(s_cpts) # num. of tde spline coefficients + } else { # model does not have tde + s_cpts <- matrix(0,len_cpts,0) + smooth_idx <- matrix(0,0,2) + smooth_map <- integer(0) + S <- 0L + } + + #----- stan data + + standata <- nlist( + K, S, + nvars, + has_intercept, + has_quadrature, + qnodes, + smooth_map, + smooth_idx, + cpts, + len_cpts, + idx_cpts, + type = basehaz$type, + + nevent = if (has_quadrature) 0L else nevent, + nlcens = if (has_quadrature) 0L else nlcens, + nrcens = if (has_quadrature) 0L else nrcens, + nicens = if (has_quadrature) 0L else nicens, + ndelay = if (has_quadrature) 0L else ndelay, + + t_event = if (has_quadrature) rep(0,0) else t_event, + t_lcens = if (has_quadrature) rep(0,0) else t_lcens, + t_rcens = if (has_quadrature) rep(0,0) else t_rcens, + t_icenl = if (has_quadrature) rep(0,0) else t_icenl, + t_icenu = if (has_quadrature) rep(0,0) else t_icenu, + t_delay = if (has_quadrature) rep(0,0) else t_delay, + + x_event = if (has_quadrature) matrix(0,0,K) else x_event, + x_lcens = if (has_quadrature) matrix(0,0,K) else x_lcens, + x_rcens = if (has_quadrature) matrix(0,0,K) else x_rcens, + x_icens = if (has_quadrature) matrix(0,0,K) else x_icens, + x_delay = if (has_quadrature) matrix(0,0,K) else x_delay, + + basis_event = if (has_quadrature) matrix(0,0,nvars) else basis_event, + ibasis_event = if (has_quadrature) matrix(0,0,nvars) else ibasis_event, + ibasis_lcens = if (has_quadrature) matrix(0,0,nvars) else ibasis_lcens, + ibasis_rcens = if (has_quadrature) matrix(0,0,nvars) else ibasis_rcens, + ibasis_icenl = if (has_quadrature) matrix(0,0,nvars) else ibasis_icenl, + ibasis_icenu = if (has_quadrature) matrix(0,0,nvars) else ibasis_icenu, + ibasis_delay = if (has_quadrature) matrix(0,0,nvars) else ibasis_delay, + + Nevent = if (!has_quadrature) 0L else nevent, + qevent = if (!has_quadrature) 0L else qevent, + qlcens = if (!has_quadrature) 0L else qlcens, + qrcens = if (!has_quadrature) 0L else qrcens, + qicens = if (!has_quadrature) 0L else qicens, + qdelay = if (!has_quadrature) 0L else qdelay, + + x_cpts = if (!has_quadrature) matrix(0,0,K) else x_cpts, + s_cpts = if (!has_quadrature) matrix(0,0,S) else s_cpts, + basis_cpts = if (!has_quadrature) matrix(0,0,nvars) else basis_cpts, + + qwts_event = if (!has_quadrature) rep(0,0) else qwts_event, + qwts_lcens = if (!has_quadrature) rep(0,0) else qwts_lcens, + qwts_rcens = if (!has_quadrature) rep(0,0) else qwts_rcens, + qwts_icenl = if (!has_quadrature) rep(0,0) else qwts_icenl, + qwts_icenu = if (!has_quadrature) rep(0,0) else qwts_icenu, + qwts_delay = if (!has_quadrature) rep(0,0) else qwts_delay + ) + + #----- priors and hyperparameters + + # valid priors + ok_dists <- nlist("normal", + student_t = "t", + "cauchy", + "hs", + "hs_plus", + "laplace", + "lasso") # disallow product normal + ok_intercept_dists <- ok_dists[1:3] + ok_aux_dists <- ok_dists[1:3] + ok_smooth_dists <- c(ok_dists[1:3], "exponential") + + # priors + user_prior_stuff <- prior_stuff <- + handle_glm_prior(prior, + nvars = K, + default_scale = 2, + link = NULL, + ok_dists = ok_dists) + + user_prior_intercept_stuff <- prior_intercept_stuff <- + handle_glm_prior(prior_intercept, + nvars = 1, + default_scale = 20, + link = NULL, + ok_dists = ok_intercept_dists) + + user_prior_aux_stuff <- prior_aux_stuff <- + handle_glm_prior(prior_aux, + nvars = basehaz$nvars, + default_scale = get_default_aux_scale(basehaz), + link = NULL, + ok_dists = ok_aux_dists) + if (prior_PD && is.null(prior_aux)) + stop("'prior_aux' cannot be NULL if 'prior_PD' is TRUE") + + user_prior_smooth_stuff <- prior_smooth_stuff <- + handle_glm_prior(prior_smooth, + nvars = if (S) max(smooth_map) else 0, + default_scale = 1, + link = NULL, + ok_dists = ok_smooth_dists) + + # stop null priors if prior_PD is TRUE + if (prior_PD) { + if (is.null(prior)) + stop("'prior' cannot be NULL if 'prior_PD' is TRUE") + if (is.null(prior_intercept) && has_intercept) + stop("'prior_intercept' cannot be NULL if 'prior_PD' is TRUE") + if (is.null(prior_aux)) + stop("'prior_aux' cannot be NULL if 'prior_PD' is TRUE") + if (is.null(prior_smooth) && (S > 0)) + stop("'prior_smooth' cannot be NULL if 'prior_PD' is TRUE") + } + + # autoscaling of priors + prior_stuff <- autoscale_prior(prior_stuff, predictors = x) + prior_intercept_stuff <- autoscale_prior(prior_intercept_stuff) + prior_aux_stuff <- autoscale_prior(prior_aux_stuff) + prior_smooth_stuff <- autoscale_prior(prior_smooth_stuff) + + # priors + standata$prior_dist <- prior_stuff$prior_dist + standata$prior_dist_for_intercept<- prior_intercept_stuff$prior_dist + standata$prior_dist_for_aux <- prior_aux_stuff$prior_dist + standata$prior_dist_for_smooth <- prior_smooth_stuff$prior_dist + + # hyperparameters + standata$prior_mean <- prior_stuff$prior_mean + standata$prior_scale <- prior_stuff$prior_scale + standata$prior_df <- prior_stuff$prior_df + standata$prior_mean_for_intercept <- c(prior_intercept_stuff$prior_mean) + standata$prior_scale_for_intercept<- c(prior_intercept_stuff$prior_scale) + standata$prior_df_for_intercept <- c(prior_intercept_stuff$prior_df) + standata$prior_scale_for_aux <- prior_aux_stuff$prior_scale + standata$prior_df_for_aux <- prior_aux_stuff$prior_df + standata$prior_mean_for_smooth <- prior_smooth_stuff$prior_mean + standata$prior_scale_for_smooth <- prior_smooth_stuff$prior_scale + standata$prior_df_for_smooth <- prior_smooth_stuff$prior_df + standata$global_prior_scale <- prior_stuff$global_prior_scale + standata$global_prior_df <- prior_stuff$global_prior_df + standata$slab_df <- prior_stuff$slab_df + standata$slab_scale <- prior_stuff$slab_scale + + # any additional flags + standata$prior_PD <- ai(prior_PD) + + #--------------- + # Prior summary + #--------------- + + prior_info <- summarize_jm_prior( + user_priorEvent = user_prior_stuff, + user_priorEvent_intercept = user_prior_intercept_stuff, + user_priorEvent_aux = user_prior_aux_stuff, + adjusted_priorEvent_scale = prior_stuff$prior_scale, + adjusted_priorEvent_intercept_scale = prior_intercept_stuff$prior_scale, + adjusted_priorEvent_aux_scale = prior_aux_stuff$prior_scale, + e_has_intercept = has_intercept, + e_has_predictors = K > 0, + basehaz = basehaz + ) + + #----------- + # Fit model + #----------- + + # obtain stan model code + stanfit <- stanmodels$surv + + # specify parameters for stan to monitor + stanpars <- c(if (standata$has_intercept) "gamma", + if (standata$K) "beta", + if (standata$S) "beta_tde", + if (standata$S) "smooth_sd", + if (standata$nvars) "coefs") + + # fit model using stan + if (algorithm == "sampling") { # mcmc + args <- set_sampling_args( + object = stanfit, + data = standata, + pars = stanpars, + prior = prior, + user_dots = list(...), + user_adapt_delta = adapt_delta, + show_messages = FALSE) + stanfit <- do.call(rstan::sampling, args) + } else { # meanfield or fullrank vb + args <- nlist( + object = stanfit, + data = standata, + pars = stanpars, + algorithm + ) + args[names(dots)] <- dots + stanfit <- do.call(rstan::vb, args) + } + check_stanfit(stanfit) + + # define new parameter names + nms_beta <- colnames(x) # may be NULL + nms_tde <- get_smooth_name(s_cpts, type = "smooth_coefs") # may be NULL + nms_smooth <- get_smooth_name(s_cpts, type = "smooth_sd") # may be NULL + nms_int <- get_int_name_basehaz(basehaz) + nms_aux <- get_aux_name_basehaz(basehaz) + nms_all <- c(nms_int, + nms_beta, + nms_tde, + nms_smooth, + nms_aux, + "log-posterior") + + # substitute new parameter names into 'stanfit' object + stanfit <- replace_stanfit_nms(stanfit, nms_all) + + # return an object of class 'stansurv' + fit <- nlist(stanfit, + formula, + has_tde, + has_quadrature, + data, + model_frame = mf, + terms = mt, + xlevels = .getXlevels(mt, mf), + x, + s_cpts = if (has_tde) s_cpts else NULL, + t_beg, + t_end, + status, + event = as.logical(status == 1), + delayed, + basehaz, + nobs = nrow(mf), + nevents = nevent, + nlcens, + nrcens, + nicens, + ncensor = nlcens + nrcens + nicens, + ndelayed = ndelay, + prior_info, + qnodes = if (has_quadrature) qnodes else NULL, + algorithm, + stan_function = "stan_surv", + rstanarm_version = packageVersion("rstanarm"), + call = match.call(expand.dots = TRUE)) + stansurv(fit) +} + + +#---------- internal + +# Identify whether the type of baseline hazard requires an intercept in +# the linear predictor (NB splines incorporate the intercept into the basis). +# +# @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. +# @return A Logical. +has_intercept <- function(basehaz) { + nm <- get_basehaz_name(basehaz) + (nm %in% c("exp", "weibull", "gompertz")) +} + +# Return the name of the tde spline coefs or smoothing parameters. +# +# @param x The predictor matrix for the time-dependent effects, with column names. +# @param type The type of information about the smoothing parameters to return. +# @return A character or numeric vector, depending on 'type'. +get_smooth_name <- function(x, type = "smooth_coefs") { + + if (is.null(x) || !ncol(x)) + return(NULL) + + nms <- gsub(":bs\\(times__.*\\)[0-9]*$", "", colnames(x)) + tally <- table(nms) + indices <- uapply(tally, seq_len) + suffix <- paste0(":tde-spline-coef", indices) + + switch(type, + smooth_coefs = paste0(nms, suffix), + smooth_sd = paste0("smooth_sd[", unique(nms), "]"), + smooth_map = rep(seq_along(tally), tally), + smooth_vars = unique(nms), + stop2("Bug found: invalid input to 'type' argument.")) +} + +# Return the default scale parameter for 'prior_aux'. +# +# @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. +# @return A scalar. +get_default_aux_scale <- function(basehaz) { + nm <- get_basehaz_name(basehaz) + if (nm %in% c("weibull", "gompertz")) 2 else 20 +} + +# Check if the type of baseline hazard has a closed form +# +# @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. +# @return A logical. +check_for_closed_form <- function(basehaz) { + nm <- get_basehaz_name(basehaz) + nm %in% c("exp", + "weibull", + "gompertz", + "ms") +} + +# Replace the parameter names slot of an object of class 'stanfit'. +# +# @param stanfit An object of class 'stanfit'. +# @param new_nms A character vector of new parameter names. +# @return A 'stanfit' object. +replace_stanfit_nms <- function(stanfit, new_nms) { + stanfit@sim$fnames_oi <- new_nms + stanfit +} + +# Return the spline basis for the given type of baseline hazard. +# +# @param times A numeric vector of times at which to evaluate the basis. +# @param basehaz A list with info about the baseline hazard, returned by a +# call to 'handle_basehaz'. +# @param integrate A logical, specifying whether to calculate the integral of +# the specified basis. +# @return A matrix. +make_basis <- function(times, basehaz, integrate = FALSE) { + N <- length(times) + K <- basehaz$nvars + if (!N) { # times is NULL or empty vector + return(matrix(0, 0, K)) + } + switch(basehaz$type_name, + "exp" = matrix(0, N, K), # dud matrix for Stan + "weibull" = matrix(0, N, K), # dud matrix for Stan + "gompertz" = matrix(0, N, K), # dud matrix for Stan + "ms" = basis_matrix(times, basis = basehaz$basis, integrate = integrate), + "bs" = basis_matrix(times, basis = basehaz$basis), + "piecewise" = dummy_matrix(times, knots = basehaz$knots), + stop2("Bug found: type of baseline hazard unknown.")) +} + +# Evaluate a spline basis matrix at the specified times +# +# @param time A numeric vector. +# @param basis Info on the spline basis. +# @param integrate A logical, should the integral of the basis be returned? +# @return A two-dimensional array. +basis_matrix <- function(times, basis, integrate = FALSE) { + out <- predict(basis, times) + if (integrate) { + stopifnot(inherits(basis, "mSpline")) + out <- splines2:::predict.iSpline(basis, times) + } + aa(out) +} + +# Parse the model formula +# +# @param formula The user input to the formula argument. +# @param data The user input to the data argument (i.e. a data frame). +parse_formula <- function(formula, data) { + + formula <- validate_formula(formula, needs_response = TRUE) + + lhs <- lhs(formula) # full LHS of formula + lhs_form <- reformulate_lhs(lhs) + + rhs <- rhs(formula) # RHS as expression + rhs_form <- reformulate_rhs(rhs) # RHS as formula + rhs_terms <- terms(rhs_form, specials = "tde") + rhs_vars <- rownames(attr(rhs_terms, "factors")) + + allvars <- all.vars(formula) + allvars_form <- reformulate(allvars) + + surv <- eval(lhs, envir = data) # Surv object + surv <- validate_surv(surv) + type <- attr(surv, "type") + + if (type == "right") { + tvar_beg <- NULL + tvar_end <- as.character(lhs[[2L]]) + dvar <- as.character(lhs[[3L]]) + min_t <- 0 + max_t <- max(surv[, "time"]) + } else if (type == "counting") { + tvar_beg <- as.character(lhs[[2L]]) + tvar_end <- as.character(lhs[[3L]]) + dvar <- as.character(lhs[[4L]]) + min_t <- min(surv[, "start"]) + max_t <- max(surv[, "stop"]) + } else if (type == "interval") { + tvar_beg <- NULL + tvar_end <- as.character(lhs[[2L]]) + dvar <- as.character(lhs[[4L]]) + min_t <- 0 + max_t <- max(surv[, c("time1", "time2")]) + } else if (type == "interval2") { + tvar_beg <- NULL + tvar_end <- as.character(lhs[[2L]]) + dvar <- as.character(lhs[[3L]]) + min_t <- 0 + max_t <- max(surv[, c("time1", "time2")]) + } + + sel <- attr(rhs_terms, "specials")$tde + + if (!is.null(sel)) { # model has tde + + # replace 'tde(x, ...)' in formula with 'x' + tde_oldvars <- rhs_vars + tde_newvars <- sapply(tde_oldvars, function(oldvar) { + if (oldvar %in% rhs_vars[sel]) { + tde <- function(newvar, ...) { # define tde function locally + safe_deparse(substitute(newvar)) + } + eval(parse(text = oldvar)) + } else oldvar + }, USE.NAMES = FALSE) + term_labels <- attr(rhs_terms, "term.labels") + for (i in sel) { + sel_terms <- which(attr(rhs_terms, "factors")[i, ] > 0) + for (j in sel_terms) { + term_labels[j] <- gsub(tde_oldvars[i], + tde_newvars[i], + term_labels[j], + fixed = TRUE) + } + } + tf_form <- reformulate(term_labels, response = lhs) + + # extract 'tde(x, ...)' from formula and construct 'bs(times, ...)' + tde_terms <- lapply(rhs_vars[sel], function(x) { + tde <- function(vn, ...) { # define tde function locally + dots <- list(...) + ok_args <- c("df") + if (!isTRUE(all(names(dots) %in% ok_args))) + stop2("Invalid argument to 'tde' function. ", + "Valid arguments are: ", comma(ok_args)) + df <- if (is.null(dots$df)) 3 else dots$df + degree <- 3 + if (df == 3) { + dots[["knots"]] <- numeric(0) + } else { + dx <- (max_t - min_t) / (df - degree + 1) + dots[["knots"]] <- seq(min_t + dx, max_t - dx, dx) + } + dots[["Boundary.knots"]] <- c(min_t, max_t) + sub("^list\\(", "bs\\(times__, ", safe_deparse(dots)) + } + tde_calls <- eval(parse(text = x)) + sel_terms <- which(attr(rhs_terms, "factors")[x, ] > 0) + new_calls <- sapply(seq_along(sel_terms), function(j) { + paste0(term_labels[sel_terms[j]], ":", tde_calls) + }) + nlist(tde_calls, new_calls) + }) + td_basis <- fetch(tde_terms, "tde_calls") + new_calls <- fetch_(tde_terms, "new_calls") + td_form <- reformulate(new_calls, response = NULL, intercept = FALSE) + + } else { # model doesn't have tde + tf_form <- formula + td_form <- NULL + td_basis <- NULL + } + + nlist(formula, + lhs, + rhs, + lhs_form, + rhs_form, + tf_form, + td_form, + td_basis, + fe_form = rhs_form, # no re terms accommodated yet + re_form = NULL, # no re terms accommodated yet + allvars, + allvars_form, + tvar_beg, + tvar_end, + dvar, + surv_type = attr(surv, "type")) +} + +# Check formula object +# +# @param formula The user input to the formula argument. +# @param needs_response A logical; if TRUE then formula must contain a LHS. +validate_formula <- function(formula, needs_response = TRUE) { + + if (!inherits(formula, "formula")) { + stop2("'formula' must be a formula.") + } + + if (needs_response) { + len <- length(formula) + if (len < 3) { + stop2("'formula' must contain a response.") + } + } + as.formula(formula) +} + +# Check object is a Surv object with a valid type +# +# @param x A Surv object; the LHS of a formula evaluated in a data frame environment. +# @param ok_types A character vector giving the allowed types of Surv object. +validate_surv <- function(x, ok_types = c("right", "counting", + "interval", "interval2")) { + if (!inherits(x, "Surv")) + stop2("LHS of 'formula' must be a 'Surv' object.") + if (!attr(x, "type") %in% ok_types) + stop2("Surv object type must be one of: ", comma(ok_types)) + x +} + + +# Extract LHS of a formula +# +# @param x A formula object +# @param as_formula Logical. If TRUE then the result is reformulated. +lhs <- function(x, as_formula = FALSE) { + len <- length(x) + if (len == 3L) { + out <- x[[2L]] + } else { + out <- NULL + } + out +} + +# Extract RHS of a formula +# +# @param x A formula object +# @param as_formula Logical. If TRUE then the result is reformulated. +rhs <- function(x, as_formula = FALSE) { + len <- length(x) + if (len == 3L) { + out <- x[[3L]] + } else { + out <- x[[2L]] + } + out +} + +# Reformulate as LHS of a formula +# +# @param x A character string or expression object +# @param as_formula Logical. If TRUE then the result is reformulated. +reformulate_lhs <- function(x) { + #x <- deparse(x, 500L) + x <- formula(substitute(LHS ~ 1, list(LHS = x))) + x +} + +# Reformulate as RHS of a formula +# +# @param x A formula object +# @param as_formula Logical. If TRUE then the result is reformulated. +reformulate_rhs <- function(x) { + #x <- deparse(x, 500L) + x <- formula(substitute(~ RHS, list(RHS = x))) + x +} + + +# Return the response vector (time) for estimation +# +# @param model_frame The model frame. +# @param type The type of time variable to return: +# "beg": the entry time for the row in the survival data, +# "end": the exit time for the row in the survival data, +# "gap": the difference between entry and exit times, +# "upp": if the row involved interval censoring, then the exit time +# would have been the lower limit of the interval, and "upp" +# is the upper limit of the interval. +# @return A numeric vector. +make_t <- function(model_frame, type = c("beg", "end", "gap", "upp")) { + + type <- match.arg(type) + resp <- if (survival::is.Surv(model_frame)) + model_frame else model.response(model_frame) + surv <- attr(resp, "type") + err <- paste0("Bug found: cannot handle '", surv, "' Surv objects.") + + t_beg <- switch(surv, + "right" = rep(0, nrow(model_frame)), + "interval" = rep(0, nrow(model_frame)), + "interval2" = rep(0, nrow(model_frame)), + "counting" = as.vector(resp[, "start"]), + stop(err)) + + t_end <- switch(surv, + "right" = as.vector(resp[, "time"]), + "interval" = as.vector(resp[, "time1"]), + "interval2" = as.vector(resp[, "time1"]), + "counting" = as.vector(resp[, "stop"]), + stop(err)) + + t_upp <- switch(surv, + "right" = rep(NaN, nrow(model_frame)), + "counting" = rep(NaN, nrow(model_frame)), + "interval" = as.vector(resp[, "time2"]), + "interval2" = as.vector(resp[, "time2"]), + stop(err)) + + switch(type, + "beg" = t_beg, + "end" = t_end, + "gap" = t_end - t_beg, + "upp" = t_upp, + stop("Bug found: cannot handle specified 'type'.")) +} + + +# Return the response vector (status indicator) +# +# @param model_frame The model frame. +# @return A numeric vector. +make_d <- function(model_frame) { + + resp <- if (survival::is.Surv(model_frame)) + model_frame else model.response(model_frame) + surv <- attr(resp, "type") + err <- paste0("Bug found: cannot handle '", surv, "' Surv objects.") + + switch(surv, + "right" = as.vector(resp[, "status"]), + "interval" = as.vector(resp[, "status"]), + "interval2" = as.vector(resp[, "status"]), + "counting" = as.vector(resp[, "status"]), + stop(err)) +} + +# Return a data frame with NAs excluded +# +# @param formula The parsed model formula. +# @param data The user specified data frame. +make_model_data <- function(formula, data) { + mf <- model.frame(formula, data, na.action = na.pass) + include <- apply(mf, 1L, function(row) !any(is.na(row))) + data[include, , drop = FALSE] +} + +# Return the model frame +# +# @param formula The parsed model formula. +# @param data The model data frame. +make_model_frame <- function(formula, data, check_constant = TRUE) { + + # construct terms object from formula + Terms <- terms(formula) + + # construct model frame + mf <- model.frame(Terms, data) + + # check no constant vars + if (check_constant) + mf <- check_constant_vars(mf) + + # check for terms + mt <- attr(mf, "terms") + if (is.empty.model(mt)) + stop2("No intercept or predictors specified.") + + nlist(mf, mt) +} + +# Return the fe predictor matrix for estimation +# +# @param formula The parsed model formula. +# @param model_frame The model frame. +# @return A named list with the following elements: +# x: the fe model matrix, not centred and without intercept. +# xbar: the column means of the model matrix. +# N,K: number of rows (observations) and columns (predictors) in the +# fixed effects model matrix +make_x <- function(formula, model_frame, xlevs = NULL, check_constant = TRUE) { + + # uncentred predictor matrix, without intercept + x <- model.matrix(formula, model_frame, xlevs = xlevs) + x <- drop_intercept(x) + + # column means of predictor matrix + xbar <- colMeans(x) + + # identify any column of x with < 2 unique values (empty interaction levels) + sel <- (apply(x, 2L, n_distinct) < 2) + if (check_constant && any(sel)) { + cols <- paste(colnames(x)[sel], collapse = ", ") + stop2("Cannot deal with empty interaction levels found in columns: ", cols) + } + + nlist(x, xbar, N = NROW(x), K = NCOL(x)) +} + +# Return a predictor for the tde spline terms +# +# @param formula The formula for the time-dependent effects part of the model. +# @param data A data frame. +# @param times The vector of times at which the predictor matrix should be +# evaluated. +# @param xlevs The factor levels to use for the predictor matrix. +# @return A matrix. +make_s <- function(formula, data, times, xlevs = NULL) { + + # add times (as a new variable) to the model data + if (!length(times) == nrow(data)) + stop("Bug found: 'times' is the incorrect length.") + data <- data.frame(data, times__ = times) + + # make model frame and predictor matrix + mf <- make_model_frame(formula, data, check_constant = FALSE)$mf + x <- make_x(formula, mf, xlevs = xlevs, check_constant = FALSE)$x + return(x) +} + +# Return the fe predictor matrix for prediction +# +# @param object A stansurv object. +# @param model_frame The model frame. +# @return A named list with the following elements: +# x: the fe model matrix, not centred and may have intercept depending on +# the requirement of the baseline hazard. +# N,K: number of rows (observations) and columns (predictors) in the +# fixed effects model matrix +make_pp_x <- function(object, model_frame) { + + # formula for fe predictor matrix + tt <- delete.response(terms(object)) + + # check data classes in the model frame match those used in model fitting + if (!is.null(cl <- attr(tt, "dataClasses"))) + .checkMFClasses(cl, model_frame) + + # uncentered predictor matrix + x <- model.matrix(tt, model_frame, contrasts.arg = object$contrasts) + + # drop intercept if baseline hazard doesn't require one + if (!has_intercept(object$basehaz)) + x <- drop_intercept(x) + + nlist(x, N = NROW(x), K = NCOL(x)) +} + +# apply b-spline time-dependent effect +apply_tde_fun <- function(model_terms, model_frame, times, bknots = NULL) { + + tde_stuff <- survival::untangle.specials(model_terms, "tde") + + if (!length(tde_stuff$terms)) + return(model_frame) # no time-dependent effects + + if (!nrow(model_frame)) + return(model_frame) # no rows in model frame (e.g. no delayed entry) + + vars <- attr(model_terms, 'variables') + pvars <- attr(model_terms, 'predvars') + + # loop over time-dependent terms in formula + K <- length(tde_stuff$terms) + for (i in 1:K) { + indx_i <- tde_stuff$terms[i] + 2 # index in call; +2 for 'list' & 'Surv()' + var_i <- vars [[indx_i]] # var in formula + pvar_i <- pvars[[indx_i]] # predvar in formula + var_i <- safe_deparse(var_i) # treat call as a string + pvar_i <- safe_deparse(pvar_i) # treat call as a string + # get the possible prefixes for the predvar (i.e. 'tde(x' or 'bs(x') + prefix <- "^bs\\([^,]+,[[:blank:]]*|^tde\\([^,]+,[[:blank:]]*" + # returns dots from 'tde(x, ...)' as a list + chck <- grepl(prefix, pvar_i) + if (chck) { + args_i <- eval_string(sub(prefix, "list\\(", pvar_i)) + } else { + args_i <- list() + } + # combine the dots with the times at which to evaluate the b-spline basis + args_i$intercept <- TRUE + if (!is.null(bknots)) + args_i$Boundary.knots <- bknots + args_i <- c(list(x = times), args_i) + # extract the variable from the model frame + oldx_i <- model_frame[[var_i]] + # apply interaction with the b-spline basis evaluated at specified times + newx_i <- oldx_i * do.call(splines::bs, args_i) + # substitute back into the model frame + model_frame[[var_i]] <- newx_i + } + + return(model_frame) +} + +update_tde_terms <- function(model_terms, model_frame) { + tde_terms <- survival::untangle.specials(model_terms, "tde")$terms + if (!length(tde_terms)) + return(model_frame) # no time-dependent effects + vars <- attr(model_terms, 'variables') + pvars <- attr(model_terms, 'predvars') + dclss <- attr(model_terms, "dataClasses") + K <- length(tde_terms) + for (i in 1:K) { + indx_i <- tde_terms[i] + 2 # index in call; +2 for 'list' & 'Surv()' + var_i <- vars [[indx_i]] # var in formula + pvar_i <- pvars[[indx_i]] # predvar in formula + var_i <- safe_deparse(var_i) # treat call as a string + pvar_i <- safe_deparse(pvar_i) # treat call as a string + oldx_i <- model_frame[[var_i]] # extract transformed variable from model frame + dummy <- as.call(list(as.name(class(oldx_i)[[1L]]), vars[[indx_i]][[2]])) + ptemp <- makepredictcall(oldx_i, dummy) # predvars call + pvars[[indx_i]] <- ptemp + dclss[[var_i]] <- class(oldx_i)[[1L]] + } + attr(model_terms, "predvars") <- pvars + #attr(model_terms, "dataClasses") <- dclss + return(model_terms) +} + + +#--------- not used; based on tt approach instead of tde approach + +# # Validate the user input to the 'tt' argument. This draws on the +# # code for the coxph modelling function in the survival package. +# # +# # Copyright (C) 2018 Sam Brilleman +# # Copyright (C) 2018 Terry Therneau, Thomas Lumley +# # +# # @param tt The user input to the 'tt' argument. +# # @param validate_length Integer specifying the required length of the +# # returned list. +# # @return A list of functions. +# validate_tt_fun <- function(tt, validate_length) { +# +# if (is.null(tt)) +# stop2("'tt' must be specified.") +# +# if (is.function(tt)) +# tt <- list(tt) # convert since function to a one element list +# +# if (!is.list(tt)) +# stop2("The 'tt' argument must contain a function or list of functions.") +# +# if (!all(sapply(tt, is.function))) +# stop2("The 'tt' argument must contain function or list of functions.") +# +# if (!length(tt) %in% c(1, validate_length)) +# stop2("The 'tt' argument contains a list of the incorrect length.") +# +# if (length(tt) == 1) +# tt <- rep(tt, validate_length) +# +# return(tt) +# } +# +# # apply time transform to the model frame; method based on survival package +# apply_tt_fun <- function(model_frame, tt_funs, tt_vars, tt_terms, times) { +# if (!length(tt_terms)) +# return(model_frame) +# +# for (i in 1:length(tt_terms)) { # loop over time transform terms +# +# # extract quantities used in time transform +# varnm_i <- tt_vars[[i]] # varname in model frame +# ttfun_i <- tt_funs[[i]] # user defined tt function +# +# # time transform at event times +# oldx_i <- model_frame[[varnm_i]] # extract var from model frame +# newx_i <- (ttfun_i)(oldx_i, times) # evaluate tt function at times +# model_frame[[varnm_i]] <- newx_i # substitute back into model frame +# } +# +# return(model_frame) +# } +# +# # update the predvars attribute for time transformed terms +# update_predvars <- function(model_terms, model_frame, tt_vars, tt_terms) { +# tcall <- attr(model_terms, 'variables')[tt_terms + 2] +# pvars <- attr(model_terms, 'predvars') +# pmethod <- sub("makepredictcall.", "", as.vector(methods("makepredictcall"))) +# for (i in 1:length(tt_terms)) { +# # update predvars if necessary +# varnm_i <- tt_vars[[i]] # varname in model frame +# terms_i <- tt_terms[i] + 2 # index in terms object +# x_i <- model_frame[[varnm_i]] # extract transformed variable from model frame +# nclass <- class(x_i) # check class of transformed variable +# if (any(nclass %in% pmethod)) { # it has a makepredictcall method... +# dummy <- as.call(list(as.name(class(x_i)[1]), tcall[[i]][[2]])) +# ptemp <- makepredictcall(x_i, dummy) +# pvars[[terms_i]] <- ptemp +# } +# } +# attr(model_terms, "predvars") <- pvars +# return(model_terms) +# } + From 9c88853b80975fe3f58f90f864f500bccba74eb9 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 11:05:21 +1100 Subject: [PATCH 003/225] Add roxygen template for stan_surv model objects --- man-roxygen/args-stansurv-stanjm-object.R | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 man-roxygen/args-stansurv-stanjm-object.R diff --git a/man-roxygen/args-stansurv-stanjm-object.R b/man-roxygen/args-stansurv-stanjm-object.R new file mode 100644 index 000000000..8ef6c5c85 --- /dev/null +++ b/man-roxygen/args-stansurv-stanjm-object.R @@ -0,0 +1,3 @@ +#' @param <%= stanregArg %> A fitted model object returned by the +#' \code{\link{stan_surv}} or \code{\link{stan_jm}} modelling function. +#' See \code{\link{stanreg-objects}}. From 826322d508320ce71caaea6bf3751ad9620a857e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 11:12:31 +1100 Subject: [PATCH 004/225] Add stansurv function for returning models of class stansurv --- R/stansurv.R | 107 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 107 insertions(+) create mode 100644 R/stansurv.R diff --git a/R/stansurv.R b/R/stansurv.R new file mode 100644 index 000000000..2c45e0da7 --- /dev/null +++ b/R/stansurv.R @@ -0,0 +1,107 @@ +# Part of the rstanarm package for estimating model parameters +# Copyright (C) 2015, 2016, 2017 Trustees of Columbia University +# Copyright (C) 2016, 2017, 2018 Sam Brilleman +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 3 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +# Function to create a stansurv object (fitted model object) +# +# @param object A list returned by a call to stan_surv +# @return A stansurv object +# +stansurv <- function(object) { + + alg <- object$algorithm + opt <- alg == "optimizing" + mcmc <- alg == "sampling" + stanfit <- object$stanfit + basehaz <- object$basehaz + K <- NCOL(object$x) + + if (opt) + stop2("Optimisation not implemented for 'stansurv' objects.") + + stan_summary <- make_stan_summary(stanfit) + + # number of parameters + nvars <- ncol(object$x) + has_intercept(basehaz) + basehaz$nvars + + # obtain medians + coefs <- stan_summary[seq(nvars), select_median(alg)] + coefs_nms <- rownames(stan_summary)[seq(nvars)] + names(coefs) <- coefs_nms # ensure parameter names are retained + + # obtain standard errors and covariance matrix + stanmat <- as.matrix(stanfit)[, seq(nvars), drop = FALSE] + colnames(stanmat) <- coefs_nms + ses <- apply(stanmat, 2L, mad) + covmat <- cov(stanmat) + + # for mcmc only + if (mcmc) { + check_rhats(stan_summary[, "Rhat"]) # check rhats for all parameters + runtime <- get_runtime(object$stanfit) # run time (in mins) + } + + # return object of class 'stansurv' + out <- nlist( + coefficients = coefs, + ses = ses, + covmat = covmat, + formula = object$formula, + has_tde = object$has_tde, + has_quadrature= object$has_quadrature, + terms = object$terms, + data = object$data, + model_frame = object$model_frame, + x = object$x, + s_cpts = object$s_cpts, + entrytime = object$t_beg, + eventtime = object$t_end, + event = object$event, + delayed = object$delayed, + basehaz = object$basehaz, + nobs = object$nobs, + nevents = object$nevents, + ncensor = object$ncensor, + ndelayed = object$ndelayed, + qnodes = object$qnodes, + prior.info = object$prior_info, + algorithm = object$algorithm, + stan_function = object$stan_function, + call = object$call, + runtime = if (mcmc) runtime else NULL, + rstan_version = utils::packageVersion("rstan"), + rstanarm_version = utils::packageVersion("rstanarm"), + stan_summary, + stanfit + ) + out <- rm_null(out, recursive = FALSE) + + structure(out, class = c("stansurv", "stanreg")) +} + + +#---------- internal + +# Return the model fitting time in minutes. +# +# @param stanfit An object of class 'stanfit'. +# @return A matrix of runtimes, stratified by warmup/sampling and chain/overall. +get_runtime <- function(stanfit) { + tt <- rstan::get_elapsed_time(stanfit) + tt <- round(tt / 60, digits = 1L) # time per chain + tt <- cbind(tt, total = rowSums(tt)) # time per chain & overall +} From 13caaed63c9d2526686a712d18a17fcff6642dac Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 11:16:11 +1100 Subject: [PATCH 005/225] Add stan_surv for package documentation of modelling functions --- R/doc-modeling-functions.R | 43 +++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 17 deletions(-) diff --git a/R/doc-modeling-functions.R b/R/doc-modeling-functions.R index 7c51ee66f..841d8878c 100644 --- a/R/doc-modeling-functions.R +++ b/R/doc-modeling-functions.R @@ -1,7 +1,7 @@ #' Modeling functions available in \pkg{rstanarm} -#' +#' #' @name available-models -#' +#' #' @section Modeling functions: #' The model estimating functions are described in greater detail in their #' individual help pages and vignettes. Here we provide a very brief @@ -33,9 +33,16 @@ #' appropriate estimates of uncertainty for models that consist of a mix of #' common and group-specific parameters. #' } +#' \item{\code{\link{stan_mvmer}}}{ +#' A multivariate form of \code{\link{stan_glmer}}, whereby the user can +#' specify one or more submodels each consisting of a GLM with group-specific +#' terms. If more than one submodel is specified (i.e. there is more than one +#' outcome variable) then a dependence is induced by assuming that the +#' group-specific terms for each grouping factor are correlated across submodels. +#' } #' \item{\code{\link{stan_nlmer}}}{ -#' Similar to \code{\link[lme4]{nlmer}} in the \pkg{lme4} package for -#' nonlinear "mixed-effects" models, but the group-specific coefficients +#' Similar to \code{\link[lme4]{nlmer}} in the \pkg{lme4} package for +#' nonlinear "mixed-effects" models, but the group-specific coefficients #' have flexible priors on their unknown covariance matrices. #' } #' \item{\code{\link{stan_gamm4}}}{ @@ -68,22 +75,24 @@ #' to \code{\link[survival]{clogit}} that allow \code{stan_clogit} to accept #' group-specific terms as in \code{\link{stan_glmer}}. #' } -#' \item{\code{\link{stan_mvmer}}}{ -#' A multivariate form of \code{\link{stan_glmer}}, whereby the user can -#' specify one or more submodels each consisting of a GLM with group-specific -#' terms. If more than one submodel is specified (i.e. there is more than one -#' outcome variable) then a dependence is induced by assuming that the -#' group-specific terms for each grouping factor are correlated across submodels. +#' \item{\code{\link{stan_surv}}}{ +#' Fits models to survival (i.e. time-to-event) data on the hazard scale. +#' The user can choose between a variety of standard parametric distributions +#' for the baseline hazard, or a flexible parametric model (using either +#' M-splines for modelling the baseline hazard, or B-splines for modelling +#' the log baseline hazard). Covariate effects can be accommodated under +#' proportional hazards or non-proportional hazards (i.e. time-dependent +#' effects). #' } #' \item{\code{\link{stan_jm}}}{ -#' Estimates shared parameter joint models for longitudinal and time-to-event -#' (i.e. survival) data. The joint model can be univariate (i.e. one longitudinal -#' outcome) or multivariate (i.e. more than one longitudinal outcome). A variety -#' of parameterisations are available for linking the longitudinal and event -#' processes (i.e. a variety of association structures). +#' Estimates shared parameter joint models for longitudinal and survival (i.e. +#' time-to-event) data. The joint model can be univariate (i.e. one longitudinal +#' outcome) or multivariate (i.e. more than one longitudinal outcome). A variety +#' of parameterisations are available for linking the longitudinal and event +#' processes (i.e. a variety of association structures). #' } #' } -#' +#' #' @seealso \url{http://mc-stan.org/rstanarm/} -#' +#' NULL From a18ae333a708a056c3d19c907204ef59a5b26809 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 11:53:29 +1100 Subject: [PATCH 006/225] misc.R: add helper functions for stan_surv and stan_jm --- R/misc.R | 728 ++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 644 insertions(+), 84 deletions(-) diff --git a/R/misc.R b/R/misc.R index f85ecaaf4..68f87bf35 100644 --- a/R/misc.R +++ b/R/misc.R @@ -89,10 +89,20 @@ default_stan_control <- function(prior, adapt_delta = NULL, nlist(adapt_delta, max_treedepth) } -# Test if an object is a stanreg object +# Test if an object inherits a specific stanreg class # # @param x The object to test. -is.stanreg <- function(x) inherits(x, "stanreg") +is.stanreg <- function(x) inherits(x, "stanreg") +is.stansurv <- function(x) inherits(x, "stansurv") +is.stanmvreg <- function(x) inherits(x, "stanmvreg") +is.stanjm <- function(x) inherits(x, "stanjm") + +# Test if object contains a specific type of submodel +# +# @param x The object to test. +is.jm <- function(x) isTRUE(x$stan_function %in% c("stan_jm")) +is.mvmer <- function(x) isTRUE(x$stan_function %in% c("stan_jm", "stan_mvmer")) +is.surv <- function(x) isTRUE(x$stan_function %in% c("stan_jm", "stan_surv")) # Throw error if object isn't a stanreg object # @@ -102,16 +112,40 @@ validate_stanreg_object <- function(x, call. = FALSE) { stop("Object is not a stanreg object.", call. = call.) } +# Throw error if object isn't a stanmvreg object +# +# @param x The object to test. +validate_stanmvreg_object <- function(x, call. = FALSE) { + if (!is.stanmvreg(x)) + stop("Object is not a stanmvreg object.", call. = call.) +} + +# Throw error if object isn't a stanjm object +# +# @param x The object to test. +validate_stanjm_object <- function(x, call. = FALSE) { + if (!is.stanjm(x)) + stop("Object is not a stanjm object.", call. = call.) +} + +# Throw error if object isn't a stansurv object +# +# @param x The object to test. +validate_stansurv_object <- function(x, call. = FALSE) { + if (!is.stansurv(x)) + stop("Object is not a stansurv object.", call. = call.) +} + # Test for a given family # # @param x A character vector (probably x = family(fit)$family) is.binomial <- function(x) x == "binomial" is.gaussian <- function(x) x == "gaussian" -is.gamma <- function(x) x == "Gamma" -is.ig <- function(x) x == "inverse.gaussian" -is.nb <- function(x) x == "neg_binomial_2" -is.poisson <- function(x) x == "poisson" -is.beta <- function(x) x == "beta" || x == "Beta regression" +is.gamma <- function(x) x == "Gamma" +is.ig <- function(x) x == "inverse.gaussian" +is.nb <- function(x) x == "neg_binomial_2" +is.poisson <- function(x) x == "poisson" +is.beta <- function(x) x == "beta" || x == "Beta regression" # test if a stanreg object has class clogit is_clogit <- function(object) { @@ -585,6 +619,23 @@ get_z.stanmvreg <- function(object, m = NULL, ...) { if (!is.null(m)) ret[[m]] else list_nms(ret, stub = stub) } +#' Extract survival response from a stansurv or stanjm object +#' +#' @keywords internal +#' @export +#' @param object A \code{stansurv} or \code{stanjm} object. +#' @param ... Other arguments passed to methods. +#' @return A \code{Surv} object, see \code{?survival::Surv}. +get_surv <- function(object, ...) UseMethod("get_surv") +#' @export +get_surv.stansurv <- function(object, ...) { + model.response(model.frame(object)) %ORifNULL% stop("response not found") +} +#' @export +get_surv.stanjm <- function(object, ...) { + object$survmod$mod$y %ORifNULL% stop("response not found") +} + # Get inverse link function # # @param x A stanreg object, family object, or string. @@ -842,6 +893,19 @@ array2list <- function(x, nsplits, bycol = TRUE) { x[(k-1) * len_k + 1:len_k, , drop = FALSE]}) } +# Use sweep to multiply a vector or array. Note that usually sweep cannot +# handle a vector, whereas this function definition can. +# +# @param x A vector or array. +# @param y The vector or scalar to multiply 'x' by. +# @param margin The margin of 'x' across which to apply 'y' (only relevant +# if 'x' is an array, i.e. not a vector). +# @return An object of the same class as 'x'. +sweep_multiply <- function(x, y, margin = 2L) { + if (is.vector(x)) return(x * y) + sweep(x, margin, y, `*`) +} + # Convert a standardised quadrature node to an unstandardised value based on # the specified integral limits # @@ -880,57 +944,6 @@ unstandardise_qwts <- function(x, a, b) { ((b - a) / 2) * x } -# Test if object is stanmvreg class -# -# @param x An object to be tested. -is.stanmvreg <- function(x) { - inherits(x, "stanmvreg") -} - -# Test if object is stanjm class -# -# @param x An object to be tested. -is.stanjm <- function(x) { - inherits(x, "stanjm") -} - -# Test if object is a joint longitudinal and survival model -# -# @param x An object to be tested. -is.jm <- function(x) { - isTRUE(x$stan_function == "stan_jm") -} - -# Test if object contains a multivariate GLM -# -# @param x An object to be tested. -is.mvmer <- function(x) { - isTRUE(x$stan_function %in% c("stan_mvmer", "stan_jm")) -} - -# Test if object contains a survival model -# -# @param x An object to be tested. -is.surv <- function(x) { - isTRUE(x$stan_function %in% c("stan_jm")) -} - -# Throw error if object isn't a stanmvreg object -# -# @param x The object to test. -validate_stanmvreg_object <- function(x, call. = FALSE) { - if (!is.stanmvreg(x)) - stop("Object is not a stanmvreg object.", call. = call.) -} - -# Throw error if object isn't a stanjm object -# -# @param x The object to test. -validate_stanjm_object <- function(x, call. = FALSE) { - if (!is.stanjm(x)) - stop("Object is not a stanjm object.", call. = call.) -} - # Throw error if parameter isn't a positive scalar # # @param x The object to test. @@ -950,18 +963,20 @@ validate_positive_scalar <- function(x, not_greater_than = NULL) { } } -# Return a list with the median and prob% CrI bounds for each column of a -# matrix or 2D array +# Return a matrix or list with the median and prob% CrI bounds for +# each column of a matrix or 2D array # # @param x A matrix or 2D array # @param prob Value between 0 and 1 indicating the desired width of the CrI -median_and_bounds <- function(x, prob, na.rm = FALSE) { +# @param return_matrix Logical, if TRUE then a matrix with three columns is +# returned (med, lb, ub) else if FALSE a list with three elements is returned. +median_and_bounds <- function(x, prob, na.rm = FALSE, return_matrix = FALSE) { if (!any(is.matrix(x), is.array(x))) stop("x should be a matrix or 2D array.") med <- apply(x, 2, median, na.rm = na.rm) lb <- apply(x, 2, quantile, (1 - prob)/2, na.rm = na.rm) ub <- apply(x, 2, quantile, (1 + prob)/2, na.rm = na.rm) - nlist(med, lb, ub) + if (return_matrix) cbind(med, lb, ub) else nlist(med, lb, ub) } # Return the stub for variable names from one submodel of a stan_jm model @@ -1166,6 +1181,14 @@ STOP_arg_required_for_stanmvreg <- function(arg) { stop2(msg) } +# Error message when not specifying 'id_var' for stansurv methods that require it +# +# @param arg The argument +STOP_id_var_required <- function() { + stop2("'id_var' must be specified for models with a start-stop response ", + "or with time dependent effects.") +} + # Error message when a function is not yet implemented for stanmvreg objects # # @param what A character string naming the function not yet implemented @@ -1176,6 +1199,16 @@ STOP_if_stanmvreg <- function(what) { stop2(msg) } +# Error message when a function is not yet implemented for stansurv objects +# +# @param what A character string naming the function not yet implemented +STOP_if_stansurv <- function(what) { + msg <- "not yet implemented for stansurv objects." + if (!missing(what)) + msg <- paste(what, msg) + stop2(msg) +} + # Error message when a function is not yet implemented for stan_mvmer models # # @param what An optional message to prepend to the default message. @@ -1212,6 +1245,13 @@ STOP_no_var <- function(var) { stop2("Variable '", var, "' cannot be found in the data frame.") } +# Error message when values for the time variable are negative +# +# @param var The name of the time variable +STOP_negative_times <- function(var) { + stop2("Values for the time variable (", var, ") should not be negative.") +} + # Error message for dynamic predictions # # @param what A reason why the dynamic predictions are not allowed @@ -1428,23 +1468,46 @@ get_time_seq <- function(increments, t0, t1, simplify = TRUE) { # Extract parameters from stanmat and return as a list # -# @param object A stanmvreg object +# @param object A stanmvreg or stansurv object # @param stanmat A matrix of posterior draws, may be provided if the desired # stanmat is only a subset of the draws from as.matrix(object$stanfit) # @return A named list -extract_pars <- function(object, stanmat = NULL, means = FALSE) { +extract_pars <- function(object, ...) { + UseMethod("extract_pars") +} + +extract_pars.stansurv <- function(object, stanmat = NULL, means = FALSE) { + validate_stansurv_object(object) + if (is.null(stanmat)) + stanmat <- as.matrix(object$stanfit) + if (means) + stanmat <- t(colMeans(stanmat)) # return posterior means + nms_beta <- colnames(object$x) + nms_tde <- get_smooth_name(object$s_cpts, type = "smooth_coefs") + nms_smth <- get_smooth_name(object$s_cpts, type = "smooth_sd") + nms_int <- get_int_name_basehaz(object$basehaz) + nms_aux <- get_aux_name_basehaz(object$basehaz) + alpha <- stanmat[, nms_int, drop = FALSE] + beta <- stanmat[, nms_beta, drop = FALSE] + beta_tde <- stanmat[, nms_tde, drop = FALSE] + aux <- stanmat[, nms_aux, drop = FALSE] + smooth <- stanmat[, nms_smth, drop = FALSE] + nlist(alpha, beta, beta_tde, aux, smooth, stanmat) +} + +extract_pars.stanmvreg <- function(object, stanmat = NULL, means = FALSE) { validate_stanmvreg_object(object) M <- get_M(object) if (is.null(stanmat)) stanmat <- as.matrix(object$stanfit) if (means) stanmat <- t(colMeans(stanmat)) # return posterior means - nms <- collect_nms(colnames(stanmat), M, stub = get_stub(object)) - beta <- lapply(1:M, function(m) stanmat[, nms$y[[m]], drop = FALSE]) - ebeta <- stanmat[, nms$e, drop = FALSE] - abeta <- stanmat[, nms$a, drop = FALSE] + nms <- collect_nms(colnames(stanmat), M, stub = get_stub(object)) + beta <- lapply(1:M, function(m) stanmat[, nms$y[[m]], drop = FALSE]) + b <- lapply(1:M, function(m) stanmat[, nms$y_b[[m]], drop = FALSE]) + ebeta <- stanmat[, nms$e, drop = FALSE] + abeta <- stanmat[, nms$a, drop = FALSE] bhcoef <- stanmat[, nms$e_extra, drop = FALSE] - b <- lapply(1:M, function(m) stanmat[, nms$y_b[[m]], drop = FALSE]) nlist(beta, ebeta, abeta, bhcoef, b, stanmat) } @@ -1652,28 +1715,112 @@ pad_matrix <- function(x, cols = NULL, rows = NULL, x } -#------- helpers from brms package +# Return the cutpoints for a specified number of quantiles of 'x' +# +# @param x A numeric vector. +# @param nq Integer specifying the number of quantiles. +# @return A vector of percentiles corresponding to percentages 100*k/m for +# k=1,2,...,nq-1. +qtile <- function(x, nq = 2) { + if (nq > 1) { + probs <- seq(1, nq - 1) / nq + return(quantile(x, probs = probs)) + } else if (nq == 1) { + return(NULL) + } else { + stop("'nq' must be >= 1.") + } +} -stop2 <- function(...) { - stop(..., call. = FALSE) +# Return the desired spline basis for the given knot locations +get_basis <- function(x, iknots, bknots = range(x), + degree = 3, intercept = TRUE, + type = c("bs", "is", "ms")) { + type <- match.arg(type) + if (type == "bs") { + out <- splines::bs(x, knots = iknots, Boundary.knots = bknots, + degree = degree, intercept = intercept) + } else if (type == "is") { + out <- splines2::iSpline(x, knots = iknots, Boundary.knots = bknots, + degree = degree, intercept = intercept) + } else if (type == "ms") { + out <- splines2::mSpline(x, knots = iknots, Boundary.knots = bknots, + degree = degree, intercept = intercept) + } else { + stop2("'type' is not yet accommodated.") + } + out +} + +# Paste character vector collapsing with a comma +comma <- function(x) { + paste(x, collapse = ", ") +} + +# Select rows of a matrix +# +# @param x A matrix. +# @param rows Logical or numeric vector stating which rows of 'x' to retain. +keep_rows <- function(x, rows = 1:nrow(x)) { + x[rows, , drop = FALSE] } -warning2 <- function(...) { - warning(..., call. = FALSE) +# Drop rows of a matrix +# +# @param x A matrix. +# @param rows Logical or numeric vector stating which rows of 'x' to drop +drop_rows <- function(x, rows = 1:nrow(x)) { + x[!rows, , drop = FALSE] } -SW <- function(expr) { - # just a short form for suppressWarnings - base::suppressWarnings(expr) +# Replicate rows of a matrix or data frame +# +# @param x A matrix or data frame. +# @param ... Arguments passed to 'rep', namely 'each' or 'times'. +rep_rows <- function(x, ...) { + if (is.null(x) || !nrow(x)) { + return(x) + } else if (is.matrix(x) || is.data.frame(x)) { + x <- x[rep(1:nrow(x), ...), , drop = FALSE] + } else { + stop2("'x' must be a matrix or data frame.") + } + x } +# Stop without printing call +stop2 <- function(...) stop(..., call. = FALSE) + +# Immediate warning without printing call +warning2 <- function(...) warning(..., immediate. = TRUE, call. = FALSE) + +# Shorthand for suppress warnings +SW <- function(expr) base::suppressWarnings(expr) + +# Check if an object is NULL is_null <- function(x) { - # check if an object is NULL is.null(x) || ifelse(is.vector(x), all(sapply(x, is.null)), FALSE) } +# Check if all objects are NULL +all_null <- function(...) { + dots <- list(...) + null_check <- uapply(dots, function(x) { + is.null(x) || ifelse(is.vector(x), all(sapply(x, is.null)), FALSE) + }) + all(null_check) +} + +# Check if any objects are NULL +any_null <- function(...) { + dots <- list(...) + null_check <- uapply(dots, function(x) { + is.null(x) || ifelse(is.vector(x), all(sapply(x, is.null)), FALSE) + }) + any(null_check) +} +# Recursively removes NULL entries from an object rm_null <- function(x, recursive = TRUE) { - # recursively removes NULL entries from an object x <- Filter(Negate(is_null), x) if (recursive) { x <- lapply(x, function(x) if (is.list(x)) rm_null(x) else x) @@ -1681,16 +1828,429 @@ rm_null <- function(x, recursive = TRUE) { x } -isFALSE <- function(x) { - identical(FALSE, x) -} - +# Check if all elements are equal allowing NA and NULL is_equal <- function(x, y, ...) { isTRUE(all.equal(x, y, ...)) } +# Check if x behaves like a factor in design matrices is_like_factor <- function(x) { - # check if x behaves like a factor in design matrices is.factor(x) || is.character(x) || is.logical(x) } +# Check if 'x' is FALSE +isFALSE <- function(x) { + identical(FALSE, x) +} + +# Concatenate (i.e. 'c(...)') but don't demote factors to integers +ulist <- function(...) { unlist(list(...)) } + +# Return the names for the group specific coefficients +# +# @param cnms A named list with the names of the parameters nested within each +# grouping factor. +# @param flevels A named list with the (unique) factor levels nested within each +# grouping factor. +# @return A character vector. +get_ranef_name <- function(cnms, flevels) { + cnms_nms <- names(cnms) + b_nms <- uapply(seq_along(cnms), FUN = function(i) { + nm <- cnms_nms[i] + nms_i <- paste(cnms[[i]], nm) + flevels[[nm]] <- c(gsub(" ", "_", flevels[[nm]]), + paste0("_NEW_", nm)) + if (length(nms_i) == 1) { + paste0(nms_i, ":", flevels[[nm]]) + } else { + c(t(sapply(nms_i, paste0, ":", flevels[[nm]]))) + } + }) + c(paste0("b[", b_nms, "]")) +} + +# Return the name for the mean_PPD +get_ppd_name <- function(x, ...) { + paste0(x$stub, "|mean_PPD") +} + +# Return the name for the intercept parameter +get_int_name_basehaz <- function(x, is_jm = FALSE, ...) { + if (is_jm || has_intercept(x)) "(Intercept)" else NULL +} +get_int_name_ymod <- function(x, ...) { + if (x$intercept_type$number) paste0(x$stub, "|(Intercept)") else NULL +} +get_int_name_emod <- function(x, is_jm = FALSE, ...) { + nm <- get_int_name_basehaz(x$basehaz, is_jm = is_jm) + if (!is.null(nm)) paste0("Event|", nm) else NULL +} + +# Return the names for the auxiliary parameters +get_aux_name_basehaz <- function(x, ...) { + switch(get_basehaz_name(x), + exp = NULL, + weibull = "weibull-shape", + gompertz = "gompertz-scale", + ms = paste0("m-splines-coef", seq(x$nvars)), + bs = paste0("b-splines-coef", seq(x$nvars)), + piecewise = paste0("piecewise-coef", seq(x$nvars)), + NA) +} +get_aux_name_ymod <- function(x, ...) { + switch(x$family$family, + gaussian = paste0(x$stub, "|sigma"), + Gamma = paste0(x$stub, "|shape"), + inverse.gaussian = paste0(x$stub, "|lambda"), + neg_binomial_2 = paste0(x$stub, "|reciprocal_dispersion"), + NULL) +} +get_aux_name_emod <- function(x, ...) { + nms <- get_aux_name_basehaz(x$basehaz) + if (!is.null(nms)) paste0("Event|", nms) else NULL +} + +# Return the names for the coefficients +get_beta_name_ymod <- function(x) { + nms <- colnames(x$x$xtemp) + if (!is.null(nms)) paste0(x$stub, "|", nms) else NULL +} +get_beta_name_emod <- function(x, ...) { + nms <- colnames(x$x) + if (!is.null(nms)) paste0("Event|", nms) else NULL +} + +# Return the names for the association parameters +get_assoc_name <- function(a_mod, assoc, ...) { + M <- length(a_mod) + a <- assoc + ev <- "etavalue" + es <- "etaslope" + ea <- "etaauc" + mv <- "muvalue" + ms <- "muslope" + ma <- "muauc" + evd <- "etavalue_data" + esd <- "etaslope_data" + mvd <- "muvalue_data" + msd <- "muslope_data" + evev <- "etavalue_etavalue" + evmv <- "etavalue_muvalue" + mvev <- "muvalue_etavalue" + mvmv <- "muvalue_muvalue" + p <- function(...) paste0(...) + indx <- function(x, m) paste0("Long", assoc["which_interactions",][[m]][[x]]) + cnms <- function(x, m) colnames(a_mod[[m]][["X_data"]][[x]]) + nms <- character() + for (m in 1:M) { + stub <- paste0("Assoc|Long", m, "|") + # order matters here! (needs to line up with the monitored stanpars) + if (a[ev, ][[m]]) nms <- c(nms, p(stub, ev )) + if (a[evd, ][[m]]) nms <- c(nms, p(stub, ev, ":", cnms(evd, m) )) + if (a[evev,][[m]]) nms <- c(nms, p(stub, ev, ":", indx(evev, m), "|", ev)) + if (a[evmv,][[m]]) nms <- c(nms, p(stub, ev, ":", indx(evmv, m), "|", mv)) + if (a[es, ][[m]]) nms <- c(nms, p(stub, es )) + if (a[esd, ][[m]]) nms <- c(nms, p(stub, es, ":", cnms(esd, m) )) + if (a[ea, ][[m]]) nms <- c(nms, p(stub, ea )) + if (a[mv, ][[m]]) nms <- c(nms, p(stub, mv )) + if (a[mvd, ][[m]]) nms <- c(nms, p(stub, mv, ":", cnms(mvd, m) )) + if (a[mvev,][[m]]) nms <- c(nms, p(stub, mv, ":", indx(mvev, m), "|", ev)) + if (a[mvmv,][[m]]) nms <- c(nms, p(stub, mv, ":", indx(mvmv, m), "|", mv)) + if (a[ms, ][[m]]) nms <- c(nms, p(stub, ms )) + if (a[msd, ][[m]]) nms <- c(nms, p(stub, ms, ":", cnms(msd, m) )) + if (a[ma, ][[m]]) nms <- c(nms, p(stub, ma )) + } + nms +} + +# Return the list with summary information about the baseline hazard +# +# @return A named list. +get_basehaz <- function(x) { + if (is.stansurv(x)) + return(x$basehaz) + if (is.stanjm(x)) + return(x$survmod$basehaz) + stop("Bug found: could not find basehaz.") +} + +# Return the name of the baseline hazard +# +# @return A character string. +get_basehaz_name <- function(x) { + if (is.character(x)) + return(x) + if (is.stansurv(x)) + return(x$basehaz$type_name) + if (is.stanjm(x)) + return(x$survmod$basehaz$type_name) + if (is.character(x$type_name)) + return(x$type_name) + stop("Bug found: could not resolve basehaz name.") +} + +# Add the variables in ...'s to the RHS of a model formula +# +# @param x A model formula. +# @param ... Character strings, the variable names. +addto_formula <- function(x, ...) { + rhs_terms <- terms(reformulate_rhs(rhs(x))) + intercept <- attr(rhs_terms, "intercept") + term_labels <- attr(rhs_terms, "term.labels") + reformulate(c(term_labels, c(...)), response = lhs(x), intercept = intercept) +} + +# Shorthand for as.integer, as.double, as.matrix, as.array +ai <- function(x, ...) as.integer(x, ...) +ad <- function(x, ...) as.double (x, ...) +am <- function(x, ...) as.matrix (x, ...) +aa <- function(x, ...) as.array (x, ...) + +# Sample rows from a two-dimensional object +# +# @param x The two-dimensional object (e.g. matrix, data frame, array). +# @param size Integer specifying the number of rows to sample. +# @param replace Should the rows be sampled with replacement? +# @return A two-dimensional object with 'size' rows and 'ncol(x)' columns. +sample_rows <- function(x, size, replace = FALSE) { + samp <- sample(nrow(x), size, replace) + x[samp, , drop = FALSE] +} + +# Sample rows from a stanmat object +# +# @param object A stanreg object. +# @param draws The number of draws/rows to sample from the stanmat. +# @param default_draws Integer or NA. If 'draws' is NULL then the number of +# rows sampled from the stanmat is equal to +# min(default_draws, posterior_sample_size, na.rm = TRUE) +# @return A matrix with 'draws' rows and 'ncol(stanmat)' columns. +sample_stanmat <- function(object, draws = NULL, default_draws = NA) { + S <- posterior_sample_size(object) + if (is.null(draws)) + draws <- min(default_draws, S, na.rm = TRUE) + if (draws > S) + stop2("'draws' should be <= posterior sample size (", S, ").") + stanmat <- as.matrix(object$stanfit) + if (isTRUE(draws < S)) { + stanmat <- sample_rows(stanmat, draws) + } + stanmat +} + +# Method to truncate a numeric vector at defined limits +# +# @param con A numeric vector. +# @param lower Scalar, the lower limit for the returned vector. +# @param upper Scalar, the upper limit for the returned vector. +# @return A numeric vector. +truncate.numeric <- function(con, lower = NULL, upper = NULL) { + if (!is.null(lower)) con[con < lower] <- lower + if (!is.null(upper)) con[con > upper] <- upper + con +} + +# Transpose only if 'x' is a vector +transpose_vector <- function(x) { + if (is.vector(x)) return(t(x)) else return(x) +} + +# Simplified conditional for 'if (is.null(...))' +if_null <- function(test, yes, no) { + if (is.null(test)) yes else no +} + +# Replace entries of 'x' based on a (possibly) vectorised condition +# +# @param x The vector, matrix, or array. +# @param condition The logical condition, possibly a logical vector. +# @param replacement The value to replace with, where the condition is TRUE. +# @param margin The margin of 'x' on which to apply the condition. +# @return The same class as 'x' but possibly with some entries replaced. +replace_where <- function(x, condition, replacement, margin = 1L) { + switch(margin, + x[condition] <- replacement, + x[,condition] <- replacement, + stop("Cannot handle 'margin' > 2.")) + x +} + +# Calculate row means, but don't simplify to a vector +row_means <- function(x, na.rm = FALSE) { + mns <- rowMeans(x, na.rm = na.rm) + if (is.matrix(x)) { + return(matrix(mns, ncol = 1)) + } else if (is.array(x)) { + return(array(mns, dim = c(nrow(x), 1))) + } else if (is.data.frame(x)) { + return(data.frame(mns)) + } else { + stop2("Cannot handle objects of class: ", class(x)) + } +} + +# Calculate column means, but don't simplify to a vector +col_means <- function(x, na.rm = FALSE) { + mns <- colMeans(x, na.rm = na.rm) + if (is.matrix(x)) { + return(matrix(mns, nrow = 1)) + } else if (is.array(x)) { + return(array(mns, dim = c(1, ncol(x)))) + } else { + stop2("Cannot handle objects of class: ", class(x)) + } +} + +# Set row or column names on an object +set_rownames <- function(x, names) { rownames(x) <- names; x } +set_colnames <- function(x, names) { colnames(x) <- names; x } + +# Select rows or columns by name or index +select_rows <- function(x, rows) { x[rows, , drop = FALSE] } +select_cols <- function(x, cols) { x[, cols, drop = FALSE] } + +# Add attributes, but only if 'condition' is TRUE +structure2 <- function(.Data, condition, ...) { + if (condition) structure(.Data, ...) else .Data +} + +# Split a vector in a specified number of (equally sized) segments +# +# @param x The vector to split. +# @param n_segments Integer specifying the desired number of segments. +# @return A list of vectors, see `?split`. +split_vector <- function(x, n_segments = 1) { + split(x, rep(1:n_segments, each = length(x) / n_segments)) +} + +# Replace an NA object, or NA entries in a vector +# +# @param x The vector with elements to potentially replace. +# @param replace_with The replacement value. +replace_na <- function(x, replace_with = "0") { + if (is.na(x)) { + x <- replace_with + } else { + x[is.na(x)] <- replace_with + } + x +} + +# Replace an NULL object, or NULL entries in a vector +# +# @param x The vector with elements to potentially replace. +# @param replace_with The replacement value. +replace_null <- function(x, replace_with = "0") { + if (is.null(x)) { + x <- replace_with + } else { + x[is.null(x)] <- replace_with + } + x +} + +# Add an intercept column onto a predictor matrix +add_intercept <- function(x) { + stopifnot(is.matrix(x)) + cbind(rep(1, nrow(x)), x) +} + +# Replace named elements of 'x' with 'y' +replace_named_elements <- function(x, y) { x[names(y)] <- y; x } + +# Invert 'is.null' +not.null <- function(x) { !is.null(x) } + +# Shorthand for as.integer, as.double, as.matrix, as.array +ai <- function(x, ...) as.integer(x, ...) +ad <- function(x, ...) as.double(x, ...) +am <- function(x, ...) as.matrix(x, ...) +aa <- function(x, ...) as.array(x, ...) + +# Return a vector of 0's or 1's +zeros <- function(n) rep(0, times = n) +ones <- function(n) rep(1, times = n) + +# Check if all elements of a vector are zeros +all_zero <- function(x) all(x == 0) + +# Return the maximum integer or double +max_integer <- function() .Machine$integer.max +max_double <- function() .Machine$double.xmax + +# Check for scalar or string +is.scalar <- function(x) { isTRUE(is.numeric(x) && (length(x) == 1)) } +is.string <- function(x) { isTRUE(is.character(x) && (length(x) == 1)) } + +# Safe deparse +safe_deparse <- function(expr) deparse(expr, 500L) + +# Evaluate a character string +eval_string <- function(x) eval(parse(text = x)) + +# Mutate, similar to dplyr (ie. append a new variable(s) to the data frame) +mutate <- function(x, ..., names_eval = FALSE, n = 4) { + dots <- list(...) + if (names_eval) { # evaluate names in parent frame + nms <- sapply(names(dots), function(x) eval.parent(as.name(x), n = n)) + } else { + nms <- names(dots) + } + for (i in seq_along(dots)) + x[[nms[[i]]]] <- dots[[i]] + x +} +mutate_ <- function(x, ...) mutate(x, ..., names_eval = TRUE, n = 5) + +# Sort the rows of a data frame based on the variables specified in dots. +# (For convenience, any variables in ... that are not in the data frame +# are ignored, rather than throwing an error - dangerous but convenient) +# +# @param x A data frame. +# @param ... Character strings; names of the columns of 'x' on which to sort. +# @param skip Logical, if TRUE then any strings in the ...'s that are not +# present as variables in the data frame are ignored, rather than throwing +# an error - somewhat dangerous, but convenient. +# @return A data frame. +row_sort <- function(x, ...) { + stopifnot(is.data.frame(x)) + vars <- lapply(list(...), as.name) # convert string to name + x[with(x, do.call(order, vars)), , drop = FALSE] +} + +# Order the cols of a data frame in the order specified in the dots. Any +# remaining columns of 'x' are retained as is and included after the ... columns. +# +# @param x A data frame. +# @param ... Character strings; the desired order of the columns of 'x' by name. +# @param skip Logical, if TRUE then any strings in the ...'s that are not +# present as variables in the data frame are ignored, rather than throwing +# an error - somewhat dangerous, but convenient. +# @return A data frame. +col_sort <- function(x, ...) { + stopifnot(is.data.frame(x)) + vars1 <- unlist(list(...)) + vars2 <- setdiff(colnames(x), vars1) # select the leftover columns in x + x[, c(vars1, vars2), drop = FALSE] +} + +# Calculate the specified quantiles for each column of an array +col_quantiles <- function(x, probs, na.rm = FALSE, return_matrix = FALSE) { + stopifnot(is.matrix(x) || is.array(x)) + out <- lapply(probs, function(q) apply(x, 2, quantile, q, na.rm = na.rm)) + if (return_matrix) do.call(cbind, out) else out +} +col_quantiles_ <- function(x, probs) { + col_quantiles(x, probs, na.rm = TRUE, return_matrix = TRUE) +} + +# Append a string (prefix) to the column names of a matrix or array +append_prefix_to_colnames <- function(x, str) { + if (ncol(x)) set_colnames(x, paste0(str, colnames(x))) else x +} + +# Return the name of the calling function as a string +get_calling_fun <- function(which = -2) { + fn <- tryCatch(sys.call(which = which)[[1L]], error = function(e) NULL) + if (!is.null(fn)) safe_deparse(fn) else NULL +} From 804507a66c629c2529c949e4a7e9694cc8e3793a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 12:26:08 +1100 Subject: [PATCH 007/225] Add plot method for stansurv objects For stansurv objects, this allows plotfun to be a plot of the baseline hazard vs time (the default), or time-dependent hazard ratio(s) vs time, or otherwise plot.stanreg is called. --- R/plots.R | 275 ++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 196 insertions(+), 79 deletions(-) diff --git a/R/plots.R b/R/plots.R index 39a84c75a..6142285cc 100644 --- a/R/plots.R +++ b/R/plots.R @@ -1,5 +1,6 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2015, 2016, 2017 Trustees of Columbia University +# Copyright (C) 2018 Sam Brilleman # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License @@ -17,10 +18,10 @@ # #' Plot method for stanreg objects #' -#' The \code{plot} method for \link{stanreg-objects} provides a convenient -#' interface to the \link[bayesplot]{MCMC} module in the \pkg{\link{bayesplot}} -#' package for plotting MCMC draws and diagnostics. It is also straightforward -#' to use the functions from the \pkg{bayesplot} package directly rather than +#' The \code{plot} method for \link{stanreg-objects} provides a convenient +#' interface to the \link[bayesplot]{MCMC} module in the \pkg{\link{bayesplot}} +#' package for plotting MCMC draws and diagnostics. It is also straightforward +#' to use the functions from the \pkg{bayesplot} package directly rather than #' via the \code{plot} method. Examples of both methods of plotting are given #' below. #' @@ -30,16 +31,20 @@ #' @template args-stanreg-object #' @template args-pars #' @template args-regex-pars -#' @param plotfun A character string naming the \pkg{bayesplot} +#' @param plotfun A character string naming the \pkg{bayesplot} #' \link[bayesplot]{MCMC} function to use. The default is to call #' \code{\link[bayesplot]{mcmc_intervals}}. \code{plotfun} can be specified #' either as the full name of a \pkg{bayesplot} plotting function (e.g. #' \code{"mcmc_hist"}) or can be abbreviated to the part of the name following #' the \code{"mcmc_"} prefix (e.g. \code{"hist"}). To get the names of all #' available MCMC functions see \code{\link[bayesplot]{available_mcmc}}. +#' For the \code{stansurv} method, one can also specify +#' \code{plotfun = "basehaz"} for a plot of the estimated baseline hazard +#' function, or \code{plot = "tde"} for a plot of the time-dependent +#' hazard ratio (if time-dependent effects were specified in the model). #' #' @param ... Additional arguments to pass to \code{plotfun} for customizing the -#' plot. These are described on the help pages for the individual plotting +#' plot. These are described on the help pages for the individual plotting #' functions. For example, the arguments accepted for the default #' \code{plotfun="intervals"} can be found at #' \code{\link[bayesplot]{mcmc_intervals}}. @@ -49,19 +54,19 @@ #' (e.g. a gtable object created by \code{\link[gridExtra]{arrangeGrob}}). #' #' @seealso -#' \itemize{ +#' \itemize{ #' \item The vignettes in the \pkg{bayesplot} package for many examples. #' \item \code{\link[bayesplot]{MCMC-overview}} (\pkg{bayesplot}) for links to #' the documentation for all the available plotting functions. #' \item \code{\link[bayesplot]{color_scheme_set}} (\pkg{bayesplot}) to change #' the color scheme used for plotting. #' \item \code{\link{pp_check}} for graphical posterior predictive checks. -#' \item \code{\link{plot_nonlinear}} for models with nonlinear smooth +#' \item \code{\link{plot_nonlinear}} for models with nonlinear smooth #' functions fit using \code{\link{stan_gamm4}}. -#' } +#' } #' #' @template reference-bayesvis -#' +#' #' @examples #' \donttest{ #' # Use rstanarm example model @@ -81,7 +86,7 @@ #' bayesplot::color_scheme_set("brightblue") #' plot(fit, "areas", regex_pars = "period", #' prob = 0.5, prob_outer = 0.9) -#' +#' #' # Make the same plot by extracting posterior draws and calling #' # bayesplot::mcmc_areas directly #' x <- as.array(fit, regex_pars = "period") @@ -110,27 +115,27 @@ #' ### Rhat, effective sample size, autocorrelation ### #' #################################################### #' bayesplot::color_scheme_set("red") -#' +#' #' # rhat #' plot(fit, "rhat") #' plot(fit, "rhat_hist") -#' +#' #' # ratio of effective sample size to total posterior sample size #' plot(fit, "neff") #' plot(fit, "neff_hist") -#' +#' #' # autocorrelation by chain #' plot(fit, "acf", pars = "(Intercept)", regex_pars = "period") #' plot(fit, "acf_bar", pars = "(Intercept)", regex_pars = "period") -#' -#' +#' +#' #' ################## #' ### Traceplots ### #' ################## #' # NOTE: rstanarm doesn't store the warmup draws (to save space because they #' # are not so essential for diagnosing the particular models implemented in #' # rstanarm) so the iterations in the traceplot are post-warmup iterations -#' +#' #' bayesplot::color_scheme_set("pink") #' (trace <- plot(fit, "trace", pars = "(Intercept)")) #' @@ -138,7 +143,7 @@ #' trace + ggplot2::scale_color_discrete() #' trace + ggplot2::scale_color_manual(values = c("maroon", "skyblue2")) #' -#' # changing facet layout +#' # changing facet layout #' plot(fit, "trace", pars = c("(Intercept)", "period2"), #' facet_args = list(nrow = 2)) #' # same plot by calling bayesplot::mcmc_trace directly @@ -164,16 +169,128 @@ #' plot.stanreg <- function(x, plotfun = "intervals", pars = NULL, regex_pars = NULL, ...) { - + if (plotfun %in% c("pairs", "mcmc_pairs")) return(pairs.stanreg(x, pars = pars, regex_pars = regex_pars, ...)) - + fun <- set_plotting_fun(plotfun) args <- set_plotting_args(x, pars, regex_pars, ..., plotfun = plotfun) do.call(fun, args) } +# plot method for stansurv ---------------------------------------------- + +#' @rdname plot.stanreg +#' @export +#' @templateVar cigeomArg ci_geom_args +#' @template args-ci-geom-args +#' @param prob A scalar between 0 and 1 specifying the width to use for the +#' plotted posterior uncertainty interval when \code{limit = "ci"}. For +#' example \code{prob = 0.95} (the default) means that the 2.5th and 97.5th +#' percentiles will be provided. +#' @param limits A quoted character string specifying the type of limits to +#' include in the plot. Can be \code{"ci"} for the Bayesian posterior +#' uncertainty interval, or \code{"none"}. This argument is only relevant +#' when \code{plotfun = "basehaz"} or \code{plotfun = "tde"} +#' +plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, + regex_pars = NULL, ..., prob = 0.95, + limits = c("ci", "none"), + ci_geom_args = NULL) { + + validate_stansurv_object(x) + + if (plotfun %in% c("basehaz", "tde")) { + + stanpars <- extract_pars(x) + has_intercept <- check_for_intercept(x$basehaz) + + t_min <- min(x$entrytime) + t_max <- max(x$exittime) + times <- seq(t_min, t_max, by = (t_max - t_min) / 200) + + if (plotfun == "basehaz") { + + if (!is.null(pars)) + warning2("'pars' is ignored when plotting the baseline hazard.") + if (!is.null(regex_pars)) + warning2("'regex_pars' is ignored when plotting the baseline hazard.") + + args <- nlist(times = times, + basehaz = get_basehaz(x), + aux = stanpars$aux, + intercept = stanpars$alpha) + basehaz <- do.call(evaluate_basehaz, args) + basehaz <- median_and_bounds(basehaz, prob, na.rm = TRUE) + plotdat <- data.frame(times, basehaz) + + ylab <- "Baseline hazard rate" + xlab <- "Time" + + } else if (plotfun == "tde") { + + if (!x$has_tde) + stop2("Model does not have time-dependent effects.") + + smooth_map <- get_smooth_name(x$s_cpts, type = "smooth_map") + smooth_vars <- get_smooth_name(x$s_cpts, type = "smooth_vars") + smooth_coefs <- get_smooth_name(x$s_cpts, type = "smooth_coefs") + + if (is.null(pars)) + pars <- smooth_vars + if (length(pars) > 1L) + stop2("Only one variable can be specified in 'pars' .") + if (!pars %in% smooth_vars) + stop2("Cannot find variable '", pars, "' amongst the tde terms.") + + sel1 <- which(smooth_vars == pars) + sel2 <- smooth_coefs[smooth_map == sel1] + + betas_tf <- stanpars$beta [, pars, drop = FALSE] + betas_td <- stanpars$beta_tde[, sel2, drop = FALSE] + betas <- cbind(betas_tf, betas_td) + + times__ <- times + basis <- eval(parse(text = x$formula$td_basis[sel1])) + basis <- add_intercept(basis) + log_hr <- linear_predictor(betas, basis) + plotdat <- median_and_bounds(exp(log_hr), prob, na.rm = TRUE) + plotdat <- data.frame(times, plotdat) + + ylab <- "Hazard ratio" + xlab <- "Time" + + } + + geom_defs <- list(color = "black") # default plot args + geom_args <- set_geom_args(geom_defs, ...) + geom_ylab <- ggplot2::ylab(ylab) + geom_xlab <- ggplot2::xlab(xlab) + geom_maps <- list(aes_string(x = "times", y = "med"), method = "loess", se = FALSE) + geom_base <- ggplot(plotdat) + geom_ylab + geom_xlab + ggplot2::theme_bw() + geom_plot <- geom_base + do.call(ggplot2::geom_smooth, c(geom_maps, geom_args)) + if (limits == "ci") { + lim_defs <- list(alpha = 0.3) # default plot args for ci + lim_args <- c(defaults = list(lim_defs), ci_geom_args) + lim_args <- do.call("set_geom_args", lim_args) + lim_maps <- list(mapping = aes_string(x = "times", ymin = "lb", ymax = "ub")) + lim_tmp <- geom_base + + ggplot2::stat_smooth(aes_string(x = "times", y = "lb"), method = "loess") + + ggplot2::stat_smooth(aes_string(x = "times", y = "ub"), method = "loess") + lim_build<- ggplot2::ggplot_build(lim_tmp) + lim_data <- list(data = data.frame(times = lim_build$data[[1]]$x, + lb = lim_build$data[[1]]$y, + ub = lim_build$data[[2]]$y)) + lim_plot <- do.call(ggplot2::geom_ribbon, c(lim_data, lim_maps, lim_args)) + } else { + lim_plot <- NULL + } + return(geom_plot + lim_plot) + } + NextMethod("plot") +} + # internal for plot.stanreg ---------------------------------------------- @@ -194,7 +311,7 @@ set_plotting_args <- function(x, pars = NULL, regex_pars = NULL, ..., .plotfun_is_type <- function(patt) { grepl(pattern = paste0("_", patt), x = plotfun, fixed = TRUE) } - + if (.plotfun_is_type("nuts")) { nuts_stuff <- list(x = bayesplot::nuts_params(x), ...) if (!.plotfun_is_type("energy")) @@ -213,13 +330,13 @@ set_plotting_args <- function(x, pars = NULL, regex_pars = NULL, ..., pars <- collect_pars(x, pars, regex_pars) pars <- allow_special_parnames(x, pars) } - + if (!used.sampling(x)) { if (!length(pars)) pars <- NULL return(list(x = as.matrix(x, pars = pars), ...)) } - + if (needs_chains(plotfun)) list(x = as.array(x, pars = pars, regex_pars = regex_pars), ...) else @@ -252,10 +369,10 @@ mcmc_function_name <- function(fun) { if (!identical(substr(fun, 1, 5), "mcmc_")) fun <- paste0("mcmc_", fun) - + if (!fun %in% bayesplot::available_mcmc()) stop( - fun, " is not a valid MCMC function name.", + fun, " is not a valid MCMC function name.", " Use bayesplot::available_mcmc() for a list of available MCMC functions." ) @@ -288,11 +405,11 @@ set_plotting_fun <- function(plotfun = NULL) { stop("'plotfun' should be a string.", call. = FALSE) plotfun <- mcmc_function_name(plotfun) - fun <- try(get(plotfun, pos = asNamespace("bayesplot"), mode = "function"), + fun <- try(get(plotfun, pos = asNamespace("bayesplot"), mode = "function"), silent = TRUE) if (!inherits(fun, "try-error")) return(fun) - + stop( "Plotting function ", plotfun, " not found. ", "A valid plotting function is any function from the ", @@ -304,17 +421,17 @@ set_plotting_fun <- function(plotfun = NULL) { # check if plotfun is ok to use with vb or optimization validate_plotfun_for_opt_or_vb <- function(plotfun) { plotfun <- mcmc_function_name(plotfun) - if (needs_chains(plotfun) || + if (needs_chains(plotfun) || grepl("_rhat|_neff|_nuts_", plotfun)) STOP_sampling_only(plotfun) } - # pairs method ------------------------------------------------------------ + #' Pairs method for stanreg objects -#' -#' Interface to \pkg{bayesplot}'s \code{\link[bayesplot]{mcmc_pairs}} function +#' +#' Interface to \pkg{bayesplot}'s \code{\link[bayesplot]{mcmc_pairs}} function #' for use with \pkg{rstanarm} models. Be careful not to specify too #' many parameters to include or the plot will be both hard to read and slow to #' render. @@ -324,57 +441,57 @@ validate_plotfun_for_opt_or_vb <- function(plotfun) { #' @importFrom bayesplot pairs_style_np pairs_condition #' @export pairs_style_np pairs_condition #' @aliases pairs_style_np pairs_condition -#' +#' #' @templateVar stanregArg x #' @template args-stanreg-object #' @template args-regex-pars -#' @param pars An optional character vetor of parameter names. All parameters -#' are included by default, but for models with more than just a few -#' parameters it may be far too many to visualize on a small computer screen +#' @param pars An optional character vetor of parameter names. All parameters +#' are included by default, but for models with more than just a few +#' parameters it may be far too many to visualize on a small computer screen #' and also may require substantial computing time. -#' @param condition Same as the \code{condition} argument to +#' @param condition Same as the \code{condition} argument to #' \code{\link[bayesplot]{mcmc_pairs}} except the \emph{default is different} #' for \pkg{rstanarm} models. By default, the \code{mcmc_pairs} function in #' the \pkg{bayesplot} package plots some of the Markov chains (half, in the #' case of an even number of chains) in the panels above the diagonal and the -#' other half in the panels below the diagonal. However since we know that -#' \pkg{rstanarm} models were fit using Stan (which \pkg{bayesplot} doesn't -#' assume) we can make the default more useful by splitting the draws -#' according to the \code{accept_stat__} diagnostic. The plots below the -#' diagonal will contain realizations that are below the median -#' \code{accept_stat__} and the plots above the diagonal will contain +#' other half in the panels below the diagonal. However since we know that +#' \pkg{rstanarm} models were fit using Stan (which \pkg{bayesplot} doesn't +#' assume) we can make the default more useful by splitting the draws +#' according to the \code{accept_stat__} diagnostic. The plots below the +#' diagonal will contain realizations that are below the median +#' \code{accept_stat__} and the plots above the diagonal will contain #' realizations that are above the median \code{accept_stat__}. To change this -#' behavior see the documentation of the \code{condition} argument at +#' behavior see the documentation of the \code{condition} argument at #' \code{\link[bayesplot]{mcmc_pairs}}. -#' @param ... Optional arguments passed to \code{\link[bayesplot]{mcmc_pairs}}. -#' The \code{np}, \code{lp}, and \code{max_treedepth} arguments to -#' \code{mcmc_pairs} are handled automatically by \pkg{rstanarm} and do not -#' need to be specified by the user in \code{...}. The arguments that can be +#' @param ... Optional arguments passed to \code{\link[bayesplot]{mcmc_pairs}}. +#' The \code{np}, \code{lp}, and \code{max_treedepth} arguments to +#' \code{mcmc_pairs} are handled automatically by \pkg{rstanarm} and do not +#' need to be specified by the user in \code{...}. The arguments that can be #' specified in \code{...} include \code{transformations}, \code{diag_fun}, #' \code{off_diag_fun}, \code{diag_args}, \code{off_diag_args}, #' and \code{np_style}. These arguments are #' documented thoroughly on the help page for #' \code{\link[bayesplot]{mcmc_pairs}}. -#' -#' +#' +#' #' @examples #' \donttest{ #' if (!exists("example_model")) example(example_model) -#' +#' #' bayesplot::color_scheme_set("purple") -#' -#' # see 'condition' argument above for details on the plots below and +#' +#' # see 'condition' argument above for details on the plots below and #' # above the diagonal. default is to split by accept_stat__. #' pairs(example_model, pars = c("(Intercept)", "log-posterior")) -#' +#' #' pairs( -#' example_model, -#' regex_pars = "herd:[2,7,9]", +#' example_model, +#' regex_pars = "herd:[2,7,9]", #' diag_fun = "dens", #' off_diag_fun = "hex" #' ) #' } -#' +#' #' \donttest{ #' # for demonstration purposes, intentionally fit a model that #' # will (almost certainly) have some divergences @@ -385,33 +502,33 @@ validate_plotfun_for_opt_or_vb <- function(plotfun) { #' prior = hs(), #' adapt_delta = 0.9 #' ) -#' +#' #' pairs(fit, pars = c("wt", "sigma", "log-posterior")) -#' +#' #' pairs( -#' fit, -#' pars = c("wt", "sigma", "log-posterior"), +#' fit, +#' pars = c("wt", "sigma", "log-posterior"), #' transformations = list(sigma = "log"), # show log(sigma) instead of sigma #' off_diag_fun = "hex" # use hexagonal heatmaps instead of scatterplots #' ) -#' -#' +#' +#' #' bayesplot::color_scheme_set("brightblue") #' pairs( -#' fit, -#' pars = c("(Intercept)", "wt", "sigma", "log-posterior"), -#' transformations = list(sigma = "log"), +#' fit, +#' pars = c("(Intercept)", "wt", "sigma", "log-posterior"), +#' transformations = list(sigma = "log"), #' off_diag_args = list(size = 3/4, alpha = 1/3), # size and transparency of scatterplot points #' np_style = pairs_style_np(div_color = "black", div_shape = 2) # color and shape of the divergences #' ) -#' -#' # Using the condition argument to show divergences above the diagonal +#' +#' # Using the condition argument to show divergences above the diagonal #' pairs( -#' fit, -#' pars = c("(Intercept)", "wt", "log-posterior"), +#' fit, +#' pars = c("(Intercept)", "wt", "log-posterior"), #' condition = pairs_condition(nuts = "divergent__") #' ) -#' +#' #' } #' pairs.stanreg <- @@ -420,21 +537,21 @@ pairs.stanreg <- regex_pars = NULL, condition = pairs_condition(nuts = "accept_stat__"), ...) { - + if (!used.sampling(x)) STOP_sampling_only("pairs") - + dots <- list(...) ignored_args <- c("np", "lp", "max_treedepth") specified <- ignored_args %in% names(dots) if (any(specified)) { warning( "The following arguments were ignored because they are ", - "specified automatically by rstanarm: ", + "specified automatically by rstanarm: ", paste(sQuote(ignored_args[specified]), collapse = ", ") ) } - + posterior <- as.array.stanreg(x, pars = pars, regex_pars = regex_pars) if (is.null(pars) && is.null(regex_pars)) { # include log-posterior by default @@ -449,16 +566,16 @@ pairs.stanreg <- posterior <- tmp } posterior <- round(posterior, digits = 12) - + bayesplot::mcmc_pairs( - x = posterior, - np = bayesplot::nuts_params(x), - lp = bayesplot::log_posterior(x), + x = posterior, + np = bayesplot::nuts_params(x), + lp = bayesplot::log_posterior(x), max_treedepth = .max_treedepth(x), condition = condition, ... ) - + } From b8cb081392586ac0f801310c137477e9ad6b35dc Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 12:27:27 +1100 Subject: [PATCH 008/225] Add stop to posterior_linpred for stansurv objects --- R/posterior_linpred.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/posterior_linpred.R b/R/posterior_linpred.R index a642ac3f2..7dd654980 100644 --- a/R/posterior_linpred.R +++ b/R/posterior_linpred.R @@ -80,9 +80,10 @@ posterior_linpred.stanreg <- XZ = FALSE, ...) { - if (is.stanmvreg(object)) { + if (is.stanmvreg(object)) STOP_if_stanmvreg("'posterior_linpred'") - } + if (is.stansurv(object)) + STOP_if_stansurv("'poterior_linpred'") newdata <- validate_newdata(newdata) dat <- pp_data(object, From c3f570aad38a2a05247d49d58844fcacadf7c5f3 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 12:29:20 +1100 Subject: [PATCH 009/225] Add stop to posterior_predict for stansurv objects --- R/posterior_predict.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/posterior_predict.R b/R/posterior_predict.R index 96c3a69e9..384a12204 100644 --- a/R/posterior_predict.R +++ b/R/posterior_predict.R @@ -143,6 +143,9 @@ posterior_predict.stanreg <- function(object, newdata = NULL, draws = NULL, offset = NULL, ...) { if (used.optimizing(object)) STOP_not_optimizing("posterior_predict") + if (is.stansurv(object)) + stop2("'posterior_predict' is not implemented for stansurv objects. ", + "Use 'posterior_survfit' instead.") if (!is.null(seed)) set.seed(seed) if (!is.null(fun)) From 4ca076ee3bc2d0ece8631cf11a5b6e7829a25978 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 12:33:34 +1100 Subject: [PATCH 010/225] Move offsets to bottom of pp_data.R --- R/pp_data.R | 66 ++++++++++++++++++++++++++--------------------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index a2b2e5bd6..2390fecb4 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -233,39 +233,6 @@ pp_data <- } - -# handle offsets ---------------------------------------------------------- -null_or_zero <- function(x) { - isTRUE(is.null(x) || all(x == 0)) -} - -.pp_data_offset <- function(object, newdata = NULL, offset = NULL) { - if (is.null(newdata)) { - # get offset from model object (should be null if no offset) - if (is.null(offset)) - offset <- object$offset %ORifNULL% model.offset(model.frame(object)) - } else { - if (!is.null(offset)) - stopifnot(length(offset) == nrow(newdata)) - else { - # if newdata specified but not offset then confirm that model wasn't fit - # with an offset (warning, not error) - if (!is.null(object$call$offset) || - !null_or_zero(object$offset) || - !null_or_zero(model.offset(model.frame(object)))) { - warning( - "'offset' argument is NULL but it looks like you estimated ", - "the model using an offset term.", - call. = FALSE - ) - } - offset <- rep(0, nrow(newdata)) - } - } - return(offset) -} - - #----------------------- pp_data for joint models -------------------------- # Return the design matrices required for evaluating the linear predictor or @@ -462,3 +429,36 @@ get_model_data <- function(object, m = NULL) { mfs <- list_nms(mfs, M, stub = get_stub(object)) if (is.null(m)) mfs else mfs[[m]] } + + +#----------------------- handle offsets ---------------------------------- + +null_or_zero <- function(x) { + isTRUE(is.null(x) || all(x == 0)) +} + +.pp_data_offset <- function(object, newdata = NULL, offset = NULL) { + if (is.null(newdata)) { + # get offset from model object (should be null if no offset) + if (is.null(offset)) + offset <- object$offset %ORifNULL% model.offset(model.frame(object)) + } else { + if (!is.null(offset)) + stopifnot(length(offset) == nrow(newdata)) + else { + # if newdata specified but not offset then confirm that model wasn't fit + # with an offset (warning, not error) + if (!is.null(object$call$offset) || + !null_or_zero(object$offset) || + !null_or_zero(model.offset(model.frame(object)))) { + warning( + "'offset' argument is NULL but it looks like you estimated ", + "the model using an offset term.", + call. = FALSE + ) + } + offset <- rep(0, nrow(newdata)) + } + } + return(offset) +} From 1cdc4e2731abf1eef7e7b24e6bbd97b8b0661c05 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 12:36:50 +1100 Subject: [PATCH 011/225] pp_data.R: add more obvious subheadings to help organise file --- R/pp_data.R | 87 ++++++++++++++++++++++++++++------------------------- 1 file changed, 46 insertions(+), 41 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index 2390fecb4..c1aa409b6 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -35,7 +35,9 @@ pp_data <- .pp_data(object, newdata = newdata, offset = offset, ...) } -# for models without lme4 structure + +#------------- for models without lme4 structure ------------------------- + .pp_data <- function(object, newdata = NULL, offset = NULL, ...) { if (is(object, "gamm4")) { requireNamespace("mgcv", quietly = TRUE) @@ -78,7 +80,8 @@ pp_data <- } -# for models fit using stan_(g)lmer or stan_gamm4 +#--------- for models fit using stan_(g)lmer or stan_gamm4 ----------------- + .pp_data_mer <- function(object, newdata, re.form, m = NULL, ...) { if (is(object, "gamm4")) { requireNamespace("mgcv", quietly = TRUE) @@ -102,44 +105,6 @@ pp_data <- return(nlist(x, offset = offset, Zt = z$Zt, Z_names = z$Z_names)) } -# for models fit using stan_nlmer -.pp_data_nlmer <- function(object, newdata, re.form, offset = NULL, m = NULL, ...) { - inputs <- parse_nlf_inputs(object$glmod$respMod) - if (is.null(newdata)) { - arg1 <- arg2 <- NULL - } else if (object$family$link == "inv_SSfol") { - arg1 <- newdata[[inputs[2]]] - arg2 <- newdata[[inputs[3]]] - } else { - arg1 <- newdata[[inputs[2]]] - arg2 <- NULL - } - f <- formula(object, m = m) - if (!is.null(re.form) && !is.na(re.form)) { - f <- as.character(f) - f[3] <- as.character(re.form) - f <- as.formula(f[-1]) - } - if (is.null(newdata)) newdata <- model.frame(object) - else { - yname <- names(model.frame(object))[1] - newdata[[yname]] <- 0 - } - mc <- match.call(expand.dots = FALSE) - mc$re.form <- mc$offset <- mc$object <- mc$newdata <- NULL - mc$data <- newdata - mc$formula <- f - mc$start <- fixef(object) - nlf <- nlformula(mc) - offset <- .pp_data_offset(object, newdata, offset) - - group <- with(nlf$reTrms, pad_reTrms(Ztlist, cnms, flist)) - if (!is.null(re.form) && !is(re.form, "formula") && is.na(re.form)) - group$Z@x <- 0 - return(nlist(x = nlf$X, offset = offset, Z = group$Z, - Z_names = make_b_nms(group), arg1, arg2)) -} - # the functions below are heavily based on a combination of # lme4:::predict.merMod and lme4:::mkNewReTrms, although they do also have # substantial modifications @@ -233,7 +198,47 @@ pp_data <- } -#----------------------- pp_data for joint models -------------------------- +#------------- for models fit using stan_nlmer ----------------------------- + +.pp_data_nlmer <- function(object, newdata, re.form, offset = NULL, m = NULL, ...) { + inputs <- parse_nlf_inputs(object$glmod$respMod) + if (is.null(newdata)) { + arg1 <- arg2 <- NULL + } else if (object$family$link == "inv_SSfol") { + arg1 <- newdata[[inputs[2]]] + arg2 <- newdata[[inputs[3]]] + } else { + arg1 <- newdata[[inputs[2]]] + arg2 <- NULL + } + f <- formula(object, m = m) + if (!is.null(re.form) && !is.na(re.form)) { + f <- as.character(f) + f[3] <- as.character(re.form) + f <- as.formula(f[-1]) + } + if (is.null(newdata)) newdata <- model.frame(object) + else { + yname <- names(model.frame(object))[1] + newdata[[yname]] <- 0 + } + mc <- match.call(expand.dots = FALSE) + mc$re.form <- mc$offset <- mc$object <- mc$newdata <- NULL + mc$data <- newdata + mc$formula <- f + mc$start <- fixef(object) + nlf <- nlformula(mc) + offset <- .pp_data_offset(object, newdata, offset) + + group <- with(nlf$reTrms, pad_reTrms(Ztlist, cnms, flist)) + if (!is.null(re.form) && !is(re.form, "formula") && is.na(re.form)) + group$Z@x <- 0 + return(nlist(x = nlf$X, offset = offset, Z = group$Z, + Z_names = make_b_nms(group), arg1, arg2)) +} + + +#-------------------- for models fit using stan_jm ----------------------- # Return the design matrices required for evaluating the linear predictor or # log-likelihood in post-estimation functions for a \code{stan_jm} model From e433b0a43c104a733315461ee662b5cc77c781d5 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 12:46:35 +1100 Subject: [PATCH 012/225] Add pp_data for stansurv objects --- R/pp_data.R | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 91 insertions(+) diff --git a/R/pp_data.R b/R/pp_data.R index c1aa409b6..2ef7d52c4 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -32,6 +32,9 @@ pp_data <- if (!is.null(offset)) out$offset <- offset return(out) } + if (is.stansurv(object)) { + return(.pp_data_surv(object, newdata = newdata, ...)) + } .pp_data(object, newdata = newdata, offset = offset, ...) } @@ -238,6 +241,94 @@ pp_data <- } +#------------------ for models fit using stan_surv ----------------------- + +.pp_data_surv <- function(object, + newdata = NULL, + times = NULL, + at_quadpoints = FALSE, + ...) { + + formula <- object$formula + basehaz <- object$basehaz + + if (is.null(newdata)) + newdata <- get_model_data(object) + + # flags + has_tde <- object$has_tde + has_quadrature <- object$has_quadrature + + # define dimensions and times for quadrature + if (has_quadrature && at_quadpoints) { + + if (is.null(times)) + stop("Bug found: 'times' must be specified.") + + # error check time variables + if (length(times) == nrow(newdata)) + stop("Bug found: length of 'times' should equal number rows in the data.") + + # number of nodes + qnodes <- object$qnodes + + # standardised weights and nodes for quadrature + qq <- get_quadpoints(nodes = qnodes) + qp <- qq$points + qw <- qq$weights + + # quadrature points & weights, evaluated for each row of data + pts <- uapply(qp, unstandardise_qpts, 0, times) + wts <- uapply(qw, unstandardise_qwts, 0, times) + + # id vector for quadrature points + ids <- factor(rep(1:length(times), times = qnodes)) + + } else { # predictions don't require quadrature + + pts <- times + wts <- rep(NA, length(times)) + ids <- factor(1:length(times)) + qnodes <- NULL + + } + + # model frame for predictor matrices + mf <- make_model_frame(formula = formula$tf_form, + data = newdata, + check_constant = FALSE)$mf + + # time-fixed predictor matrix + x <- make_x(formula = object$formula$tf_form, + model_frame = mf, + xlevs = object$xlevs, + check_constant = FALSE)$x + if (has_quadrature && at_quadpoints) { + x <- rep_rows(x, times = qnodes) + } + + # time-varying predictor matrix + if (has_tde) { + s <- make_s(formula = object$formula$td_form, + data = newdata, + times = pts, # prediction times or quadrature points + xlevs = object$xlevs) + } else { # model does not have tde + s <- matrix(0, length(pts), 0) + } + + # return object + return(nlist(pts, + wts, + ids, + x, + s, + has_quadrature, + at_quadpoints, + qnodes)) +} + + #-------------------- for models fit using stan_jm ----------------------- # Return the design matrices required for evaluating the linear predictor or From 0d73af6885e4f9a28e3931bc6bff34b8c5a5eb06 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 12:58:30 +1100 Subject: [PATCH 013/225] Get print.stanreg working for stansurv objects --- R/print-and-summary.R | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/R/print-and-summary.R b/R/print-and-summary.R index dc0e1eb83..124f83208 100644 --- a/R/print-and-summary.R +++ b/R/print-and-summary.R @@ -76,12 +76,20 @@ #' print.stanreg <- function(x, digits = 1, ...) { cat(x$stan_function) - cat("\n family: ", family_plus_link(x)) - cat("\n formula: ", formula_string(formula(x))) - cat("\n observations:", nobs(x)) - if (isTRUE(x$stan_function %in% - c("stan_glm", "stan_glm.nb", "stan_lm", "stan_aov"))) { - cat("\n predictors: ", length(coef(x))) + surv <- is.surv(x) + if (surv) { + cat("\n baseline hazard:", basehaz_string(x$basehaz)) + cat("\n formula: ", formula_string(formula(x))) + cat("\n observations: ", x$nobs) + cat("\n events: ", x$nevents, percent_string(x$nevents, x$nobs)) + cat("\n censored: ", x$ncensor, percent_string(x$ncensor, x$nobs)) + cat("\n delayed entry: ", yes_no_string(x$ndelayed)) + } else { + cat("\n family: ", family_plus_link(x)) + cat("\n formula: ", formula_string(formula(x))) + cat("\n observations:", nobs(x)) + if (isTRUE(x$stan_function %in% c("stan_glm", "stan_glm.nb", "stan_lm", "stan_aov"))) + cat("\n predictors: ", length(coef(x))) } cat("\n------\n") @@ -124,6 +132,15 @@ print.stanreg <- function(x, digits = 1, ...) { if (mer) { estimates <- estimates[!grepl("^Sigma\\[", rownames(estimates)),, drop=FALSE] } + if (surv) { + nms_int <- get_int_name_basehaz(get_basehaz(x)) + nms_aux <- get_aux_name_basehaz(get_basehaz(x)) + nms_beta <- setdiff(rownames(estimates), c(nms_int, nms_aux)) + estimates <- cbind(estimates, + "exp(Median)" = c(rep(NA, length(nms_int)), + exp(estimates[nms_beta, "Median"]), + rep(NA, length(nms_aux)))) + } .printfr(estimates, digits, ...) if (length(aux_nms)) { @@ -148,7 +165,7 @@ print.stanreg <- function(x, digits = 1, ...) { if (is(x, "aov")) { print_anova_table(x, digits, ...) } - if (!no_mean_PPD(x) && !is_clogit(x)) { + if (!no_mean_PPD(x) && !is_clogit(x) && !is.stansurv(x)) { ppd_mat <- mat[, ppd_nms, drop = FALSE] ppd_estimates <- .median_and_madsd(ppd_mat) From 3698466360b63f2a94b82eb7d1ca1fcc16d34c39 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 13:08:28 +1100 Subject: [PATCH 014/225] Get summary.stanreg working for stansurv objects --- R/print-and-summary.R | 103 ++++++++++++++++++++++++++++++------------ 1 file changed, 75 insertions(+), 28 deletions(-) diff --git a/R/print-and-summary.R b/R/print-and-summary.R index 124f83208..3d64c7695 100644 --- a/R/print-and-summary.R +++ b/R/print-and-summary.R @@ -382,7 +382,8 @@ print.stanmvreg <- function(x, digits = 3, ...) { #' @importMethodsFrom rstan summary summary.stanreg <- function(object, pars = NULL, regex_pars = NULL, probs = NULL, ..., digits = 1) { - mer <- is.mer(object) + surv <- is.surv(object) + mer <- is.mer(object) pars <- collect_pars(object, pars, regex_pars) if (!used.optimizing(object)) { @@ -428,21 +429,27 @@ summary.stanreg <- function(object, pars = NULL, regex_pars = NULL, out <- object$stan_summary[mark, , drop=FALSE] } + is_glm <- + isTRUE(object$stan_function %in% c("stan_glm", "stan_glm.nb", "stan_lm")) + structure( out, - call = object$call, - algorithm = object$algorithm, + call = object$call, + algorithm = object$algorithm, stan_function = object$stan_function, - family = family_plus_link(object), - formula = formula(object), + family = family_plus_link(object), + formula = formula(object), + basehaz = if (surv) basehaz_string(get_basehaz(object)) else NULL, posterior_sample_size = posterior_sample_size(object), - nobs = nobs(object), - npreds = if (isTRUE(object$stan_function %in% c("stan_glm", "stan_glm.nb", "stan_lm"))) - length(coef(object)) else NULL, - ngrps = if (mer) ngrps(object) else NULL, - print.digits = digits, - priors = object$prior.info, - class = "summary.stanreg" + nobs = nobs(object), + npreds = if (is_glm) length(coef(object)) else NULL, + ngrps = if (mer) ngrps(object) else NULL, + nevents = if (surv) object$nevents else NULL, + ncensor = if (surv) object$ncensor else NULL, + ndelayed = if (surv) object$ndelayed else NULL, + print.digits = digits, + priors = object$prior.info, + class = "summary.stanreg" ) } @@ -455,20 +462,35 @@ print.summary.stanreg <- function(x, digits = max(1, attr(x, "print.digits")), ...) { atts <- attributes(x) cat("\nModel Info:\n") - cat("\n function: ", atts$stan_function) - cat("\n family: ", atts$family) - cat("\n formula: ", formula_string(atts$formula)) - cat("\n algorithm: ", atts$algorithm) - cat("\n priors: ", "see help('prior_summary')") - if (!is.null(atts$posterior_sample_size) && atts$algorithm == "sampling") - cat("\n sample: ", atts$posterior_sample_size, "(posterior sample size)") - cat("\n observations:", atts$nobs) - if (!is.null(atts$npreds)) - cat("\n predictors: ", atts$npreds) - if (!is.null(atts$ngrps)) - cat("\n groups: ", paste0(names(atts$ngrps), " (", - unname(atts$ngrps), ")", - collapse = ", ")) + + if (is.surv(atts)) { # survival models + cat("\n function: ", atts$stan_function) + cat("\n baseline hazard:", atts$basehaz) + cat("\n formula: ", formula_string(atts$formula)) + cat("\n algorithm: ", atts$algorithm) + cat("\n priors: ", "see help('prior_summary')") + if (!is.null(atts$posterior_sample_size) && atts$algorithm == "sampling") + cat("\n sample: ", atts$posterior_sample_size, "(posterior sample size)") + cat("\n observations: ", atts$nobs) + cat("\n events: ", atts$nevents, percent_string(atts$nevents, atts$nobs)) + cat("\n censored: ", atts$ncensor, percent_string(atts$ncensor, atts$nobs)) + cat("\n delayed entry: ", yes_no_string(atts$ndelayed)) + } else { # anything except survival models + cat("\n function: ", atts$stan_function) + cat("\n family: ", atts$family) + cat("\n formula: ", formula_string(atts$formula)) + cat("\n algorithm: ", atts$algorithm) + cat("\n priors: ", "see help('prior_summary')") + if (!is.null(atts$posterior_sample_size) && atts$algorithm == "sampling") + cat("\n sample: ", atts$posterior_sample_size, "(posterior sample size)") + cat("\n observations:", atts$nobs) + if (!is.null(atts$npreds)) + cat("\n predictors: ", atts$npreds) + if (!is.null(atts$ngrps)) + cat("\n groups: ", paste0(names(atts$ngrps), " (", + unname(atts$ngrps), ")", + collapse = ", ")) + } cat("\n\nEstimates:\n") sel <- which(colnames(x) %in% c("mcse", "n_eff", "Rhat")) @@ -702,6 +724,9 @@ allow_special_parnames <- function(object, pars) { # @param x stanreg object # @param ... Optionally include m to specify which submodel for stanmvreg models family_plus_link <- function(x, ...) { + if (is.stansurv(x)) { + return(NULL) + } fam <- family(x, ...) if (is.character(fam)) { stopifnot(identical(fam, x$method)) @@ -730,7 +755,7 @@ formula_string <- function(formula, break_and_indent = TRUE) { # get name of aux parameter based on family .aux_name <- function(object) { aux <- character() - if (!is_polr(object)) { + if (!is_polr(object) && !is.stansurv(object)) { aux <- .rename_aux(family(object)) if (is.na(aux)) { aux <- character() @@ -739,7 +764,6 @@ formula_string <- function(formula, break_and_indent = TRUE) { return(aux) } - # print anova table for stan_aov models # @param x stanreg object created by stan_aov() print_anova_table <- function(x, digits, ...) { @@ -763,6 +787,29 @@ print_anova_table <- function(x, digits, ...) { .printfr(anova_table, digits, ...) } +# @param basehaz A list with info about the baseline hazard +basehaz_string <- function(basehaz, break_and_indent = TRUE) { + nm <- get_basehaz_name(basehaz) + switch(nm, + exp = "exponential", + weibull = "weibull", + gompertz = "gompertz", + ms = "M-splines on hazard scale", + bs = "B-splines on log hazard scale", + piecewise= "piecewise constant on log hazard scale", + NULL) +} + +# @param x A logical (or a scalar to be evaluated as a logical). +yes_no_string <- function(x) { + if (x) "yes" else "no" +} + +# @param numer,denom The numerator and denominator with which to evaluate a %. +percent_string <- function(numer, denom) { + val <- round(100 * numer / denom, 1) + paste0("(", val, "%)") +} # equivalent to isFALSE(object$compute_mean_PPD) no_mean_PPD <- function(object) { From 3196062ced7172921d96e35268f77844434d97aa Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 13:10:33 +1100 Subject: [PATCH 015/225] Add stansurv objects to prior_summary --- R/prior_summary.R | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/R/prior_summary.R b/R/prior_summary.R index 71cb8c8be..d75dc5d66 100644 --- a/R/prior_summary.R +++ b/R/prior_summary.R @@ -269,6 +269,42 @@ print.prior_summary.stanreg <- function(x, digits, ...) { ) } + # unique to stan_surv + if (stan_function == "stan_surv") { + if (!is.null(x[["priorEvent_intercept"]])) + .print_scalar_prior( + x[["priorEvent_intercept"]], + txt = paste0("Intercept"), # predictors not currently centered + formatters + ) + has_intercept <- !is.null(x[["priorEvent_intercept"]]) + if (!is.null(x[["priorEvent"]])) + .print_vector_prior( + x[["priorEvent"]], + txt = paste0(if (has_intercept) "\n", "Coefficients"), + formatters = formatters + ) + if (!is.null(x[["priorEvent_aux"]])) { + aux_name <- x[["priorEvent_aux"]][["aux_name"]] + aux_dist <- x[["priorEvent_aux"]][["dist"]] + if ((aux_name %in% c("weibull-shape", "gompertz-scale")) && + (aux_dist %in% c("normal", "student_t", "cauchy"))) { # weibull, gompertz + x[["priorEvent_aux"]][["dist"]] <- paste0("half-", aux_dist) + .print_scalar_prior( + x[["priorEvent_aux"]], + txt = paste0("\nAuxiliary (", aux_name, ")"), + formatters + ) + } else { # ms, bs, piecewise + .print_vector_prior( + x[["priorEvent_aux"]], + txt = paste0("\nAuxiliary (", aux_name, ")"), + formatters + ) + } + } + } + # unique to stan_(g)lmer, stan_gamm4, stan_mvmer, or stan_jm if (!is.null(x[["prior_covariance"]])) .print_covariance_prior(x[["prior_covariance"]], txt = "\nCovariance", formatters) From 932026dd754b44d053c3d3aa9e5888e6f3856330 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 13:23:03 +1100 Subject: [PATCH 016/225] Add stansurv objects to ps_check --- R/ps_check.R | 145 +++++++++++++++++++++++++++------------------------ 1 file changed, 77 insertions(+), 68 deletions(-) diff --git a/R/ps_check.R b/R/ps_check.R index cfbe9686e..adf5d5158 100644 --- a/R/ps_check.R +++ b/R/ps_check.R @@ -1,116 +1,125 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2015, 2016, 2017 Trustees of Columbia University # Copyright (C) 2016, 2017 Sam Brilleman -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. # #' Graphical checks of the estimated survival function -#' +#' #' This function plots the estimated marginal survival function based on draws -#' from the posterior predictive distribution of the fitted joint model, and then -#' overlays the Kaplan-Meier curve based on the observed data. -#' +#' from the posterior predictive distribution of the fitted model, +#' and then overlays a Kaplan-Meier curve based on the observed data. +#' +#' @importFrom ggplot2 ggplot aes_string geom_step #' @export -#' @templateVar stanjmArg object +#' @templateVar stanregArg object #' @templateVar labsArg xlab,ylab #' @templateVar cigeomArg ci_geom_args -#' @template args-stanjm-object +#' @template args-stansurv-stanjm-object #' @template args-labs #' @template args-ci-geom-args -#' -#' @param check The type of plot to show. Currently only "survival" is -#' allowed, which compares the estimated marginal survival function under -#' the joint model to the estimated Kaplan-Meier curve based on the -#' observed data. +#' +#' @param check The type of plot to show. Currently only "survival" is +#' allowed, which compares the estimated marginal survival function +#' under the fitted model to the estimated Kaplan-Meier curve based +#' on the observed data. #' @param limits A quoted character string specifying the type of limits to #' include in the plot. Can be one of: \code{"ci"} for the Bayesian #' posterior uncertainty interval (often known as a credible interval); #' or \code{"none"} for no interval limits. -#' @param draws An integer indicating the number of MCMC draws to use to -#' to estimate the survival function. The default and maximum number of +#' @param draws An integer indicating the number of MCMC draws to use to +#' to estimate the survival function. The default and maximum number of #' draws is the size of the posterior sample. #' @param seed An optional \code{\link[=set.seed]{seed}} to use. -#' @param ... Optional arguments passed to +#' @param ... Optional arguments passed to #' \code{\link[ggplot2]{geom_line}} and used to control features #' of the plotted trajectory. -#' +#' #' @return A ggplot object that can be further customized using the #' \pkg{ggplot2} package. -#' -#' @seealso \code{\link{posterior_survfit}} for the estimated marginal or +#' +#' @seealso +#' \code{\link{posterior_survfit}} for the estimated marginal or #' subject-specific survival function based on draws of the model parameters -#' from the posterior distribution, -#' \code{\link{posterior_predict}} for drawing from the posterior -#' predictive distribution for the longitudinal submodel, and -#' \code{\link{pp_check}} for graphical checks of the longitudinal submodel. -#' +#' from the posterior distribution \cr +#' \code{\link{posterior_predict}} for drawing from the posterior +#' predictive distribution for the longitudinal submodel (for +#' \code{\link{stan_jm}} models only) \cr +#' \code{\link{pp_check}} for graphical checks of the longitudinal submodel +#' (for \code{\link{stan_jm}} models only) +#' #' @examples #' \donttest{ #' if (!exists("example_jm")) example(example_jm) #' # Compare estimated survival function to Kaplan-Meier curve #' ps <- ps_check(example_jm) -#' ps + -#' ggplot2::scale_color_manual(values = c("red", "black")) + # change colors -#' ggplot2::scale_size_manual(values = c(0.5, 3)) + # change line sizes -#' ggplot2::scale_fill_manual(values = c(NA, NA)) # remove fill +#' ps + +#' ggplot2::scale_color_manual(values = c("red", "black")) + # change colors +#' ggplot2::scale_size_manual (values = c(0.5, 3)) + # change line sizes +#' ggplot2::scale_fill_manual (values = c(NA, NA)) # remove fill #' } -#' @importFrom ggplot2 ggplot aes_string geom_step -#' -ps_check <- function(object, check = "survival", +#' +ps_check <- function(object, + check = "survival", limits = c("ci", "none"), - draws = NULL, seed = NULL, - xlab = NULL, ylab = NULL, - ci_geom_args = NULL, ...) { + draws = NULL, + seed = NULL, + xlab = NULL, + ylab = NULL, + ci_geom_args = NULL, + ...) { + if (!requireNamespace("survival")) stop("the 'survival' package must be installed to use this function") - - validate_stanjm_object(object) + + if (!any(is.stansurv(object), is.stanjm(object))) + stop("Object is not a 'stansurv' or 'stanjm' object.") + limits <- match.arg(limits) - # Predictions for plotting the estimated survival function - dat <- posterior_survfit(object, standardise = TRUE, - condition = FALSE, - times = 0, extrapolate = TRUE, - draws = draws, seed = seed) - - # Estimate KM curve based on response from the event submodel - form <- reformulate("1", response = formula(object)$Event[[2]]) - coxdat <- object$survmod$mod$y - if (is.null(coxdat)) - stop("Bug found: no response y found in the 'survmod' component of the ", - "fitted joint model.") - resp <- attr(coxdat, "type") - if (resp == "right") { - form <- formula(survival::Surv(time, status) ~ 1) - } else if (resp == "counting") { - form <- formula(survival::Surv(start, stop, time) ~ 1) - } else { - stop("Bug found: only 'right' or 'counting' survival outcomes should ", - "have been allowed as the response type in the fitted joint model.") - } - km <- survival::survfit(form, data = as.data.frame(unclass(coxdat))) - kmdat <- data.frame(times = km$time, surv = km$surv, - lb = km$lower, ub = km$upper) - - # Plot estimated survival function with KM curve overlaid - graph <- plot.survfit.stanjm(dat, ids = NULL, limits = limits, ...) - kmgraph <- geom_step(data = kmdat, - mapping = aes_string(x = "times", y = "surv")) - graph + kmgraph -} + # Obtain standardised survival probabilities for the fitted model + dat <- posterior_survfit(object, + times = 0, + extrapolate = TRUE, + standardise = TRUE, + condition = FALSE, + draws = draws, + seed = seed) + + # Obtain the response variable for the fitted model + response <- get_surv(object) + if (is.null(response)) + stop("Bug found: no response variable found in fitted model object.") + # Obtain the formula for KM curve + type <- attr(response, "type") + form <- switch(type, + right = formula(survival::Surv(time, status, type = type) ~ 1), + counting = formula(survival::Surv(start, stop, status, type = type) ~ 1), + interval = formula(survival::Surv(time1, time2, status, type = 'interval') ~ 1), + interval2= formula(survival::Surv(time1, time2, status, type = 'interval') ~ 1), + stop("Bug found: invalid type of survival object.")) + # Obtain the KM estimates + kmfit <- survival::survfit(form, data = data.frame(unclass(response))) + kmdat <- data.frame(times = kmfit$time, surv = kmfit$surv) + + # Plot estimated survival function with KM curve overlaid + psgraph <- plot.survfit.stanjm(dat, ids = NULL, limits = limits, ...) + kmgraph <- geom_step(aes_string(x = "times", y = "surv"), kmdat) + psgraph + kmgraph +} From 2a804c1e5035d9d9ea865ccfd2f7b28fbf6dfe1f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 13:37:00 +1100 Subject: [PATCH 017/225] Add some tests for stan_surv --- .../helpers/{get_tols.R => get_tols_jm.R} | 0 tests/testthat/helpers/get_tols_surv.R | 29 ++ .../{recover_pars.R => recover_pars_jm.R} | 0 tests/testthat/helpers/recover_pars_surv.R | 19 ++ tests/testthat/test_stan_jm.R | 4 +- tests/testthat/test_stan_surv.R | 263 ++++++++++++++++++ 6 files changed, 313 insertions(+), 2 deletions(-) rename tests/testthat/helpers/{get_tols.R => get_tols_jm.R} (100%) create mode 100644 tests/testthat/helpers/get_tols_surv.R rename tests/testthat/helpers/{recover_pars.R => recover_pars_jm.R} (100%) create mode 100644 tests/testthat/helpers/recover_pars_surv.R create mode 100644 tests/testthat/test_stan_surv.R diff --git a/tests/testthat/helpers/get_tols.R b/tests/testthat/helpers/get_tols_jm.R similarity index 100% rename from tests/testthat/helpers/get_tols.R rename to tests/testthat/helpers/get_tols_jm.R diff --git a/tests/testthat/helpers/get_tols_surv.R b/tests/testthat/helpers/get_tols_surv.R new file mode 100644 index 000000000..c3e9da262 --- /dev/null +++ b/tests/testthat/helpers/get_tols_surv.R @@ -0,0 +1,29 @@ +# Use the standard errors from a fitted 'comparison model' to obtain +# the tolerance for each parameter in the joint model +# Obtain parameter specific tolerances that can be used to assess the +# accuracy of parameter estimates in stan_jm models. The tolerances +# are calculated by taking the SE/SD for the parameter estimate in a +# "gold standard" model and multiplying this by the relevant element +# in the 'tolscales' argument. +# +# @param mod The "gold standard" longitudinal model. Likely to be +# a model estimated using coxph. +# @param toscales A named list with elements 'hr_fixef' and 'tde_fixef'. +# +get_tols <- function(mod, tolscales) { + + cl <- class(mod)[1L] + + if (cl == "coxph") { + fixef_ses <- sqrt(diag(mod$var)) + fixef_tols <- tolscales$hr_fixef * fixef_ses + names(fixef_tols) <- names(mod$coefficients) + } + + if ("(Intercept)" %in% names(fixef_tols)) + fixef_tols[["(Intercept)"]] <- 2 * fixef_tols[["(Intercept)"]] + + ret <- Filter(function(x) !is.null(x), list(fixef = fixef_tols)) + + return(ret) +} diff --git a/tests/testthat/helpers/recover_pars.R b/tests/testthat/helpers/recover_pars_jm.R similarity index 100% rename from tests/testthat/helpers/recover_pars.R rename to tests/testthat/helpers/recover_pars_jm.R diff --git a/tests/testthat/helpers/recover_pars_surv.R b/tests/testthat/helpers/recover_pars_surv.R new file mode 100644 index 000000000..673709bc3 --- /dev/null +++ b/tests/testthat/helpers/recover_pars_surv.R @@ -0,0 +1,19 @@ +# Recover parameter estimates and return a list with consistent +# parameter names for comparing stan_surv and coxph estimates +# +# @param mod The fitted survival model. Likely to be a model estimated +# using either coxph or stan_surv. +# +recover_pars <- function(mod) { + + cl <- class(mod)[1L] + + fixef_pars <- switch(cl, + coxph = mod$coefficients, + stansurv = fixef(mod), + NULL) + + ret <- Filter(function(x) !is.null(x), list(fixef = fixef_pars)) + + return(ret) +} diff --git a/tests/testthat/test_stan_jm.R b/tests/testthat/test_stan_jm.R index 5b2eaabd0..9801d57c3 100644 --- a/tests/testthat/test_stan_jm.R +++ b/tests/testthat/test_stan_jm.R @@ -46,8 +46,8 @@ source(test_path("helpers", "expect_ppd.R")) source(test_path("helpers", "expect_equivalent_loo.R")) source(test_path("helpers", "SW.R")) # SW <- function(expr) eval(expr) -source(test_path("helpers", "get_tols.R")) -source(test_path("helpers", "recover_pars.R")) +source(test_path("helpers", "get_tols_jm.R")) +source(test_path("helpers", "recover_pars_jm.R")) context("stan_jm") diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R new file mode 100644 index 000000000..a92dcbb95 --- /dev/null +++ b/tests/testthat/test_stan_surv.R @@ -0,0 +1,263 @@ +# Part of the rstanarm package for estimating model parameters +# Copyright (C) 2015, 2016 Trustees of Columbia University +# Copyright (C) 2017 Sam Brilleman +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 3 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +# tests can be run using devtools::test() or manually by loading testthat +# package and then running the code below possibly with options(mc.cores = 4). + +library(rstanarm) +library(survival) +library(rstpm2) +library(simsurv) +ITER <- 1000 +CHAINS <- 1 +SEED <- 12345 +REFRESH <- 0L +set.seed(SEED) +if (interactive()) + options(mc.cores = parallel::detectCores()) + +TOLSCALES <- list( + hr_fixef = 0.5, # how many SEs can stan_surv HRs be from coxph/stpm2 HRs + tde_fixef = 0.5 # how many SEs can stan_surv tde HRs be from coxph/stpm2 tde HRs +) + +source(test_path("helpers", "expect_matrix.R")) +source(test_path("helpers", "expect_stanreg.R")) +source(test_path("helpers", "expect_stanmvreg.R")) +source(test_path("helpers", "expect_survfit.R")) +source(test_path("helpers", "expect_ppd.R")) +source(test_path("helpers", "expect_equivalent_loo.R")) +source(test_path("helpers", "SW.R")) +# SW <- function(expr) eval(expr) +source(test_path("helpers", "get_tols_surv.R")) +source(test_path("helpers", "recover_pars_surv.R")) + +eo <- function(...) { expect_output (...) } +ee <- function(...) { expect_error (...) } +ew <- function(...) { expect_warning(...) } +up <- function(...) { update(...) } + +#----------------------------- Models ----------------------------------- + +#--- Time fixed covariates, time fixed coefficients + +cov1 <- data.frame(id = 1:1000, + x1 = stats::rbinom(1000, 1, 0.5), + x2 = stats::rnorm (1000, -1, 0.5)) +dat1 <- simsurv(lambdas = 0.1, + gammas = 1.5, + betas = c(x1 = -0.5, x2 = -0.3), + x = cov1, + maxt = 5) +dat1 <- merge(dat1, cov1) +fm1 <- Surv(eventtime, status) ~ x1 + x2 +mod1a <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "ms") +mod1b <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "bs") +mod1c <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "exp") +mod1d <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "weibull") +mod1e <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "gompertz") + + +#-------------------------- Arguments ----------------------------------- + +testmod <- mod1a + +test_that("prior_PD argument works", { + eo(update(testmod, prior_PD = TRUE)) +}) + +test_that("adapt_delta argument works", { + eo(up(testmod, adapt_delta = NULL)) + eo(up(testmod, adapt_delta = 0.8)) + eo(up(testmod, control = list(adapt_delta = NULL))) + eo(up(testmod, control = list(adapt_delta = 0.8))) +}) + +test_that("init argument works", { + eo(up(testmod, init = "prefit")) + eo(up(testmod, init = "0")) + eo(up(testmod, init = 0)) + eo(up(testmod, init = "random")) +}) + +test_that("qnodes argument works", { + eo(up(testmod, qnodes = 7)) + eo(up(testmod, qnodes = 11)) + eo(up(testmod, qnodes = 15)) + ee(up(testmod, qnodes = 1), "must be either 7, 11 or 15") + ee(up(testmod, qnodes = c(1,2)), "numeric vector of length 1") + ee(up(testmod, qnodes = "wrong"), "numeric vector of length 1") +}) + +test_that("basehaz argument works", { + + eo(up(testmod, basehaz = "exp")) + eo(up(testmod, basehaz = "weibull")) + eo(up(testmod, basehaz = "gompertz")) + eo(up(testmod, basehaz = "ms")) + eo(up(testmod, basehaz = "bs")) + eo(up(testmod, basehaz = "piecewise")) + + dfl <- list(df = 5) + knl <- list(knots = c(1,3,5)) + eo(up(testmod, basehaz = "ms", basehaz_ops = dfl)) + eo(up(testmod, basehaz = "ms", basehaz_ops = knl)) + eo(up(testmod, basehaz = "bs", basehaz_ops = dfl)) + eo(up(testmod, basehaz = "bs", basehaz_ops = knl)) + eo(up(testmod, basehaz = "piecewise", basehaz_ops = dfl)) + eo(up(testmod, basehaz = "piecewise", basehaz_ops = knl)) + + eo(ew(up(testmod, basehaz = "exp", basehaz_ops = dfl), "'df' will be ignored")) + eo(ew(up(testmod, basehaz = "exp", basehaz_ops = knl), "'knots' will be ignored")) + eo(ew(up(testmod, basehaz = "weibull", basehaz_ops = dfl), "'df' will be ignored")) + eo(ew(up(testmod, basehaz = "weibull", basehaz_ops = knl), "'knots' will be ignored")) + eo(ew(up(testmod, basehaz = "gompertz",basehaz_ops = dfl), "'df' will be ignored")) + eo(ew(up(testmod, basehaz = "gompertz",basehaz_ops = knl), "'knots' will be ignored")) + + ee(up(testmod, basehaz_ops = list(df = 1)), "must be at least 3") + ee(up(testmod, basehaz_ops = list(knots = -1)), "'knots' must be non-negative") + ee(up(testmod, basehaz_ops = list(knots = c(1,2,50))), "cannot be greater than the largest event time") + +}) + + +#---- Compare parameter estimates: stan_surv vs coxph + + compare_surv <- function(data, basehaz = "weibull", ...) { + require(survival) + fm <- Surv(eventtime, status) ~ X1 + X2 + surv1 <- coxph(fm, data) + stan1 <- stan_surv(formula = fm, + data = data, + basehaz = basehaz, + iter = 1000, + refresh = 0L, + chains = CHAINS, + seed = SEED, ...) + tols <- get_tols(surv1, tolscales = TOLSCALES) + pars_surv <- recover_pars(surv1) + pars_stan <- recover_pars(stan1) + for (i in names(tols$fixef)) + expect_equal(pars_surv$fixef[[i]], + pars_stan$fixef[[i]], + tol = tols$fixef[[i]], + info = basehaz) + } + + #---- weibull data + + set.seed(543634) + covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) + dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1.3, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) + dat <- merge(dat, covs) + + compare_surv(data = dat, basehaz = "weibull") + compare_surv(data = dat, basehaz = "ms") + + #---- gompertz data + + set.seed(45357) + covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) + dat <- simsurv(dist = "gompertz", + lambdas = 0.1, + gammas = 0.05, + betas = c(X1 = -0.6, X2 = -0.4), + x = covs) + dat <- merge(dat, covs) + + compare_surv(data = dat, basehaz = "gompertz") + compare_surv(data = dat, basehaz = "ms") + + +#-------- Check post-estimation functions work + + # fit the models + o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, + data = pbcSurv, + basehaz = "ms", + chains = 1, + cores = 1, + iter = 40, + refresh = 0, + seed = 12345)) + o<-SW(f2 <- update(f1, basehaz = "bs")) + o<-SW(f3 <- update(f1, basehaz = "exp")) + o<-SW(f4 <- update(f1, basehaz = "weibull")) + o<-SW(f5 <- update(f1, basehaz = "gompertz")) + + # new data for predictions + nd1 <- pbcSurv[pbcSurv$id == 2,] + nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] + + # test the models + for (j in c(1:30)) { + + mod <- try(get(paste0("f", j)), silent = TRUE) + + if (class(mod)[1L] == "try-error") { + + cat("Model not found:", paste0("f", j), "\n") + + } else { + + cat("Checking model:", paste0("f", j), "\n") + + test_that("log_lik works with estimation data", { + ll <- log_lik(mod) + expect_matrix(ll) + }) + + test_that("log_lik works with new data (one individual)", { + ll <- log_lik(mod, newdata = nd1) + expect_matrix(ll) + }) + + test_that("log_lik works with new data (multiple individuals)", { + ll <- log_lik(mod, newdata = nd2) + expect_matrix(ll) + }) + + test_that("loo and waic work", { + expect_equivalent_loo(mod) + }) + + test_that("posterior_survfit works with estimation data", { + SW(ps <- posterior_survfit(mod)) + expect_survfit(ps) + }) + + test_that("posterior_survfit works with new data (one individual)", { + SW(ps <- posterior_survfit(mod, newdata = nd1)) + expect_survfit(ps) + }) + + test_that("posterior_survfit works with new data (multiple individuals)", { + SW(ps <- posterior_survfit(mod, newdata = nd2)) + expect_survfit(ps) + }) + + } + } From b406ec81c94e5f8fa5ced00fa3539963bd5b8c58 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 14:24:37 +1100 Subject: [PATCH 018/225] surv.stan: add += in places and avoid integer division --- R/stan_surv.R | 2 ++ .../functions/hazard_functions.stan | 7 +++-- src/stan_files/surv.stan | 27 +++++++++++-------- 3 files changed, 21 insertions(+), 15 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index f74028202..0cec183ea 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -492,6 +492,8 @@ stan_surv <- function(formula, qrcens = if (!has_quadrature) 0L else qrcens, qicens = if (!has_quadrature) 0L else qicens, qdelay = if (!has_quadrature) 0L else qdelay, + Nlcens = if (!has_quadrature) 0L else nlcens, + Nicens = if (!has_quadrature) 0L else nicens, x_cpts = if (!has_quadrature) matrix(0,0,K) else x_cpts, s_cpts = if (!has_quadrature) matrix(0,0,S) else s_cpts, diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan index 710bfbcd7..009727c65 100644 --- a/src/stan_files/functions/hazard_functions.stan +++ b/src/stan_files/functions/hazard_functions.stan @@ -71,6 +71,7 @@ * @param qwts Vector, the quadrature weights * @param log_hazard Vector, log hazard at the quadrature points * @param qnodes Integer, the number of quadrature points for each individual + * @param N Integer, the number of individuals (ie. rows(log_hazard) / qnodes) * @return A vector */ real quadrature_log_surv(vector qwts, vector log_hazard) { @@ -79,9 +80,8 @@ return res; } - vector quadrature_log_cdf(vector qwts, vector log_hazard, int qnodes) { + vector quadrature_log_cdf(vector qwts, vector log_hazard, int qnodes, int N) { int M = rows(log_hazard); - int N = M / qnodes; // num of individuals vector[M] hazard = exp(log_hazard); matrix[N,qnodes] qwts_mat = to_matrix(qwts, N, qnodes); matrix[N,qnodes] haz_mat = to_matrix(hazard, N, qnodes); @@ -93,9 +93,8 @@ vector quadrature_log_cdf2(vector qwts_lower, vector log_hazard_lower, vector qwts_upper, vector log_hazard_upper, - int qnodes) { + int qnodes, int N) { int M = rows(log_hazard_lower); - int N = M / qnodes; // num of individuals vector[M] hazard_lower = exp(log_hazard_lower); vector[M] hazard_upper = exp(log_hazard_upper); matrix[N,qnodes] qwts_lower_mat = to_matrix(qwts_lower, N, qnodes); diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 97e1959fe..544057384 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -408,7 +408,9 @@ data { int nicens; // num. rows w/ interval censoring int ndelay; // num. rows w/ delayed entry int qnodes; // num. nodes for GK quadrature - int Nevent; // num. rows w/ an event, used only in model w/ quadrature + int Nevent; // num. rows w/ an event; used only w/ quadrature + int Nlcens; // num. rows w/ left cens; used only w/ quadrature + int Nicens; // num. rows w/ interval cens; used only w/ quadrature int qevent; // num. quadrature points for rows w/ an event int qlcens; // num. quadrature points for rows w/ left censoring int qrcens; // num. quadrature points for rows w/ right censoring @@ -599,7 +601,8 @@ transformed parameters { beta_tde[beg] = z_beta_tde[beg]; // define first spline coef if (end > beg) { // define subsequent spline coefs for (j in (beg+1):end) { - beta_tde[j] = beta_tde[j-1] + z_beta_tde[j] * smooth_sd[smooth_map[j]]; + real tmp = beta_tde[j-1]; + beta_tde[j] = tmp + z_beta_tde[j] * smooth_sd[smooth_map[j]]; } } } @@ -639,11 +642,11 @@ model { // add intercept if (has_intercept == 1) { - if (nevent > 0) eta_event = eta_event + gamma[1]; - if (nlcens > 0) eta_lcens = eta_lcens + gamma[1]; - if (nrcens > 0) eta_rcens = eta_rcens + gamma[1]; - if (nicens > 0) eta_icens = eta_icens + gamma[1]; - if (ndelay > 0) eta_delay = eta_delay + gamma[1]; + if (nevent > 0) eta_event += gamma[1]; + if (nlcens > 0) eta_lcens += gamma[1]; + if (nrcens > 0) eta_rcens += gamma[1]; + if (nicens > 0) eta_icens += gamma[1]; + if (ndelay > 0) eta_delay += gamma[1]; } // evaluate log hazard and log survival @@ -711,12 +714,12 @@ model { // add on time-varying part to linear predictor if (S > 0) { - eta = eta + s_cpts * beta_tde; + eta += s_cpts * beta_tde; } // add on intercept to linear predictor if (has_intercept == 1) { - eta = eta + gamma[1]; + eta += gamma[1]; } // evaluate log hazard @@ -753,10 +756,12 @@ model { // increment target with log-lik contributions for event submodel if (Nevent > 0) target += lhaz_epts_event; if (qevent > 0) target += quadrature_log_surv(qwts_event, lhaz_qpts_event); - if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, qnodes); + if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, + qnodes, Nlcens); if (qrcens > 0) target += quadrature_log_surv(qwts_rcens, lhaz_qpts_rcens); if (qicens > 0) target += quadrature_log_cdf2(qwts_icenl, lhaz_qpts_icenl, - qwts_icenu, lhaz_qpts_icenu, qnodes); + qwts_icenu, lhaz_qpts_icenu, + qnodes, Nicens); if (qdelay > 0) target += -quadrature_log_surv(qwts_delay, lhaz_qpts_delay); } From a26296d238cac818b9d6845840967a6754056378 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 16:11:46 +1100 Subject: [PATCH 019/225] stan_surv.R: add some missing helper functions --- R/stan_surv.R | 225 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 217 insertions(+), 8 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 0cec183ea..40924e608 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -306,14 +306,14 @@ stan_surv <- function(formula, ok_basehaz <- c("exp", "weibull", "gompertz", "ms", "bs") ok_basehaz_ops <- get_ok_basehaz_ops(basehaz) - basehaz <- handle_basehaz(basehaz = basehaz, - basehaz_ops = basehaz_ops, - ok_basehaz = ok_basehaz, - ok_basehaz_ops = ok_basehaz_ops, - times = t_end, - status = status, - min_t = min(t_beg), - max_t = max(c(t_end,t_upp), na.rm = TRUE)) + basehaz <- handle_basehaz_surv(basehaz = basehaz, + basehaz_ops = basehaz_ops, + ok_basehaz = ok_basehaz, + ok_basehaz_ops = ok_basehaz_ops, + times = t_end, + status = status, + min_t = min(t_beg), + max_t = max(c(t_end,t_upp), na.rm = TRUE)) nvars <- basehaz$nvars # number of basehaz aux parameters # flag if intercept is required for baseline hazard @@ -701,6 +701,215 @@ stan_surv <- function(formula, #---------- internal +# Construct a list with information about the baseline hazard +# +# @param basehaz A string specifying the type of baseline hazard +# @param basehaz_ops A named list with elements df, knots +# @param ok_basehaz A list of admissible baseline hazards +# @param times A numeric vector with eventtimes for each individual +# @param status A numeric vector with event indicators for each individual +# @param min_t Scalar, the minimum entry time across all individuals +# @param max_t Scalar, the maximum event or censoring time across all individuals +# @return A named list with the following elements: +# type: integer specifying the type of baseline hazard, 1L = weibull, +# 2L = b-splines, 3L = piecewise. +# type_name: character string specifying the type of baseline hazard. +# user_df: integer specifying the input to the df argument +# df: integer specifying the number of parameters to use for the +# baseline hazard. +# knots: the knot locations for the baseline hazard. +# bs_basis: The basis terms for the B-splines. This is passed to Stan +# as the "model matrix" for the baseline hazard. It is also used in +# post-estimation when evaluating the baseline hazard for posterior +# predictions since it contains information about the knot locations +# for the baseline hazard (this is implemented via splines::predict.bs). +handle_basehaz_surv <- function(basehaz, + basehaz_ops, + ok_basehaz = c("weibull", "bs", "piecewise"), + ok_basehaz_ops = c("df", "knots"), + times, + status, + min_t, max_t) { + + if (!basehaz %in% ok_basehaz) + stop2("'basehaz' should be one of: ", comma(ok_basehaz)) + + if (!all(names(basehaz_ops) %in% ok_basehaz_ops)) + stop2("'basehaz_ops' can only include: ", comma(ok_basehaz_ops)) + + if (basehaz == "exp") { + + bknots <- NULL # boundary knot locations + iknots <- NULL # internal knot locations + basis <- NULL # spline basis + nvars <- 0L # number of aux parameters, none + + } else if (basehaz == "gompertz") { + + bknots <- NULL # boundary knot locations + iknots <- NULL # internal knot locations + basis <- NULL # spline basis + nvars <- 1L # number of aux parameters, Gompertz scale + + } else if (basehaz == "weibull") { + + bknots <- NULL # boundary knot locations + iknots <- NULL # internal knot locations + basis <- NULL # spline basis + nvars <- 1L # number of aux parameters, Weibull shape + + } else if (basehaz == "bs") { + + df <- basehaz_ops$df + knots <- basehaz_ops$knots + + if (!is.null(df) && !is.null(knots)) + stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") + + if (is.null(df)) + df <- 5L # default df for B-splines, assuming no intercept + # NB this is ignored if the user specified knots + + tt <- times[status == 1] # uncensored event times + if (is.null(knots) && !length(tt)) { + warning2("No observed events found in the data. Censoring times will ", + "be used to evaluate default knot locations for splines.") + tt <- times + } + + bknots <- c(min_t, max_t) + iknots <- get_iknots(tt, df = df, iknots = knots) + basis <- get_basis(tt, iknots = iknots, bknots = bknots, type = "bs") + nvars <- ncol(basis) # number of aux parameters, basis terms + + } else if (basehaz == "ms") { + + df <- basehaz_ops$df + knots <- basehaz_ops$knots + + if (!is.null(df) && !is.null(knots)) { + stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") + } + + tt <- times[status == 1] # uncensored event times + if (is.null(df)) { + df <- 5L # default df for B-splines, assuming no intercept + # NB this is ignored if the user specified knots + } + + tt <- times[status == 1] # uncensored event times + if (is.null(knots) && !length(tt)) { + warning2("No observed events found in the data. Censoring times will ", + "be used to evaluate default knot locations for splines.") + tt <- times + } + + bknots <- c(min_t, max_t) + iknots <- get_iknots(tt, df = df, iknots = knots) + basis <- get_basis(tt, iknots = iknots, bknots = bknots, type = "ms") + nvars <- ncol(basis) # number of aux parameters, basis terms + + } else if (basehaz == "piecewise") { + + df <- basehaz_ops$df + knots <- basehaz_ops$knots + + if (!is.null(df) && !is.null(knots)) { + stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") + } + + if (is.null(df)) { + df <- 6L # default number of segments for piecewise constant + # NB this is ignored if the user specified knots + } + + if (is.null(knots) && !length(tt)) { + warning2("No observed events found in the data. Censoring times will ", + "be used to evaluate default knot locations for piecewise basehaz.") + tt <- times + } + + bknots <- c(min_t, max_t) + iknots <- get_iknots(tt, df = df, iknots = knots) + basis <- NULL # spline basis + nvars <- length(iknots) + 1 # number of aux parameters, dummy indicators + + } + + nlist(type_name = basehaz, + type = basehaz_for_stan(basehaz), + nvars, + iknots, + bknots, + basis, + df = nvars, + user_df = nvars, + knots = if (basehaz == "bs") iknots else c(bknots[1], iknots, bknots[2]), + bs_basis = basis) +} + +# Return a vector with valid names for elements in the list passed to the +# 'basehaz_ops' argument of a 'stan_jm' or 'stan_surv' call +# +# @param basehaz_name A character string, the type of baseline hazard. +# @return A character vector, or NA if unmatched. +get_ok_basehaz_ops <- function(basehaz_name) { + switch(basehaz_name, + weibull = c(), + bs = c("df", "knots"), + piecewise = c("df", "knots"), + ms = c("df", "knots"), + NA) +} + +# Return the integer respresentation for the baseline hazard, used by Stan +# +# @param basehaz_name A character string, the type of baseline hazard. +# @return An integer, or NA if unmatched. +basehaz_for_stan <- function(basehaz_name) { + switch(basehaz_name, + weibull = 1L, + bs = 2L, + piecewise = 3L, + ms = 4L, + exp = 5L, + gompertz = 6L, + NA) +} + +# Return a vector with internal knots for 'x', based on evenly spaced quantiles +# +# @param x A numeric vector. +# @param df The degrees of freedom. If specified, then 'df - degree - intercept'. +# knots are placed at evenly spaced percentiles of 'x'. If 'iknots' is +# specified then 'df' is ignored. +# @return A numeric vector of internal knot locations, or NULL if there are +# no internal knots. +get_iknots <- function(x, df = 6L, degree = 3L, iknots = NULL, intercept = TRUE) { + + # obtain number of internal knots + if (is.null(iknots)) { + nk <- df - degree - intercept + } else { + nk <- length(iknots) + } + + # validate number of internal knots + if (nk < 0) { + stop2("Number of internal knots cannot be negative.") + } + + # obtain default knot locations if necessary + if (is.null(iknots)) { + iknots <- qtile(x, nq = nk + 1) # evenly spaced percentiles + } + + # return internal knot locations, ensuring they are positive + validate_positive_scalar(iknots) + + return(iknots) +} + # Identify whether the type of baseline hazard requires an intercept in # the linear predictor (NB splines incorporate the intercept into the basis). # From 063b09ba15cc5f09e96b80dce45223f4be53a9bb Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 16:20:42 +1100 Subject: [PATCH 020/225] Fix typo in plot.stansurv --- R/plots.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plots.R b/R/plots.R index 6142285cc..a3f32bb63 100644 --- a/R/plots.R +++ b/R/plots.R @@ -207,7 +207,7 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, has_intercept <- check_for_intercept(x$basehaz) t_min <- min(x$entrytime) - t_max <- max(x$exittime) + t_max <- max(x$eventtime) times <- seq(t_min, t_max, by = (t_max - t_min) / 200) if (plotfun == "basehaz") { From b63626df80026e183a6b5f6ef48173382501d217 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 16:21:42 +1100 Subject: [PATCH 021/225] log_lik.R: add evaluators for log baseline hazard or survival --- R/log_lik.R | 156 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 152 insertions(+), 4 deletions(-) diff --git a/R/log_lik.R b/R/log_lik.R index 4376df2bc..801f918c7 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -760,9 +760,9 @@ ll_args.stanjm <- function(object, data, pars, m = 1, } # Log baseline hazard at etimes (if not NULL) and qtimes - log_basehaz <- evaluate_log_basehaz(times = times, - basehaz = basehaz, - coefs = pars$bhcoef) + log_basehaz <- evaluate_log_basehaz2(times = times, + basehaz = basehaz, + coefs = pars$bhcoef) # Log hazard at etimes (if not NULL) and qtimes log_haz <- log_basehaz + e_eta @@ -812,7 +812,7 @@ ll_args.stanjm <- function(object, data, pars, m = 1, # @param basehaz A list with info about the baseline hazard. # @param coefs A vector or matrix of parameter estimates (MCMC draws). # @return A vector or matrix, depending on the input type of coefs. -evaluate_log_basehaz <- function(times, basehaz, coefs) { +evaluate_log_basehaz2 <- function(times, basehaz, coefs) { type <- basehaz$type_name if (type == "weibull") { X <- log(times) # log times @@ -869,3 +869,151 @@ evaluate_log_survival.matrix <- function(log_haz, qnodes, qwts) { # return: -cum_haz == log survival probability -cum_haz } + +#------------- + +# Evaluate the log baseline hazard at the specified times given the +# vector or matrix of MCMC draws for the baseline hazard parameters +# +# @param times A vector of times. +# @param basehaz A list with info about the baseline hazard. +# @param aux,intercept A vector or matrix of parameter estimates (MCMC draws). +# @param x Predictor matrix. +# @param s Predictor matrix for time-dependent effects. +# @return A vector or matrix, depending on the input type of aux. +evaluate_log_basehaz <- function(times, basehaz, aux, intercept = NULL) { + switch(get_basehaz_name(basehaz), + "exp" = log_basehaz_exponential(times, log_scale = intercept), + "weibull" = log_basehaz_weibull (times, shape = aux, log_scale = intercept), + "gompertz" = log_basehaz_gompertz(times, scale = aux, log_shape = intercept), + "ms" = log_basehaz_ms(times, coefs = aux, basis = basehaz$basis), + "bs" = log_basehaz_bs(times, coefs = aux, basis = basehaz$basis), + "piecewise" = log_basehaz_pw(times, coefs = aux, knots = basehaz$knots), + stop2("Bug found: unknown type of baseline hazard.")) +} + +log_basehaz_exponential <- function(x, log_scale) { + linear_predictor(log_scale, rep(1, length(x))) +} +log_basehaz_weibull <- function(x, shape, log_scale) { + as.vector(log_scale + log(shape)) + linear_predictor(shape - 1, log(x)) +} +log_basehaz_gompertz <- function(x, scale, log_shape) { + as.vector(log_shape) + linear_predictor(scale, x) +} +log_basehaz_ms <- function(x, coefs, basis) { + log(linear_predictor(coefs, basis_matrix(x, basis = basis))) +} +log_basehaz_bs <- function(x, coefs, basis) { + linear_predictor(coefs, basis_matrix(x, basis = basis)) +} +log_basehaz_pw <- function(x, coefs, knots) { + linear_predictor(coefs, dummy_matrix(x, knots = knots)) +} + +evaluate_log_haz <- function(times, basehaz, betas, betas_tde, aux, + intercept = NULL, x, s = NULL) { + eta <- linear_predictor(betas, x) + if ((!is.null(s)) && ncol(s)) + eta <- eta + linear_predictor(betas_tde, s) + args <- nlist(times, basehaz, aux, intercept) + do.call(evaluate_log_basehaz, args) + eta +} + +evaluate_basehaz <- function(times, basehaz, aux, intercept = NULL) { + exp(evaluate_log_basehaz(times = times, basehaz = basehaz, + aux = aux, intercept = intercept)) +} + +#------------- + +# Evaluate the log baseline survival at the specified times given the +# vector or matrix of MCMC draws for the baseline hazard parameters +# +# @param times A vector of times. +# @param basehaz A list with info about the baseline hazard. +# @param aux,intercept A vector or matrix of parameter estimates (MCMC draws). +# @return A vector or matrix, depending on the input type of aux. +evaluate_log_basesurv <- function(times, basehaz, aux, intercept = NULL) { + switch(get_basehaz_name(basehaz), + "exp" = log_basesurv_exponential(times, log_scale = intercept), + "weibull" = log_basesurv_weibull (times, shape = aux, log_scale = intercept), + "gompertz" = log_basesurv_gompertz(times, scale = aux, log_shape = intercept), + "ms" = log_basesurv_ms(times, coefs = aux, basis = basehaz$basis), + stop2("Bug found: unknown type of baseline hazard.")) +} + +log_basesurv_exponential <- function(x, log_scale) { + -linear_predictor(exp(log_scale), x) +} +log_basesurv_weibull <- function(x, shape, log_scale) { + -exp(as.vector(log_scale) + linear_predictor(shape, log(x))) +} +log_basesurv_gompertz <- function(x, scale, log_shape) { + -(as.vector(log_shape / scale)) * (exp(linear_predictor(scale, x)) - 1) +} +log_basesurv_ms <- function(x, coefs, basis) { + -linear_predictor(coefs, basis_matrix(x, basis = basis, integrate = TRUE)) +} + +evaluate_log_surv <- function(times, basehaz, betas, aux, intercept = NULL, x, ...) { + eta <- linear_predictor(betas, x) + args <- nlist(times, basehaz, aux, intercept) + do.call(evaluate_log_basesurv, args) * exp(eta) +} + +#--------------- + +quadrature_sum <- function(x, qnodes, qwts) { + UseMethod("quadrature_sum") +} + +quadrature_sum.default <- function(x, qnodes, qwts) { + weighted_x <- qwts * x # apply quadrature weights + splitted_x <- split_vector(x, n_segments = qnodes) # split at each quad node + Reduce('+', splitted_x) # sum over the quad nodes +} + +quadrature_sum.matrix <- function(x, qnodes, qwts) { + weighted_x <- sweep_multiply(x, qwts, margin = 2L) # apply quadrature weights + splitted_x <- array2list(weighted_x, nsplits = qnodes) # split at each quad node + Reduce('+', splitted_x) # sum over the quad nodes +} + +# Split a vector or matrix into a specified number of segments and return +# each segment as an element of a list. The matrix method allows splitting +# across the column (bycol = TRUE) or row margin (bycol = FALSE). +# +# @param x A vector or matrix. +# @param n_segments Integer specifying the number of segments. +# @param bycol Logical, should a matrix be split along the column or row margin? +# @return A list with n_segments elements. +split2 <- function(x, n_segments = 1, ...) { + UseMethod("split2") +} + +split2.vector <- function(x, n_segments = 1, ...) { + len <- length(x) + segment_length <- len %/% n_segments + if (!len == (segment_length * n_segments)) + stop("Dividing x by n_segments does not result in an integer.") + split(x, rep(1:n_segments, each = segment_length)) +} + +split2.matrix <- function(x, n_segments = 1, bycol = TRUE) { + len <- if (bycol) ncol(x) else nrow(x) + segment_length <- len %/% n_segments + if (!len == (segment_length * n_segments)) + stop("Dividing x by n_segments does not result in an integer.") + lapply(1:nsplits, function(k) { + if (bycol) x[, (k-1) * len_k + 1:segment_length, drop = FALSE] else + x[(k-1) * len_k + 1:len_k, , drop = FALSE]}) +} + +# Split a vector or matrix into a specified number of segments +# (see rstanarm:::split2) and then reduce it using 'FUN' +split_and_reduce <- function(x, n_segments = 1, bycol = TRUE, FUN = '+') { + splitted_x <- split2(x, n_segments = n_segments, bycol = bycol) + Reduce(FUN, splitted_x) +} + From bc7facf1ddd21d7401fb0af61f54c77ec3c98e82 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 16:28:17 +1100 Subject: [PATCH 022/225] Add splines2 to Imports --- DESCRIPTION | 2 ++ R/stan_surv.R | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2e3238426..6c28a9525 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,6 +43,8 @@ Imports: rstan (>= 2.18.1), rstantools (>= 1.4.0), shinystan (>= 2.3.0), + splines, + splines2 (>= 0.2.7), stats, survival (>= 2.40.1), utils diff --git a/R/stan_surv.R b/R/stan_surv.R index 40924e608..f6eb4ebdf 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -29,7 +29,8 @@ #' #' @export #' @importFrom splines bs -#' +#' @import splines2 +#' #' @template args-prior_intercept #' @template args-priors #' @template args-prior_PD From e11f499b9bf5074bd7fde402bc34960914792ddd Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 16:28:57 +1100 Subject: [PATCH 023/225] Fix typo in plot.stansurv --- R/plots.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/plots.R b/R/plots.R index a3f32bb63..ccc7865eb 100644 --- a/R/plots.R +++ b/R/plots.R @@ -201,6 +201,8 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, validate_stansurv_object(x) + limits <- match.arg(limits) + if (plotfun %in% c("basehaz", "tde")) { stanpars <- extract_pars(x) From 249c092c3081fc50da0de8764e846e08704ced60 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 16:46:02 +1100 Subject: [PATCH 024/225] Add stansurv objects to stanreg methods --- R/stanreg-methods.R | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/R/stanreg-methods.R b/R/stanreg-methods.R index 3e0500da2..277e98082 100644 --- a/R/stanreg-methods.R +++ b/R/stanreg-methods.R @@ -118,7 +118,7 @@ fitted.stanreg <- function(object, ...) { #' @rdname stanreg-methods #' @export nobs.stanreg <- function(object, ...) { - nrow(model.frame(object)) + if (is.surv(object)) object$nobs else nrow(model.frame(object)) } #' @rdname stanreg-methods @@ -336,6 +336,9 @@ model.frame.stanreg <- function(formula, fixed.only = FALSE, ...) { } return(fr) } + if (is.stansurv(formula)) { + return(formula$model_frame) + } NextMethod("model.frame") } @@ -362,7 +365,10 @@ model.matrix.stanreg <- function(object, ...) { #' that both default to \code{FALSE}. #' formula.stanreg <- function(x, ..., m = NULL) { - if (is.mer(x) && !isTRUE(x$stan_function == "stan_gamm4")) return(formula_mer(x, ...)) + if (is.mer(x) && !isTRUE(x$stan_function == "stan_gamm4")) + return(formula_mer(x, ...)) + if (is.surv(x)) + return(x$formula$formula) x$formula } From 6bd151759a058ea2440002104dc08764ec345f11 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 16:58:37 +1100 Subject: [PATCH 025/225] print & summary: add more info about censoring type for stansurv objects --- R/print-and-summary.R | 18 +++++++++++++++--- R/stansurv.R | 3 +++ 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/R/print-and-summary.R b/R/print-and-summary.R index 3d64c7695..2fb250ea6 100644 --- a/R/print-and-summary.R +++ b/R/print-and-summary.R @@ -82,7 +82,12 @@ print.stanreg <- function(x, digits = 1, ...) { cat("\n formula: ", formula_string(formula(x))) cat("\n observations: ", x$nobs) cat("\n events: ", x$nevents, percent_string(x$nevents, x$nobs)) - cat("\n censored: ", x$ncensor, percent_string(x$ncensor, x$nobs)) + if (x$nlcens > 0) + cat("\n left censored: ", x$nlcens, percent_string(x$nlcens, x$nobs)) + if (x$nrcens > 0) + cat("\n right censored: ", x$nrcens, percent_string(x$nrcens, x$nobs)) + if (x$nicens > 0) + cat("\n interval cens.: ", x$nicens, percent_string(x$nicens, x$nobs)) cat("\n delayed entry: ", yes_no_string(x$ndelayed)) } else { cat("\n family: ", family_plus_link(x)) @@ -445,7 +450,9 @@ summary.stanreg <- function(object, pars = NULL, regex_pars = NULL, npreds = if (is_glm) length(coef(object)) else NULL, ngrps = if (mer) ngrps(object) else NULL, nevents = if (surv) object$nevents else NULL, - ncensor = if (surv) object$ncensor else NULL, + nlcens = if (surv) object$nlcens else NULL, + nrcens = if (surv) object$nrcens else NULL, + nicens = if (surv) object$nicens else NULL, ndelayed = if (surv) object$ndelayed else NULL, print.digits = digits, priors = object$prior.info, @@ -473,7 +480,12 @@ print.summary.stanreg <- function(x, digits = max(1, attr(x, "print.digits")), cat("\n sample: ", atts$posterior_sample_size, "(posterior sample size)") cat("\n observations: ", atts$nobs) cat("\n events: ", atts$nevents, percent_string(atts$nevents, atts$nobs)) - cat("\n censored: ", atts$ncensor, percent_string(atts$ncensor, atts$nobs)) + if (atts$nlcens > 0) + cat("\n left censored: ", atts$nlcens, percent_string(atts$nlcens, atts$nobs)) + if (atts$nrcens > 0) + cat("\n right censored: ", atts$nrcens, percent_string(atts$nrcens, atts$nobs)) + if (atts$nicens > 0) + cat("\n interval cens.: ", atts$nicens, percent_string(atts$nicens, atts$nobs)) cat("\n delayed entry: ", yes_no_string(atts$ndelayed)) } else { # anything except survival models cat("\n function: ", atts$stan_function) diff --git a/R/stansurv.R b/R/stansurv.R index 2c45e0da7..f5a5569df 100644 --- a/R/stansurv.R +++ b/R/stansurv.R @@ -75,6 +75,9 @@ stansurv <- function(object) { basehaz = object$basehaz, nobs = object$nobs, nevents = object$nevents, + nlcens = object$nlcens, + nrcens = object$nrcens, + nicens = object$nicens, ncensor = object$ncensor, ndelayed = object$ndelayed, qnodes = object$qnodes, From 38ce2e5f926b946b7cd3cfa1e749cdedd5f7765e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 18:36:31 +1100 Subject: [PATCH 026/225] Allow NA in unstandardise_qpts and unstandardise_qwts functions --- R/misc.R | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/R/misc.R b/R/misc.R index 68f87bf35..7f6ed6d3d 100644 --- a/R/misc.R +++ b/R/misc.R @@ -912,16 +912,18 @@ sweep_multiply <- function(x, y, margin = 2L) { # @param x An unstandardised quadrature node # @param a The lower limit(s) of the integral, possibly a vector # @param b The upper limit(s) of the integral, possibly a vector -unstandardise_qpts <- function(x, a, b) { +unstandardise_qpts <- function(x, a, b, na.ok = TRUE) { if (!identical(length(x), 1L) || !is.numeric(x)) - stop("'x' should be a single numeric value.", call. = FALSE) - if (!all(is.numeric(a), is.numeric(b))) - stop("'a' and 'b' should be numeric.", call. = FALSE) + stop2("'x' should be a single numeric value.") if (!length(a) %in% c(1L, length(b))) - stop("'a' and 'b' should be vectors of length 1, or, be the same length.", call. = FALSE) - if (any((b - a) < 0)) - stop("The upper limits for the integral ('b' values) should be greater than ", - "the corresponding lower limits for the integral ('a' values).", call. = FALSE) + stop2("'a' and 'b' should be vectors of length 1, or, be the same length.") + if (!na.ok) { + if (!all(is.numeric(a), is.numeric(b))) + stop2("'a' and 'b' should be numeric.") + if (any((b - a) < 0)) + stop2("The upper limits for the integral ('b' values) should be greater than ", + "the corresponding lower limits for the integral ('a' values).") + } ((b - a) / 2) * x + ((b + a) / 2) } @@ -931,16 +933,18 @@ unstandardise_qpts <- function(x, a, b) { # @param x An unstandardised quadrature weight # @param a The lower limit(s) of the integral, possibly a vector # @param b The upper limit(s) of the integral, possibly a vector -unstandardise_qwts <- function(x, a, b) { +unstandardise_qwts <- function(x, a, b, na.ok = TRUE) { if (!identical(length(x), 1L) || !is.numeric(x)) - stop("'x' should be a single numeric value.", call. = FALSE) - if (!all(is.numeric(a), is.numeric(b))) - stop("'a' and 'b' should be numeric.", call. = FALSE) + stop2("'x' should be a single numeric value.") if (!length(a) %in% c(1L, length(b))) - stop("'a' and 'b' should be vectors of length 1, or, be the same length.", call. = FALSE) - if (any((b - a) < 0)) - stop("The upper limits for the integral ('b' values) should be greater than ", - "the corresponding lower limits for the integral ('a' values).", call. = FALSE) + stop2("'a' and 'b' should be vectors of length 1, or, be the same length.") + if (!na.ok) { + if (!all(is.numeric(a), is.numeric(b))) + stop2("'a' and 'b' should be numeric.") + if (any((b - a) < 0)) + stop2("The upper limits for the integral ('b' values) should be greater than ", + "the corresponding lower limits for the integral ('a' values).") + } ((b - a) / 2) * x } From 91682ada626a1bcebda135ad027675b2375324d6 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 18:36:52 +1100 Subject: [PATCH 027/225] Add log_lik method for stansurv objects --- R/log_lik.R | 233 +++++++++++++++++++++++++++++++++++++++++++++++++--- R/pp_data.R | 27 ++++-- 2 files changed, 241 insertions(+), 19 deletions(-) diff --git a/R/log_lik.R b/R/log_lik.R index 801f918c7..0beb0125a 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -73,21 +73,36 @@ log_lik.stanreg <- function(object, newdata = NULL, offset = NULL, ...) { newdata <- validate_newdata(newdata) calling_fun <- as.character(sys.call(-1))[1] dots <- list(...) + if (is.stanmvreg(object)) { - m <- dots[["m"]] - if (is.null(m)) - STOP_arg_required_for_stanmvreg(m) - if (!is.null(offset)) - stop2("'offset' cannot be specified for stanmvreg objects.") + m <- dots[["m"]]; if (is.null(m)) STOP_arg_required_for_stanmvreg(m) } else { m <- NULL } + + if (is.stansurv(object)) { + args <- ll_args.stansurv(object, newdata = newdata, + reloo_or_kfold = reloo_or_kfold, ...) + } else { + args <- ll_args.stanreg(object, newdata = newdata, offset = offset, + reloo_or_kfold = reloo_or_kfold, ...) + } - args <- ll_args.stanreg(object, newdata = newdata, offset = offset, - reloo_or_kfold = calling_fun %in% c("kfold", "reloo"), - ...) fun <- ll_fun(object, m = m) - if (is_clogit(object)) { + if (is.stansurv(object)) { + out <- + vapply( + seq_len(args$N), + FUN.VALUE = numeric(length = args$S), + FUN = function(i) { + as.vector(fun( + draws = args$draws, + data_i = args$data[args$data$cids == + unique(args$data$cids)[i], , drop = FALSE] + )) + } + ) + } else if (is_clogit(object)) { out <- vapply( seq_len(args$N), @@ -172,7 +187,9 @@ log_lik.stanjm <- function(object, newdataLong = NULL, newdataEvent = NULL, ...) ll_fun <- function(x, m = NULL) { validate_stanreg_object(x) f <- family(x, m = m) - if (!is(f, "family") || is_scobit(x)) + if (is.stansurv(x)) { + return(.ll_surv_i) + } else if (!is(f, "family") || is_scobit(x)) return(.ll_polr_i) else if (is_clogit(x)) return(.ll_clogit_i) @@ -200,6 +217,8 @@ ll_fun <- function(x, m = NULL) { # @return a named list with elements data, draws, S (posterior sample size) and # N = number of observations ll_args <- function(object, ...) UseMethod("ll_args") + +#--- ll_args for stanreg models ll_args.stanreg <- function(object, newdata = NULL, offset = NULL, m = NULL, reloo_or_kfold = FALSE, ...) { validate_stanreg_object(object) @@ -366,6 +385,75 @@ ll_args.stanreg <- function(object, newdata = NULL, offset = NULL, m = NULL, return(out) } +#--- ll_args for stansurv models +ll_args.stansurv <- function(object, newdata = NULL, + reloo_or_kfold = FALSE, ...) { + + validate_stansurv_object(object) + + if (is.null(newdata)) { + newdata <- get_model_data(object) + } + newdata <- as.data.frame(newdata) + + # response, ie. a Surv object + form <- as.formula(formula(object)) + y <- eval(form[[2L]], newdata) + + # outcome, ie. time variables and status indicator + t_beg <- make_t(y, type = "beg") # entry time + t_end <- make_t(y, type = "end") # exit time + t_upp <- make_t(y, type = "upp") # upper time for interval censoring + status <- make_d(y) + if (any(status < 0 || status > 3)) + stop2("Invalid status indicator in Surv object.") + + # delayed entry indicator for each row of data + delayed <- as.logical(!t_beg == 0) + + # we reconstruct the design matrices even if no newdata, since it is + # too much of a pain to store everything in the fitted model object + # (e.g. w/ delayed entry, interval censoring, quadrature points, etc) + pp <- pp_data(object, newdata, times = t_end) + + # returned object depends on quadrature + if (object$has_quadrature) { + pp_qpts_beg <- pp_data(object, newdata, times = t_beg, at_quadpoints = TRUE) + pp_qpts_end <- pp_data(object, newdata, times = t_end, at_quadpoints = TRUE) + pp_qpts_upp <- pp_data(object, newdata, times = t_upp, at_quadpoints = TRUE) + cpts <- c(pp$pts, pp_qpts_beg$pts, pp_qpts_end$pts, pp_qpts_upp$pts) + cwts <- c(pp$wts, pp_qpts_beg$wts, pp_qpts_end$wts, pp_qpts_upp$wts) + cids <- c(pp$ids, pp_qpts_beg$ids, pp_qpts_end$ids, pp_qpts_upp$ids) + x <- rbind(pp$x, pp_qpts_beg$x, pp_qpts_end$x, pp_qpts_upp$x) + s <- rbind(pp$s, pp_qpts_beg$s, pp_qpts_end$s, pp_qpts_upp$s) + x <- append_prefix_to_colnames(x, "x__") + s <- append_prefix_to_colnames(s, "s__") + status <- c(status, rep(NA, length(cids) - length(status))) + delayed <- c(delayed, rep(NA, length(cids) - length(delayed))) + data <- data.frame(cpts, cwts, cids, status, delayed) + data <- cbind(data, x, s) + } else { + x <- append_prefix_to_colnames(pp$x, "x__") + cids <- seq_along(t_end) + data <- data.frame(cids, t_beg, t_end, t_upp, status, delayed) + data <- cbind(data, x) + } + + # parameter draws + draws <- list() + pars <- extract_pars(object) + draws$basehaz <- get_basehaz (object) + draws$aux <- pars$aux + draws$alpha <- pars$alpha + draws$beta <- pars$beta + draws$beta_tde <- pars$beta_tde + draws$has_quadrature <- pp$has_quadrature + draws$qnodes <- pp$qnodes + + out <- nlist(data, draws, S = NROW(draws$beta), N = n_distinct(cids)) + return(out) +} + # check intercept for polr models ----------------------------------------- # Check if a model fit with stan_polr has an intercept (i.e. if it's actually a @@ -417,6 +505,18 @@ ll_args.stanreg <- function(object, newdata = NULL, offset = NULL, m = NULL, draws$f_phi$linkinv(eta) } +# for stan_surv only +.xdata_surv <- function(data) { + nms <- colnames(data) + sel <- grep("^x__", nms) + data[, sel] +} +.sdata_surv <- function(data) { + nms <- colnames(data) + sel <- grep("^s__", nms) + data[, sel] +} + # log-likelihood functions ------------------------------------------------ .ll_gaussian_i <- function(data_i, draws) { val <- dnorm(data_i$y, mean = .mu(data_i, draws), sd = draws$sigma, log = TRUE) @@ -493,6 +593,119 @@ ll_args.stanreg <- function(object, newdata = NULL, offset = NULL, m = NULL, .weighted(val, data_i$weights) } +.ll_surv_i <- function(data_i, draws) { + + if (draws$has_quadrature) { + + qnodes <- draws$qnodes + status <- data_i[1L, "status"] + delayed <- data_i[1L, "delayed"] + + # row indexing of quadrature points in data_i + idx_epts <- 1 + idx_qpts_beg <- 1 + (qnodes * 0) + (1:qnodes) + idx_qpts_end <- 1 + (qnodes * 1) + (1:qnodes) + idx_qpts_upp <- 1 + (qnodes * 2) + (1:qnodes) + + args <- list(times = data_i$cpts, + basehaz = draws$basehaz, + aux = draws$aux, + intercept = draws$alpha) + + eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) + eta <- eta + linear_predictor(draws$beta_tde, .sdata_surv(data_i)) + lhaz <- eta + do.call(evaluate_log_basehaz, args) + + if (status == 1) { + # uncensored + lhaz_epts <- lhaz[, idx_epts, drop = FALSE] + lhaz_qpts_end <- lhaz[, idx_qpts_end, drop = FALSE] + lsurv <- -quadrature_sum(exp(lhaz_qpts_end), + qnodes = qnodes, + qwts = data_i$cwts[idx_qpts_end]) + ll <- lhaz_epts + lsurv + } else if (status == 0) { + # right censored + lhaz_qpts_end <- lhaz[, idx_qpts_end, drop = FALSE] + lsurv <- -quadrature_sum(exp(lhaz_qpts_end), + qnodes = qnodes, + qwts = data_i$cwts[idx_qpts_end]) + ll <- lsurv + } else if (status == 2) { + # left censored + lhaz_qpts_end <- lhaz[, idx_qpts_end, drop = FALSE] + lsurv <- -quadrature_sum(exp(lhaz_qpts_end), + qnodes = qnodes, + qwts = data_i$cwts[idx_qpts_end]) + ll <- log(1 - exp(lsurv)) # = log CDF + } else if (status == 3) { + # interval censored + lhaz_qpts_end <- lhaz[, idx_qpts_end, drop = FALSE] + lsurv_lower <- -quadrature_sum(exp(lhaz_qpts_end), + qnodes = qnodes, + qwts = data_i$cwts[idx_qpts_end]) + lhaz_qpts_upp <- lhaz[, idx_qpts_upp, drop = FALSE] + lsurv_upper <- -quadrature_sum(exp(lhaz_qpts_upp), + qnodes = qnodes, + qwts = data_i$cwts[idx_qpts_upp]) + ll <- log(exp(lsurv_lower) - exp(lsurv_upper)) + } + if (delayed) { + # delayed entry + lhaz_qpts_beg <- lhaz[, idx_qpts_beg, drop = FALSE] + lsurv_beg <- -quadrature_sum(exp(lhaz_qpts_beg), + qnodes = qnodes, + qwts = data_i$cwts[idx_qpts_beg]) + ll <- ll - lsurv_beg + } + + } else { # no quadrature + + status <- data_i$status + delayed <- data_i$delayed + + args <- list(basehaz = draws$basehaz, + aux = draws$aux, + intercept = draws$alpha) + + eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) + + if (status == 1) { + # uncensored + args$times <- data_i$t_end + lhaz <- do.call(evaluate_log_basehaz, args) + eta + lsurv <- do.call(evaluate_log_basesurv, args) * exp(eta) + ll <- lhaz + lsurv + } else if (status == 0) { + # right censored + args$times <- data_i$t_end + lsurv <- do.call(evaluate_log_basesurv, args) * exp(eta) + ll <- lsurv + } else if (status == 2) { + # left censored + args$times <- data_i$t_end + lsurv <- do.call(evaluate_log_basesurv, args) * exp(eta) + ll <- log(1 - exp(lsurv)) # = log CDF + } else if (status == 3) { + # interval censored + args$times <- data_i$t_end + lsurv_lower <- do.call(evaluate_log_basesurv, args) * exp(eta) + args$times <- data_i$t_upp + lsurv_upper <- do.call(evaluate_log_basesurv, args) * exp(eta) + ll <- log(exp(lsurv_lower) - exp(lsurv_upper)) + } + if (delayed) { + # delayed entry + args$times <- data_i$t_beg + lsurv_beg <- do.call(evaluate_log_basesurv, args) * exp(eta) + ll <- ll - lsurv_beg + } + + } + return(ll) +} + + # log-likelihood functions for stanjm objects only ---------------------- # Alternative ll_args method for stanjm objects that allows data and pars to be diff --git a/R/pp_data.R b/R/pp_data.R index 2ef7d52c4..277c36297 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -266,7 +266,7 @@ pp_data <- stop("Bug found: 'times' must be specified.") # error check time variables - if (length(times) == nrow(newdata)) + if (!length(times) == nrow(newdata)) stop("Bug found: length of 'times' should equal number rows in the data.") # number of nodes @@ -282,15 +282,14 @@ pp_data <- wts <- uapply(qw, unstandardise_qwts, 0, times) # id vector for quadrature points - ids <- factor(rep(1:length(times), times = qnodes)) + ids <- rep(seq_along(times), times = qnodes) } else { # predictions don't require quadrature pts <- times wts <- rep(NA, length(times)) - ids <- factor(1:length(times)) - qnodes <- NULL - + ids <- seq_along(times) + } # model frame for predictor matrices @@ -325,7 +324,7 @@ pp_data <- s, has_quadrature, at_quadpoints, - qnodes)) + qnodes = object$qnodes)) } @@ -472,12 +471,22 @@ pp_data <- # need to be recalculated at quadrature points etc, for example # in posterior_survfit. # -# @param object A stanmvreg object. +# @param object A stansurv, stanmvreg or stanjm object. # @param m Integer specifying which submodel to get the -# prediction data frame for. +# prediction data frame for (for stanmvreg or stanjm objects). # @return A data frame or list of data frames with all the # (unevaluated) variables required for predictions. -get_model_data <- function(object, m = NULL) { +get_model_data <- function(object, ...) UseMethod("get_model_data") + +get_model_data.stansurv <- function(object, ...) { + validate_stansurv_object(object) + terms <- terms(object) + row_nms <- row.names(model.frame(object)) + get_all_vars(terms, object$data)[row_nms, , drop = FALSE] +} + +get_model_data.stanmvreg <- function(object, m = NULL, ...) { + validate_stanmvreg_object(object) M <- get_M(object) terms <- terms(object, fixed.only = FALSE) From 0cde0f776c38be7ae1629250690becb4fb16d48a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 18:48:55 +1100 Subject: [PATCH 028/225] Add loo for stansurv models with quadrature --- R/loo.R | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/R/loo.R b/R/loo.R index a53020aea..f1e7aeadb 100644 --- a/R/loo.R +++ b/R/loo.R @@ -215,7 +215,7 @@ loo.stanreg <- )) } else if (is_clogit(x)) { ll <- log_lik.stanreg(x) - cons <- apply(ll,MARGIN = 2, FUN = function(y) sd(y) < 1e-15) + cons <- apply(ll, MARGIN = 2, FUN = function(y) sd(y) < 1e-15) if (any(cons)) { message( "The following strata were dropped from the ", @@ -232,6 +232,16 @@ loo.stanreg <- cores = cores, save_psis = save_psis )) + } else if (is.stansurv(x) && x$has_quadrature) { + ll <- log_lik.stanreg(x) + r_eff <- loo::relative_eff(exp(ll), chain_id = chain_id, cores = cores) + loo_x <- + suppressWarnings(loo.matrix( + ll, + r_eff = r_eff, + cores = cores, + save_psis = save_psis + )) } else { args <- ll_args(x) llfun <- ll_fun(x) From 96de0f62206fe7cfd1f795a979ac90283fbd2c76 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 19:00:10 +1100 Subject: [PATCH 029/225] Handle stansurv objects in is_discrete function --- R/loo.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/loo.R b/R/loo.R index f1e7aeadb..9fd49d607 100644 --- a/R/loo.R +++ b/R/loo.R @@ -833,6 +833,8 @@ hash_y <- function(x, ...) { is_discrete <- function(object) { if (inherits(object, "polr")) return(TRUE) + if (inherits(object, "stansurv")) + return(FALSE) if (inherits(object, "stanmvreg")) { fams <- fetch(family(object), "family") res <- sapply(fams, function(x) From 040e4e952e9ba70fec42afa1d73a958be6869f49 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 26 Oct 2018 19:01:31 +1100 Subject: [PATCH 030/225] Updated NAMESPACE --- NAMESPACE | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index a2d3780a9..5541205a0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,8 @@ S3method(fixef,stanmvreg) S3method(fixef,stanreg) S3method(formula,stanmvreg) S3method(formula,stanreg) +S3method(get_surv,stanjm) +S3method(get_surv,stansurv) S3method(get_x,default) S3method(get_x,gamm4) S3method(get_x,lmerMod) @@ -44,6 +46,7 @@ S3method(nobs,stanreg) S3method(pairs,stanreg) S3method(plot,predict.stanjm) S3method(plot,stanreg) +S3method(plot,stansurv) S3method(plot,survfit.stanjm) S3method(posterior_interval,stanreg) S3method(posterior_linpred,stanreg) @@ -92,6 +95,7 @@ export(decov) export(dirichlet) export(exponential) export(fixef) +export(get_surv) export(get_x) export(get_y) export(get_z) @@ -153,6 +157,7 @@ export(stan_mvmer) export(stan_nlmer) export(stan_polr) export(stan_polr.fit) +export(stan_surv) export(stanjm_list) export(stanmvreg_list) export(stanreg_list) @@ -166,6 +171,7 @@ import(bayesplot) import(methods) import(rstantools) import(shinystan) +import(splines2) import(stats) importFrom(Matrix,Matrix) importFrom(Matrix,t) @@ -223,6 +229,7 @@ importFrom(rstan,optimizing) importFrom(rstan,sampling) importFrom(rstan,stanc) importFrom(rstan,vb) +importFrom(splines,bs) importFrom(stats,cov2cor) importFrom(stats,getInitial) importFrom(survival,Surv) From 4810fdf3d55c2517a25f84f7bb742d6f458f7658 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 10:34:32 +1100 Subject: [PATCH 031/225] stan_surv.R: make sure data argument is a data frame --- R/stan_surv.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/stan_surv.R b/R/stan_surv.R index f6eb4ebdf..d379f09ec 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -254,6 +254,8 @@ stan_surv <- function(formula, if (missing(basehaz_ops)) basehaz_ops <- NULL + if (missing(data) || !inherits(data, "data.frame")) + stop("'data' must be a data frame.") dots <- list(...) algorithm <- match.arg(algorithm) From 45a9363faca8cb6bb947e65c57338496117301dd Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 10:35:09 +1100 Subject: [PATCH 032/225] Add reloo and kfold for stansurv objects --- R/log_lik.R | 9 ++++----- R/loo.R | 4 ++-- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/R/log_lik.R b/R/log_lik.R index 0beb0125a..16f83f83f 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -81,11 +81,11 @@ log_lik.stanreg <- function(object, newdata = NULL, offset = NULL, ...) { } if (is.stansurv(object)) { - args <- ll_args.stansurv(object, newdata = newdata, - reloo_or_kfold = reloo_or_kfold, ...) + args <- ll_args.stansurv(object, newdata = newdata, ...) } else { args <- ll_args.stanreg(object, newdata = newdata, offset = offset, - reloo_or_kfold = reloo_or_kfold, ...) + reloo_or_kfold = calling_fun %in% c("kfold", "reloo"), + ...) } fun <- ll_fun(object, m = m) @@ -386,8 +386,7 @@ ll_args.stanreg <- function(object, newdata = NULL, offset = NULL, m = NULL, } #--- ll_args for stansurv models -ll_args.stansurv <- function(object, newdata = NULL, - reloo_or_kfold = FALSE, ...) { +ll_args.stansurv <- function(object, newdata = NULL, ...) { validate_stansurv_object(object) diff --git a/R/loo.R b/R/loo.R index 9fd49d607..a11d56129 100644 --- a/R/loo.R +++ b/R/loo.R @@ -427,7 +427,7 @@ kfold <- function(x, K = 10, save_fits = FALSE, folds = NULL) { if (!is.null(getCall(x)$offset)) { fit_k_call$offset <- x$offset[-omitted] } - fit_k_call$subset <- eval(fit_k_call$subset) + fit_k_call$subset <- if (!is.stansurv(x)) eval(fit_k_call$subset) else NULL fit_k_call$data <- eval(fit_k_call$data) capture.output( fit_k <- eval(fit_k_call) @@ -711,7 +711,7 @@ reloo <- function(x, loo_x, obs, ..., refit = TRUE) { refresh = 0, open_progress = FALSE ) - fit_j_call$subset <- eval(fit_j_call$subset) + fit_j_call$subset <- if (!is.stansurv(x)) eval(fit_j_call$subset) else NULL fit_j_call$data <- eval(fit_j_call$data) if (!is.null(getCall(x)$offset)) { fit_j_call$offset <- x$offset[-omitted] From 27f5ee481d790abe2b46bc8da5a41da0cd3d0790 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 14:07:36 +1100 Subject: [PATCH 033/225] Rename some of the testthat helper functions --- .../helpers/{expect_survfit.R => expect_survfit_jm.R} | 0 tests/testthat/helpers/expect_survfit_surv.R | 1 + tests/testthat/test_stan_jm.R | 2 +- tests/testthat/test_stan_surv.R | 6 +++--- 4 files changed, 5 insertions(+), 4 deletions(-) rename tests/testthat/helpers/{expect_survfit.R => expect_survfit_jm.R} (100%) create mode 100644 tests/testthat/helpers/expect_survfit_surv.R diff --git a/tests/testthat/helpers/expect_survfit.R b/tests/testthat/helpers/expect_survfit_jm.R similarity index 100% rename from tests/testthat/helpers/expect_survfit.R rename to tests/testthat/helpers/expect_survfit_jm.R diff --git a/tests/testthat/helpers/expect_survfit_surv.R b/tests/testthat/helpers/expect_survfit_surv.R new file mode 100644 index 000000000..258c10c2c --- /dev/null +++ b/tests/testthat/helpers/expect_survfit_surv.R @@ -0,0 +1 @@ +expect_survfit <- function(x) expect_s3_class(x, "survfit.stansurv") diff --git a/tests/testthat/test_stan_jm.R b/tests/testthat/test_stan_jm.R index 9801d57c3..5e9f20a78 100644 --- a/tests/testthat/test_stan_jm.R +++ b/tests/testthat/test_stan_jm.R @@ -41,7 +41,7 @@ TOLSCALES <- list( source(test_path("helpers", "expect_matrix.R")) source(test_path("helpers", "expect_stanreg.R")) source(test_path("helpers", "expect_stanmvreg.R")) -source(test_path("helpers", "expect_survfit.R")) +source(test_path("helpers", "expect_survfit_jm.R")) source(test_path("helpers", "expect_ppd.R")) source(test_path("helpers", "expect_equivalent_loo.R")) source(test_path("helpers", "SW.R")) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index a92dcbb95..32b9df10b 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -19,6 +19,7 @@ # tests can be run using devtools::test() or manually by loading testthat # package and then running the code below possibly with options(mc.cores = 4). +#library(testthat) library(rstanarm) library(survival) library(rstpm2) @@ -39,11 +40,10 @@ TOLSCALES <- list( source(test_path("helpers", "expect_matrix.R")) source(test_path("helpers", "expect_stanreg.R")) source(test_path("helpers", "expect_stanmvreg.R")) -source(test_path("helpers", "expect_survfit.R")) +source(test_path("helpers", "expect_survfit_surv.R")) source(test_path("helpers", "expect_ppd.R")) source(test_path("helpers", "expect_equivalent_loo.R")) source(test_path("helpers", "SW.R")) -# SW <- function(expr) eval(expr) source(test_path("helpers", "get_tols_surv.R")) source(test_path("helpers", "recover_pars_surv.R")) @@ -213,7 +213,7 @@ test_that("basehaz argument works", { nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models - for (j in c(1:30)) { + for (j in c(1:5)) { mod <- try(get(paste0("f", j)), silent = TRUE) From d98fc91cffa2913074aa340a98cb11b7fe547b42 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 14:07:53 +1100 Subject: [PATCH 034/225] Update NAMESPACE --- NAMESPACE | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 5541205a0..f3605003b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,10 +48,13 @@ S3method(plot,predict.stanjm) S3method(plot,stanreg) S3method(plot,stansurv) S3method(plot,survfit.stanjm) +S3method(plot,survfit.stansurv) S3method(posterior_interval,stanreg) S3method(posterior_linpred,stanreg) S3method(posterior_predict,stanmvreg) S3method(posterior_predict,stanreg) +S3method(posterior_survfit,stanjm) +S3method(posterior_survfit,stansurv) S3method(posterior_vs_prior,stanreg) S3method(pp_check,stanreg) S3method(predict,stanreg) @@ -67,6 +70,7 @@ S3method(print,stanreg) S3method(print,summary.stanmvreg) S3method(print,summary.stanreg) S3method(print,survfit.stanjm) +S3method(print,survfit.stansurv) S3method(prior_summary,stanreg) S3method(ranef,stanmvreg) S3method(ranef,stanreg) From 2a2db48aac26964a0d5bb2c1f1b2dce2e51d21f4 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 14:08:21 +1100 Subject: [PATCH 035/225] Rename get_extrapolation_control function --- R/posterior_traj.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/R/posterior_traj.R b/R/posterior_traj.R index 983fbd217..71f59c21c 100644 --- a/R/posterior_traj.R +++ b/R/posterior_traj.R @@ -375,8 +375,8 @@ posterior_traj <- function(object, m = 1, newdata = NULL, newdataLong = NULL, if (interpolate || extrapolate) { # user specified interpolation or extrapolation if (return_matrix) stop("'return_matrix' cannot be TRUE if 'interpolate' or 'extrapolate' is TRUE.") - ok_control_args <- c("ipoints", "epoints", "edist", "eprop") - control <- get_extrapolation_control(control, ok_control_args = ok_control_args) + ok_args <- c("ipoints", "epoints", "edist", "eprop") + control <- extrapolation_control(control, ok_args = ok_args) dist <- if (!is.null(control$eprop)) control$eprop * (last_time - 0) else control$edist iseq <- if (interpolate) get_time_seq(control$ipoints, 0, last_time) else NULL eseq <- if (extrapolate) get_time_seq(control$epoints, last_time, last_time + dist) else NULL @@ -691,27 +691,27 @@ plot.predict.stanjm <- function(x, ids = NULL, limits = c("ci", "pi", "none"), # # @param control A named list, being the user input to the control argument # in the posterior_predict.stanmvreg or posterior_survfit.stanjm call -# @param ok_control_args A character vector of allowed control arguments +# @param ok_args A character vector of allowed control arguments # @return A named list -get_extrapolation_control <- - function(control = list(), ok_control_args = c("epoints", "edist", "eprop")) { +extrapolation_control <- + function(control = list(), ok_args = c("epoints", "edist", "eprop")) { defaults <- list(ipoints = 15, epoints = 15, edist = NULL, eprop = 0.2, last_time = NULL) if (!is.list(control)) { stop("'control' should be a named list.") } else if (!length(control)) { - control <- defaults[ok_control_args] + control <- defaults[ok_args] } else { # user specified control list nms <- names(control) if (!length(nms)) stop("'control' should be a named list.") - if (any(!nms %in% ok_control_args)) + if (any(!nms %in% ok_args)) stop(paste0("'control' list can only contain the following named arguments: ", - paste(ok_control_args, collapse = ", "))) + paste(ok_args, collapse = ", "))) if (all(c("edist", "eprop") %in% nms)) stop("'control' list cannot include both 'edist' and 'eprop'.") - if (("ipoints" %in% ok_control_args) && is.null(control$ipoints)) + if (("ipoints" %in% ok_args) && is.null(control$ipoints)) control$ipoints <- defaults$ipoints - if (("epoints" %in% ok_control_args) && is.null(control$epoints)) + if (("epoints" %in% ok_args) && is.null(control$epoints)) control$epoints <- defaults$epoints if (is.null(control$edist) && is.null(control$eprop)) control$eprop <- defaults$eprop From 3c48f4e08eab40ad2a23107fbff636363d701b2c Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 14:09:35 +1100 Subject: [PATCH 036/225] Add WAIC for stansurv objects --- R/loo.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/loo.R b/R/loo.R index a11d56129..f6720e1c7 100644 --- a/R/loo.R +++ b/R/loo.R @@ -328,6 +328,8 @@ waic.stanreg <- function(x, ...) { out <- waic.matrix(ll) } else if (is_clogit(x)) { out <- waic.matrix(log_lik(x)) + } else if (is.stansurv(x) && x$has_quadrature) { + out <- waic.matrix(log_lik(x)) } else { args <- ll_args(x) out <- waic.function(ll_fun(x), data = args$data, draws = args$draws) From c038e9ab85ea5ca036f1e2c21a26de615db245b0 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 15:20:30 +1100 Subject: [PATCH 037/225] Add tests for stansurv models with time-dependent effects --- tests/testthat/test_stan_surv.R | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 32b9df10b..59ef954ab 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -207,13 +207,19 @@ test_that("basehaz argument works", { o<-SW(f3 <- update(f1, basehaz = "exp")) o<-SW(f4 <- update(f1, basehaz = "weibull")) o<-SW(f5 <- update(f1, basehaz = "gompertz")) + + o<-SW(f6 <- update(f1, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f7 <- update(f2, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f8 <- update(f3, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f9 <- update(f4, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f10 <- update(f5, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models - for (j in c(1:5)) { + for (j in c(1:10)) { mod <- try(get(paste0("f", j)), silent = TRUE) From 16aa3326fd1d031c66906f58f53ce475c180810f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 15:22:48 +1100 Subject: [PATCH 038/225] Stop ps_check for stansurv models with delayed entry The issue here is that I cannot calculate standardised survival predictions with delayed entry, since everyone is assumed to be in the risk set at each prediction time. This could be relaxed, but would take a bit more work. --- R/ps_check.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/ps_check.R b/R/ps_check.R index adf5d5158..1922e3090 100644 --- a/R/ps_check.R +++ b/R/ps_check.R @@ -88,6 +88,9 @@ ps_check <- function(object, if (!any(is.stansurv(object), is.stanjm(object))) stop("Object is not a 'stansurv' or 'stanjm' object.") + if (is.stansurv(object) && object$has_delayed) + stop("'ps_check' cannot currently be used on models with delayed entry.") + limits <- match.arg(limits) # Obtain standardised survival probabilities for the fitted model From 789f7df38afd975b99bb01d1d75edf8515bef5f8 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 15:24:49 +1100 Subject: [PATCH 039/225] Generate a workaround for stansurv pp_data when all times are NA An example of all times being NA is when evaluating pp_data for t_upp (the upper limit of interval censoring) when no individuals are interval censored. This workaround returns an S (i.e. time-varying predictor) matrix of the correct dimension but with all entries NA. --- R/pp_data.R | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index 277c36297..46b45ca00 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -292,30 +292,44 @@ pp_data <- } - # model frame for predictor matrices + # time-fixed predictor matrix mf <- make_model_frame(formula = formula$tf_form, data = newdata, - check_constant = FALSE)$mf - - # time-fixed predictor matrix - x <- make_x(formula = object$formula$tf_form, + check_constant = FALSE)$mf + x <- make_x(formula = formula$tf_form, model_frame = mf, xlevs = object$xlevs, check_constant = FALSE)$x if (has_quadrature && at_quadpoints) { x <- rep_rows(x, times = qnodes) } - + # time-varying predictor matrix - if (has_tde) { + if (has_tde) { # model has tde + if (at_quadpoints) { + # expand covariate data + newdata <- rep_rows(newdata, times = qnodes) + } + if (all(is.na(pts))) { + # temporary replacement to avoid error in creating spline basis + pts_tmp <- rep(0, length(pts)) + } else { + # else use prediction times or quadrature points + pts_tmp <- pts + } s <- make_s(formula = object$formula$td_form, data = newdata, - times = pts, # prediction times or quadrature points + times = pts_tmp, xlevs = object$xlevs) + if (all(is.na(pts))) { + # if pts were all NA then replace the time-varying predictor + # matrix with all NA, but retain appropriate dimensions + s[] <- NaN + } } else { # model does not have tde s <- matrix(0, length(pts), 0) } - + # return object return(nlist(pts, wts, From 5593f183564347fd8342b316c04b0c5193f19f4b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 15:25:21 +1100 Subject: [PATCH 040/225] Add posterior_survfit for stansurv models --- R/posterior_survfit.R | 880 +++++++++++++++++++++++++++++++++--------- 1 file changed, 696 insertions(+), 184 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 8e9a3ac84..98d517034 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -16,39 +16,20 @@ # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -#' Estimate subject-specific or standardised survival probabilities +#' Posterior predictions for survival models #' -#' This function allows us to generate estimated survival probabilities -#' based on draws from the posterior predictive distribution. By default -#' the survival probabilities are conditional on an individual's -#' group-specific coefficients (i.e. their individual-level random -#' effects). If prediction data is provided via the \code{newdataLong} -#' and \code{newdataEvent} arguments, then the default behaviour is to -#' sample new group-specific coefficients for the individuals in the -#' new data using a Monte Carlo scheme that conditions on their -#' longitudinal outcome data provided in \code{newdataLong} -#' (sometimes referred to as "dynamic predictions", see Rizopoulos -#' (2011)). This default behaviour can be stopped by specifying -#' \code{dynamic = FALSE}, in which case the predicted survival -#' probabilities will be marginalised over the distribution of the -#' group-specific coefficients. This has the benefit that the user does -#' not need to provide longitudinal outcome measurements for the new -#' individuals, however, it does mean that the predictions will incorporate -#' all the uncertainty associated with between-individual variation, since -#' the predictions aren't conditional on any observed data for the individual. -#' In addition, by default, the predicted subject-specific survival -#' probabilities are conditional on observed values of the fixed effect -#' covariates (ie, the predictions will be obtained using either the design -#' matrices used in the original \code{\link{stan_jm}} model call, or using the -#' covariate values provided in the \code{newdataLong} and \code{newdataEvent} -#' arguments). However, if you wish to average over the observed distribution -#' of the fixed effect covariates then this is possible -- such predictions -#' are sometimes referred to as standardised survival probabilties -- see the -#' \code{standardise} argument below. +#' This function allows us to generate predicted quantities for survival +#' models at specified times. These quantities include the +#' hazard rate, the cumulative hazard, or the survival probability. +#' Predictions are obtained using unique draws from the posterior distribution +#' of each of the model parameters and then summarised into a median and +#' posterior uncertainty interval. #' #' @export -#' @templateVar stanjmArg object -#' @template args-stanjm-object +#' @import splines2 +#' +#' @templateVar stanregArg object +#' @template args-stansurv-stanjm-object #' #' @param newdataLong,newdataEvent Optionally, a data frame (or in the case of #' \code{newdataLong} this can be a list of data frames) in which to look @@ -65,6 +46,13 @@ #' is of course assumed that all individuals in \code{newdataEvent} have not #' yet experienced the event (that is, any variable in \code{newdataEvent} that #' corresponds to the event indicator will be ignored). +#' @param type The type of prediction to return. The following are currently +#' allowed: +#' \itemize{ +#' \item \code{"surv"}: the estimated survival probability. +#' \item \code{"cumhaz"}: the estimated cumulative hazard. +#' \item \code{"haz"}: the estimated hazard rate. +#' } #' @param extrapolate A logical specifying whether to extrapolate the estimated #' survival probabilities beyond the times specified in the \code{times} argument. #' If \code{TRUE} then the extrapolation can be further controlled using @@ -72,11 +60,11 @@ #' @param control A named list with parameters controlling extrapolation #' of the estimated survival function when \code{extrapolate = TRUE}. The list #' can contain one or more of the following named elements: \cr -#' \describe{ -#' \item{\code{epoints}}{a positive integer specifying the number of +#' \itemize{ +#' \item \code{epoints}: a positive integer specifying the number of #' discrete time points at which to calculate the forecasted survival -#' probabilities. The default is 10.} -#' \item{\code{edist}}{a positive scalar specifying the amount of time +#' probabilities. The default is 10. +#' \item \code{edist}: a positive scalar specifying the amount of time #' across which to forecast the estimated survival function, represented #' in units of the time variable \code{time_var} (from fitting the model). #' The default is to extrapolate between the times specified in the @@ -84,8 +72,8 @@ #' original data. If \code{edist} leads to times that are beyond #' the maximum event or censoring time in the original data then the #' estimated survival probabilities will be truncated at that point, since -#' the estimate for the baseline hazard is not available beyond that time.} -#' } +#' the estimate for the baseline hazard is not available beyond that time. +#' } #' @param condition A logical specifying whether the estimated #' subject-specific survival probabilities at time \code{t} should be #' conditioned on survival up to a fixed time point \code{u}. The default @@ -170,33 +158,75 @@ #' size of the posterior sample if that is less than 200. #' @param seed An optional \code{\link[=set.seed]{seed}} to use. #' @param ... Currently unused. -#' +#' +#' @details +#' By default, the predicted quantities are evaluated conditional on observed +#' values of the fixed effect covariates. That is, predictions will be +#' obtained using either: +#' \itemize{ +#' \item the design matrices used in the original \code{\link{stan_surv}} +#' or \code{\link{stan_jm}} model call, or +#' \item the covariate values provided in the \code{newdata} argument +#' (or \code{newdataLong} and \code{newdataEvent} arugments for the +#' \code{stanjm} method). +#' } +#' However, if you wish to average over the observed distribution +#' of the fixed effect covariates then this is possible -- such predictions +#' are sometimes referred to as standardised survival probabilties -- see the +#' \code{standardise} argument. +#' +#' For \code{stansurv} objects, the predicted quantities are calculated for +#' each row of the prediction data, at the specified \code{times} as well as +#' any times generated through extrapolation (when \code{extrapolate = TRUE}). +#' For \code{stanjm} objects, these quantities are calculated for each +#' individual, at the specified \code{times} as well as any times generated +#' through extrapolation (when \code{extrapolate = TRUE}). +#' +#' The following also applies for \code{stanjm} objects. +#' By default the survival probabilities are conditional on an individual's +#' group-specific coefficients (i.e. their individual-level random +#' effects). If prediction data is provided via the \code{newdataLong} +#' and \code{newdataEvent} arguments, then the default behaviour is to +#' sample new group-specific coefficients for the individuals in the +#' new data using a Monte Carlo scheme that conditions on their +#' longitudinal outcome data provided in \code{newdataLong} +#' (sometimes referred to as "dynamic predictions", see Rizopoulos +#' (2011)). This default behaviour can be stopped by specifying +#' \code{dynamic = FALSE}, in which case the predicted survival +#' probabilities will be marginalised over the distribution of the +#' group-specific coefficients. This has the benefit that the user does +#' not need to provide longitudinal outcome measurements for the new +#' individuals, however, it does mean that the predictions will incorporate +#' all the uncertainty associated with between-individual variation, since +#' the predictions aren't conditional on any observed data for the individual. +#' #' @note #' Note that if any variables were transformed (e.g. rescaled) in the data #' used to fit the model, then these variables must also be transformed in #' \code{newdataLong} and \code{newdataEvent}. This only applies if variables -#' were transformed before passing the data to one of the modeling functions and -#' \emph{not} if transformations were specified inside the model formula. +#' were transformed before passing the data to one of the modeling functions +#' and \emph{not} if transformations were specified inside the model formula. #' #' @return A data frame of class \code{survfit.stanjm}. The data frame includes #' columns for each of the following: -#' (i) the median of the posterior predictions of the estimated survival -#' probabilities (\code{survpred}); +#' (i) the median of the posterior predictions (\code{median}); #' (ii) each of the lower and upper limits of the corresponding uncertainty -#' interval for the estimated survival probabilities (\code{ci_lb} and -#' \code{ci_ub}); -#' (iii) a subject identifier (\code{id_var}), unless standardised survival -#' probabilities were estimated; -#' (iv) the time that the estimated survival probability is calculated for -#' (\code{time_var}). +#' interval for the posterior predictions (\code{ci_lb} and \code{ci_ub}); +#' (iii) an observation identifier (for \code{stan_surv} models) or an +#' individual identifier (for \code{stan_jm} models), unless standardised +#' predictions were requested; +#' (iv) the time that the prediction corresponds to. #' The returned object also includes a number of additional attributes. #' -#' @seealso \code{\link{plot.survfit.stanjm}} for plotting the estimated survival -#' probabilities, \code{\link{ps_check}} for for graphical checks of the estimated -#' survival function, and \code{\link{posterior_traj}} for estimating the -#' marginal or subject-specific longitudinal trajectories, and -#' \code{\link{plot_stack_jm}} for combining plots of the estimated subject-specific -#' longitudinal trajectory and survival function. +#' @seealso +#' \code{\link{plot.survfit.stanjm}} for plotting the estimated survival +#' probabilities \cr +#' \code{\link{ps_check}} for for graphical checks of the estimated +#' survival function \cr +#' \code{\link{posterior_traj}} for estimating the +#' marginal or subject-specific longitudinal trajectories \cr +#' \code{\link{plot_stack_jm}} for combining plots of the estimated +#' subject-specific longitudinal trajectory and survival function #' #' @references #' Rizopoulos, D. (2011). Dynamic predictions and prospective accuracy in @@ -261,25 +291,225 @@ #' plot(ps4) #' } #' -posterior_survfit <- function(object, newdataLong = NULL, newdataEvent = NULL, - extrapolate = TRUE, control = list(), - condition = NULL, last_time = NULL, prob = 0.95, - ids, times = NULL, standardise = FALSE, - dynamic = TRUE, scale = 1.5, - draws = NULL, seed = NULL, ...) { +posterior_survfit <- function(object, ...) UseMethod("posterior_survfit") + +#' @rdname posterior_survfit +#' @method posterior_survfit stansurv +#' @export +#' +posterior_survfit.stansurv <- function(object, + newdata = NULL, + type = "surv", + extrapolate = TRUE, + control = list(), + condition = NULL, + last_time = NULL, + prob = 0.95, + times = NULL, + standardise = FALSE, + draws = NULL, + seed = NULL, + ...) { + + validate_stansurv_object(object) + + basehaz <- object$basehaz + + if (!is.null(seed)) + set.seed(seed) + + if (is.null(newdata) && object$ndelayed) + stop("Prediction data for 'posterior_survfit' cannot include delayed ", + "entry. If you estimated a model with delayed entry, you will ", + "not be able to obtain predictions using the estimation data frame. ", + "You must provide prediction data via the 'newdata' argument, and ", + "indicate delayed entry via the 'last_time' argument.") + + dots <- list(...) + + newdata <- validate_newdata(newdata) + has_newdata <- not.null(newdata) + + # Obtain a vector of unique subject ids + if (is.null(newdata)) { + id_list <- seq(nrow(object$model_data)) + } else { + id_list <- seq(nrow(newdata)) + } + + # Last known survival time for each individual + if (is.null(newdata)) { # user did not specify newdata + if (!is.null(last_time)) + stop("'last_time' cannot be provided when newdata is NULL, since times ", + "are taken to be the event or censoring time for each individual.") + last_time <- object$eventtime + } else { # user specified newdata + if (is.null(last_time)) { # assume at risk from time zero + last_time <- rep(0, length(id_list)) + } else if (is.string(last_time)) { + if (!last_time %in% colnames(newdata)) + stop("Cannot find 'last_time' column named in newdata") + last_time <- newdata[[last_time]] + } else if (is.scalar(last_time)) { + last_time <- rep(last_time, nrow(newdata)) + } else if (any(!is.numeric(last_time), !length(last_time) == nrow(newdata))) { + stop("Bug found: could not reconcile 'last_time' argument.") + } + names(last_time) <- as.character(id_list) + } + + # Prediction times + if (standardise) { # standardised survival probs + times <- + if (is.null(times)) { + stop("'times' cannot be NULL for obtaining standardised survival probabilities.") + } else if (is.scalar(times)) { + rep(times, length(id_list)) + } else { + stop("'times' should be a numeric vector of length 1 in order to obtain ", + "standardised survival probabilities (the subject-specific survival ", + "probabilities will be calculated at the specified time point, and ", + "then averaged).") + } + } else if (is.null(newdata)) { # subject-specific survival probs without newdata + times <- + if (is.null(times)) { + object$eventtime + } else if (is.scalar(times)) { + rep(times, length(id_list)) + } else { + stop("If newdata is NULL then 'times' must be NULL or a single number.") + } + } else { # subject-specific survival probs with newdata + times <- + if (is.null(times)) { + times <- last_time + } else if (is.scalar(times)) { + rep(times, length(id_list)) + } else if (is.string(times)) { + if (!times %in% colnames(newdata)) + stop("Variable specified in 'times' argument could not be found in newdata.") + times <- newdata[[times]] + } else { + stop("If newdata is specified then 'times' can only be the name of a ", + "variable in newdata, or a single number.") + } + } + + maxtime <- max(object$eventtime) + if (any(times > maxtime)) + stop("'times' are not allowed to be greater than the last event or ", + "censoring time (since unable to extrapolate the baseline hazard).") + + # User specified extrapolation + if (extrapolate) { + control <- extrapolation_control(control, ok_args = c("epoints", "edist")) + if (not.null(control$edist)) { + endtime <- times + control$edist + } else { + endtime <- maxtime + } + endtime <- truncate(endtime, upper = maxtime) + time_seq <- get_time_seq(control$epoints, times, endtime, simplify = FALSE) + } else { + time_seq <- list(times) # no extrapolation + } + + # Conditional survival times + if (is.null(condition)) { + condition <- ifelse(type == "surv", !standardise, FALSE) + } else if (condition && standardise) { + stop("'condition' cannot be TRUE for standardised survival probabilities.") + } + + # Get stanmat parameter matrix for specified number of draws + stanmat <- sample_stanmat(object, draws = draws, default_draws = NA) + pars <- extract_pars(object, stanmat) + + # Calculate survival probability at each increment of extrapolation sequence + surv <- lapply(time_seq, .pp_calculate_surv, + object = object, + newdata = newdata, + pars = pars, + type = type, + standardise = standardise) + + # Calculate survival probability at last known survival time and then + # use that to calculate conditional survival probabilities + if (condition) { + if (!type == "surv") + stop("'condition' can only be set to TRUE for survival probabilities.") + cond_surv <- .pp_calculate_surv(last_time, + object = object, + newdata = newdata, + pars = pars, + type = type) + surv <- lapply(surv, function(x) truncate(x / cond_surv, upper = 1)) + } + + # Summarise posterior draws to get median and CI + out <- .pp_summarise_surv(surv = surv, + prob = prob, + standardise = standardise) + + # Add attributes + structure(out, + id_var = attr(out, "id_var"), + time_var = attr(out, "time_var"), + type = type, + extrapolate = extrapolate, + control = control, + condition = condition, + standardise = standardise, + last_time = last_time, + ids = id_list, + draws = draws, + seed = seed, + class = c("survfit.stansurv", "data.frame")) +} + +#' @rdname posterior_survfit +#' @method posterior_survfit stanjm +#' @export +#' +posterior_survfit.stanjm <- function(object, + newdataLong = NULL, + newdataEvent = NULL, + type = "surv", + extrapolate = TRUE, + control = list(), + condition = NULL, + last_time = NULL, + prob = 0.95, + ids, + times = NULL, + standardise = FALSE, + dynamic = TRUE, + scale = 1.5, + draws = NULL, + seed = NULL, + ...) { + validate_stanjm_object(object) + M <- object$n_markers id_var <- object$id_var time_var <- object$time_var basehaz <- object$basehaz assoc <- object$assoc family <- family(object) + if (!is.null(seed)) set.seed(seed) if (missing(ids)) ids <- NULL + dots <- list(...) + # Temporarily only allow survprob for stan_jm until refactoring is done + if (!type == "surv") + stop("Currently only 'type = \"surv\"' is allowed for stanjm models.") + # Temporary stop, until make_assoc_terms can handle it sel_stop <- grep("^shared", rownames(object$assoc)) if (any(unlist(object$assoc[sel_stop,]))) @@ -291,6 +521,7 @@ posterior_survfit <- function(object, newdataLong = NULL, newdataEvent = NULL, # ndE: dataEvent to be used in predictions if (!identical(is.null(newdataLong), is.null(newdataEvent))) stop("Both newdataLong and newdataEvent must be supplied together.") + has_newdata <- not.null(newdataEvent) if (is.null(newdataLong)) { # user did not specify newdata dats <- get_model_data(object) ndL <- dats[1:M] @@ -383,8 +614,8 @@ posterior_survfit <- function(object, newdataLong = NULL, newdataEvent = NULL, # User specified extrapolation if (extrapolate) { - ok_control_args <- c("epoints", "edist") - control <- get_extrapolation_control(control, ok_control_args = ok_control_args) + ok_args <- c("epoints", "edist") + control <- extrapolation_control(control, ok_args = ok_args) endtime <- if (!is.null(control$edist)) times + control$edist else maxtime endtime[endtime > maxtime] <- maxtime # nothing beyond end of baseline hazard time_seq <- get_time_seq(control$epoints, times, endtime, simplify = FALSE) @@ -392,30 +623,25 @@ posterior_survfit <- function(object, newdataLong = NULL, newdataEvent = NULL, # Conditional survival times if (is.null(condition)) { - condition <- !standardise + condition <- ifelse(type == "surv", !standardise, FALSE) } else if (condition && standardise) { stop("'condition' cannot be set to TRUE if standardised survival ", "probabilities are requested.") } # Get stanmat parameter matrix for specified number of draws - S <- posterior_sample_size(object) - if (is.null(draws)) - draws <- if (S > 200L) 200L else S - if (draws > S) - stop("'draws' should be <= posterior sample size (", S, ").") - stanmat <- as.matrix(object$stanfit) - some_draws <- isTRUE(draws < S) - if (some_draws) { - samp <- sample(S, draws) - stanmat <- stanmat[samp, , drop = FALSE] - } + stanmat <- sample_stanmat(object, draws = draws, default_draws = 200) # Draw b pars for new individuals - if (dynamic && !is.null(newdataEvent)) { - stanmat <- simulate_b_pars(object, stanmat = stanmat, ndL = ndL, ndE = ndE, - ids = id_list, times = last_time, scale = scale) - b_new <- attr(stanmat, "b_new") + if (dynamic && has_newdata) { + stanmat <- simulate_b_pars(object, + stanmat = stanmat, + ndL = ndL, + ndE = ndE, + ids = id_list, + times = last_time, + scale = scale) + b_new <- attr(stanmat, "b_new") acceptance_rate <- attr(stanmat, "acceptance_rate") } @@ -423,102 +649,371 @@ posterior_survfit <- function(object, newdataLong = NULL, newdataEvent = NULL, # Matrix of surv probs at each increment of the extrapolation sequence # NB If no extrapolation then length(time_seq) == 1L - surv_t <- lapply(time_seq, function(t) { - if (!identical(length(t), length(id_list))) - stop("Bug found: the vector of prediction times is not the same length ", - "as the number of individuals.") - dat <- .pp_data_jm(object, newdataLong = ndL, newdataEvent = ndE, - ids = id_list, etimes = t, long_parts = FALSE) - surv_t <- .ll_survival(object, data = dat, pars = pars, survprob = TRUE) - if (is.vector(surv_t) == 1L) - surv_t <- t(surv_t) # transform if only one individual - surv_t[, (t == 0)] <- 1 # avoids possible NaN due to numerical inaccuracies - if (standardise) { # standardised survival probs - surv_t <- matrix(rowMeans(surv_t), ncol = 1) - dimnames(surv_t) <- list(iterations = NULL, "standardised_survprob") - } else { - dimnames(surv_t) <- list(iterations = NULL, ids = id_list) - } - surv_t - }) + surv_t <- lapply(time_seq, .pp_calculate_surv, + object = object, + newdataLong = ndL, + newdataEvent = ndE, + pars = pars, + type = type, + id_list = id_list, + standardise = standardise) - # If conditioning, need to obtain matrix of surv probs at last known surv time + # Calculate survival probability at last known survival time and then + # use that to calculate conditional survival probabilities if (condition) { - cond_dat <- .pp_data_jm(object, newdataLong = ndL, newdataEvent = ndE, - ids = id_list, etimes = last_time, long_parts = FALSE) - # matrix of survival probs at last_time - cond_surv <- .ll_survival(object, data = cond_dat, pars = pars, survprob = TRUE) - if (is.vector(cond_surv) == 1L) - cond_surv <- t(cond_surv) # transform if only one individual - cond_surv[, (last_time == 0)] <- 1 # avoids possible NaN due to numerical inaccuracies - surv <- lapply(surv_t, function(x) { # conditional survival probs - vec <- x / cond_surv - vec[vec > 1] <- 1 # if t was before last_time then surv prob may be > 1 - vec - }) - } else surv <- surv_t - - # Summarise posterior draws to get median and ci - out <- do.call("rbind", lapply( - seq_along(surv), function(x, standardise, id_list, time_seq, prob) { - val <- median_and_bounds(surv[[x]], prob, na.rm = TRUE) - if (standardise) { - data.frame(TIMEVAR = unique(time_seq[[x]]), val$med, val$lb, val$ub) - } else - data.frame(IDVAR = id_list, TIMEVAR = time_seq[[x]], val$med, val$lb, val$ub) - }, standardise, id_list, time_seq, prob)) - out <- data.frame(out) - colnames(out) <- c(if ("IDVAR" %in% colnames(out)) id_var, - time_var, "survpred", "ci_lb", "ci_ub") - if (id_var %in% colnames(out)) { # data has id column -- sort by id and time - out <- out[order(out[, id_var, drop = F], out[, time_var, drop = F]), , drop = F] - } else { # data does not have id column -- sort by time only - out <- out[order(out[, time_var, drop = F]), , drop = F] + if (!type == "surv") + stop("'condition' can only be set to TRUE for survival probabilities.") + cond_surv <- .pp_calculate_surv(last_time, + object = object, + newdataLong = ndL, + newdataEvent = ndE, + pars = pars, + type = type, + id_list = id_list) + surv <- lapply(surv_t, function(x) truncate(x / cond_surv, upper = 1)) + } else { + surv <- surv_t } - rownames(out) <- NULL - # temporary hack so that predictive_error can call posterior_survfit + # Summarise posterior draws to get median and CI + out <- .pp_summarise_surv(surv = surv, + prob = prob, + id_var = id_var, + time_var = time_var, + standardise = standardise) + + # Temporary hack so that 'predictive_error' can call 'posterior_survfit' # with two separate conditioning times... - fn <- tryCatch(sys.call(-1)[[1]], error = function(e) NULL) - if (!is.null(fn) && - grepl("predictive_error", deparse(fn), fixed = TRUE) && - "last_time2" %in% names(dots)) { - last_time2 <- ndE[[dots$last_time2]] - cond_dat2 <- .pp_data_jm(object, newdataLong = ndL, newdataEvent = ndE, - ids = id_list, etimes = last_time2, long_parts = FALSE) - cond_surv2 <- .ll_survival(object, data = cond_dat2, pars = pars, survprob = TRUE) - if (is.vector(cond_surv2) == 1L) - cond_surv2 <- t(cond_surv2) # transform if only one individual - cond_surv2[, (last_time2 == 0)] <- 1 # avoids possible NaN due to numerical inaccuracies - surv2 <- lapply(surv_t, function(x) { # conditional survival probs - vec <- x / cond_surv2 - vec[vec > 1] <- 1 # if t was before last_time then surv prob may be > 1 - vec - }) - out2 <- do.call("rbind", lapply( - seq_along(surv2), function(x, standardise, id_list, time_seq, prob) { - val <- median_and_bounds(surv2[[x]], prob, na.rm = TRUE) - data.frame(IDVAR = id_list, TIMEVAR = time_seq[[x]], val$med) - }, standardise, id_list, time_seq, prob)) - out2 <- data.frame(out2) - colnames(out2) <- c(id_var, time_var, "survpred_eventtime") - out2 <- out2[order(out2[, id_var, drop = F], out2[, time_var, drop = F]), , drop = F] - rownames(out2) <- NULL + fun_check <- isTRUE(grepl("predictive_error", get_calling_fun(), fixed = TRUE)) + dot_check <- isTRUE("last_time2" %in% names(dots)) + if (fun_check && dot_check) { + if (!type == "surv") + stop("'last_time2' can only be specified for survival probabilities.") + cond_surv2 <- .pp_calculate_surv(ndE[[dots$last_time2]], + object = object, + newdataLong = ndL, + newdataEvent = ndE, + pars = pars, + type = type, + id_list = id_list) + surv2 <- lapply(surv_t, function(x) truncate(x / cond_surv2, upper = 1)) + out2 <- .pp_summarise_surv(surv = surv2, + id_var = id_var, + time_var = time_var, + standardise = standardise, + colnames = "survprob_eventtime") out <- merge(out, out2) } - class(out) <- c("survfit.stanjm", "data.frame") - out <- structure(out, id_var = id_var, time_var = time_var, extrapolate = extrapolate, - control = control, standardise = standardise, condition = condition, - last_time = last_time, ids = id_list, draws = draws, seed = seed, - offset = offset) - if (dynamic && !is.null(newdataEvent)) { + # Return object + out <- structure(out, + id_var = id_var, + time_var = time_var, + type = type, + extrapolate = extrapolate, + control = control, + standardise = standardise, + condition = condition, + last_time = last_time, + ids = id_list, + draws = draws, + seed = seed, + offset = offset, + class = c("survfit.stanjm", "data.frame")) + + if (dynamic && has_newdata) { out <- structure(out, b_new = b_new, acceptance_rate = acceptance_rate) } + out } + +# ----------------- internal ------------------------------------------------ + +# Calculate the desired prediction (e.g. hazard, cumulative hazard, survival +# probability) at the specified times +.pp_calculate_surv <- function(times, + object, + newdata = NULL, + newdataLong = NULL, + newdataEvent = NULL, + pars, + type = "surv", + id_list = NULL, + standardise = FALSE) { + + if (is.stanjm(object) && !identical(length(times), length(id_list))) + stop("Bug found: vector of ids should be same length as vector of times.") + + # Determine whether prediction type requires quadrature + needs_quadrature <- type %in% c("cumhaz", + "surv", + "cdf", + "logcumhaz", + "logsurv", + "logcdf") + + # Evaluate hazard, cumulative hazard, survival or failure probability + if (is.stansurv(object)) { + ppdat <- .pp_data_surv(object, + newdata = newdata, + times = times, + at_quadpoints = needs_quadrature) + out <- .pp_predict_surv(object, + data = ppdat, + pars = pars, + type = type) + } else if (is.stanjm(object)) { + ppdat <- .pp_data_jm(object, + newdataLong = newdataLong, + newdataEvent = newdataEvent, + ids = id_list, + etimes = times, + long_parts = FALSE) + out <- .ll_survival(object, # refactoring for stanjm not yet finished + data = ppdat, + pars = pars, + survprob = TRUE) + } + + # Transform if only one individual + out <- transpose_vector(out) + + # Set survival probability == 1 if time == 0 (avoids possible NaN) + if (type == "surv") + out <- replace_where(out, times == 0, replacement = 1, margin = 2L) + + # Standardisation: within each iteration, calculate mean across individuals + if (standardise) { + out <- row_means(out) + ids <- "standardised_survprob" + times <- unique(times) + } else { + ids <- if (is.null(id_list)) seq(ncol(out)) else id_list + } + dimnames(out) <- list(iterations = NULL, ids = ids) + + # Add subject ids and prediction times as an attribute + structure(out, ids = ids, times = times) +} + + +# Evaluate hazard, cumulative hazard, survival or failure probability +# +# @param object A stansurv or stanjm object. +# @param data Output from .pp_data_surv or .pp_data_jm. +# @param pars Output from extract_pars. +# @param type The type of prediction quantity to return. +.pp_predict_surv <- function(object, ...) UseMethod(".pp_predict_surv") + +.pp_predict_surv.stansurv <- function(object, + data, + pars, + type = "surv") { + + args <- nlist(basehaz = get_basehaz(object), + intercept = pars$alpha, + betas = pars$beta, + betas_tde = pars$beta_tde, + aux = pars$aux, + times = data$pts, + x = data$x, + s = data$s) + if (type %in% c("loghaz", "haz")) { + # evaluate hazard; quadrature not relevant + lhaz <- do.call(evaluate_log_haz, args) + } else if (!data$has_quadrature){ + # evaluate survival; without quadrature + lsurv <- do.call(evaluate_log_surv, args) + } else { + # evaluate survival; with quadrature + lhaz <- do.call(evaluate_log_haz, args) + lsurv <- -quadrature_sum(exp(lhaz), qnodes = data$qnodes, qwts = data$wts) + } + + switch(type, + loghaz = lhaz, + logcumhaz = log(-lsurv), + logsurv = lsurv, + logcdf = log(1 - exp(lsurv)), + haz = exp(lhaz), + surv = exp(lsurv), + cumhaz = -lsurv, + cdf = 1 - exp(lsurv), + stop("Invalid input to the 'type' argument.")) +} + +.pp_predict_surv.stanjm <- function(object, + data, + pars, + type = "surv") { + + # time-fixed part of linear predictor + eta <- linear_predictor(pars$e_beta, data$e_x) + + # add on association structure + if (length(pars$a_beta)) { + + # temporary stop, until make_assoc_terms can handle it + sel_stop <- grep("^shared", rownames(object$assoc)) + if (any(unlist(object$assoc[sel_stop,]))) + stop2("not yet implemented for shared_* association structures.") + + # order b_pars from stanmat according to predictor matrices + pars$b <- lapply(1:get_M(object), function(m) { + b_m <- pars$b[[m]] + Z_names_m <- data$assoc_parts[[m]][["mod_eta"]][["Z_names"]] + pp_b_ord(if (is.matrix(b_m)) b_m else t(b_m), Z_names_m) + }) + + # evaluate the implicit covariates in the association structure + a_x <- make_assoc_terms(parts = data$assoc_parts, + assoc = object$assoc, + family = object$family, + beta = pars$beta, + b = pars$b) + if (one_draw) { + eta <- eta + linear_predictor.default(pars$a_beta, a_x) + } else { for (k in 1:length(a_x)) + eta <- eta + sweep(a_x[[k]], 1L, pars$a_beta[,k], `*`) + } + + } + + # add on baseline hazard + args <- nlist(basehaz = get_basehaz(object), + times = data$pts, + aux = pars$e_aux, + intercept = pars$e_alpha) + lhaz <- do.call(evaluate_log_basehaz, args) + eta + + if (!type %in% c("loghaz", "haz")) { + # evaluate survival; with quadrature + lsurv <- -quadrature_sum(exp(lhaz), qnodes = data$qnodes, qwts = data$wts) + } + + switch(type, + loghaz = lhaz, + logcumhaz = log(-lsurv), + logsurv = lsurv, + logcdf = log(1 - exp(lsurv)), + haz = exp(lhaz), + surv = exp(lsurv), + cumhaz = -lsurv, + cdf = 1 - exp(lsurv), + stop("Invalid input to the 'type' argument.")) +} + + +# Summarise predictions into median, lower CI, upper CI +# +# @details Convert a list of matrices (with each element being a S by N matrix, +# where S is the number of MCMC draws and N the number of individuals) +# and collapse it across the MCMC iterations summarising it into median +# and CI. The result is a data frame with K times N rows, where K was +# the length of the original list. +.pp_summarise_surv <- function(surv, + prob = NULL, + id_var = NULL, + time_var = NULL, + standardise = FALSE, + colnames = NULL) { + + # Default variable names if not provided by the user + if (is.null(id_var)) + id_var <- "id" + if (is.null(time_var)) + time_var <- "time" + + # Extract ids and times for the predictions + ids <- uapply(surv, attr, "ids") + times <- uapply(surv, attr, "times") + + # Determine the quantiles corresponding to the median and CI limits + if (is.null(prob)) { + probs <- 0.5 # median only + nms <- c(id_var, time_var, "median") + } else { + probs <- c(0.5, (1 - prob)/2, (1 + prob)/2) # median and CI + nms <- c(id_var, time_var, "median", "ci_lb", "ci_ub") + } + + # Possibly overide default variable names for the returned data frame + if (!is.null(colnames)) { + nms <- c(id_var, time_var, colnames) + } + + # Calculate mean and CI at each prediction time + out <- data.frame(do.call("rbind", lapply(surv, col_quantiles_, probs))) + out <- mutate_(out, id_var = ids, time_var = times) + out <- row_sort(out, id_var, time_var) + out <- col_sort(out, id_var, time_var) + out <- set_rownames(out, NULL) + out <- set_colnames(out, nms) + + # Drop excess info if standardised predictions were calculated + if (standardise) { out[[id_var]] <- NULL; id_var <- NULL } + + structure(out, + id_var = id_var, + time_var = time_var) +} + + +# ------------ print methods ------------------------------------------------ + +#' Generic print method for \code{survfit.stansurv} and \code{survfit.stanjm} +#' objects +#' +#' @rdname print.survfit.stansurv +#' @method print survfit.stansurv +#' @keywords internal +#' @export +#' @param x An object of class \code{survfit.stansurv} or \code{survfit.stanjm}, +#' returned by a call to \code{\link{posterior_survfit}}. +#' @param digits Number of digits to use for formatting the time variable and +#' the survival probabilities. +#' @param ... Ignored. +#' +print.survfit.stansurv <- function(x, digits = 4, ...) { + + x <- as.data.frame(x) + sel <- c(attr(x, "time_var"), "median", "ci_lb", "ci_ub") + for (i in sel) + x[[i]] <- format(round(x[[i]], digits), nsmall = digits) + + cat("stan_surv predictions\n") + cat(" num. individuals:", length(attr(x, "ids")), "\n") + cat(" prediction type: ", tolower(get_survpred_name(attr(x, "type"))), "\n") + cat(" standardised?: ", yes_no_string(attr(x, "standardise")), "\n\n") + print(x, quote = FALSE) + invisible(x) +} + +#' @rdname print.survfit.stansurv +#' @method print survfit.stanjm +#' @export +#' +print.survfit.stanjm <- function(x, digits = 4, ...) { + + x <- as.data.frame(x) + sel <- c(attr(x, "time_var"), "median", "ci_lb", "ci_ub") + for (i in sel) + x[[i]] <- format(round(x[[i]], digits), nsmall = digits) + + cat("stan_jm predictions\n") + cat(" num. individuals:", length(attr(x, "ids")), "\n") + cat(" prediction type: ", tolower(get_survpred_name(attr(x, "type"))), "\n") + cat(" standardised?: ", yes_no_string(attr(x, "standardise")), "\n\n") + print(x, quote = FALSE) + invisible(x) +} + + +# ----------------- plot methods -------------------------------------------- + #' Plot the estimated subject-specific or marginal survival function #' #' This generic \code{plot} method for \code{survfit.stanjm} objects will @@ -646,7 +1141,7 @@ plot.survfit.stanjm <- function(x, ids = NULL, stop("Too many individuals to plot for. Perhaps consider limiting ", "the number of individuals by specifying the 'ids' argument.") } else if ((!standardise) && (length(ids) > 1L)) { - graph <- ggplot(x, aes_string(x = "time", y = "survpred")) + + graph <- ggplot(x, aes_string(x = "time", y = "median")) + theme_bw() + do.call("geom_line", geom_args) + coord_cartesian(ylim = c(0, 1)) + @@ -656,7 +1151,7 @@ plot.survfit.stanjm <- function(x, ids = NULL, graph_limits <- do.call("geom_ribbon", c(lim_mapp, lim_args)) } else graph_limits <- NULL } else { - graph <- ggplot(x, aes_string(x = "time", y = "survpred")) + + graph <- ggplot(x, aes_string(x = "time", y = "median")) + theme_bw() + do.call("geom_line", geom_args) + coord_cartesian(ylim = c(0, 1)) @@ -673,6 +1168,25 @@ plot.survfit.stanjm <- function(x, ids = NULL, } +#' @rdname plot.survfit.stanjm +#' @method plot survfit.stansurv +#' @export +#' +plot.survfit.stansurv <- function(x, + ids = NULL, + limits = c("ci", "none"), + xlab = NULL, + ylab = NULL, + facet_scales = "free", + ci_geom_args = NULL, ...) { + mc <- match.call(expand.dots = FALSE) + mc[[1L]] <- quote(plot.survfit.stanjm) + ret <- eval(mc) + class(ret)[[1L]] <- "plot.survfit.stansurv" + ret +} + + #' @rdname plot.survfit.stanjm #' @export #' @importFrom ggplot2 ggplot_build facet_wrap aes_string expand_limits @@ -802,33 +1316,31 @@ plot_stack_jm <- function(yplot, survplot) { } -# ------------------ exported but doc kept internal +# ----------------- helpers ------------------------------------------------ -#' Generic print method for \code{survfit.stanjm} objects -#' -#' @rdname print.survfit.stanjm -#' @method print survfit.stanjm -#' @keywords internal -#' @export -#' @param x An object of class \code{survfit.stanjm}, returned by a call to -#' \code{\link{posterior_survfit}}. -#' @param digits Number of digits to use for formatting the time variable and -#' the survival probabilities. -#' @param ... Ignored. -#' -print.survfit.stanjm <- function(x, digits = 4, ...) { - time_var <- attr(x, "time_var") - x <- as.data.frame(x) - sel <- c(time_var, "survpred", "ci_lb", "ci_ub") - for (i in sel) - x[[i]] <- format(round(x[[i]], digits), nsmall = digits) - print(x, quote = FALSE) - invisible(x) +# Return a user-friendly name for the prediction type +get_survpred_name <- function(x) { + switch(x, + haz = "Hazard rate", + cumhaz = "Cumulative hazard rate", + surv = "Event free probability", + cdf = "Failure probability", + loghaz = "log(Hazard rate)", + logcumhaz = "log(Cumulative hazard rate)", + logsurv = "log(Event free probability)", + logcdf = "log(Failure probability)", + stop("Bug found: invalid input to 'type' argument.")) } -# ------------------ internal +# Return appropriate y-axis limits for the prediction type +get_survpred_ylim <- function(x) { + switch(x, + surv = c(0,1), + cdf = c(0,1), + NULL) +} -# default plotting attributes +# Default plotting attributes .PP_FILL <- "skyblue" .PP_DARK <- "skyblue4" .PP_VLINE_CLR <- "#222222" From cad6b1fcce4be27173b745c2f7adad3d40f19a9b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 15:26:13 +1100 Subject: [PATCH 041/225] Fix small typo --- R/ps_check.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/ps_check.R b/R/ps_check.R index 1922e3090..ee78c9d62 100644 --- a/R/ps_check.R +++ b/R/ps_check.R @@ -88,7 +88,7 @@ ps_check <- function(object, if (!any(is.stansurv(object), is.stanjm(object))) stop("Object is not a 'stansurv' or 'stanjm' object.") - if (is.stansurv(object) && object$has_delayed) + if (is.stansurv(object) && object$ndelayed) stop("'ps_check' cannot currently be used on models with delayed entry.") limits <- match.arg(limits) From 21c4865aab74915516db308aef6191c5d7aa6449 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 15:33:03 +1100 Subject: [PATCH 042/225] Small bit of reformatting --- R/posterior_survfit.R | 2 +- R/ps_check.R | 15 ++++++++------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 98d517034..59a416ca8 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -332,7 +332,7 @@ posterior_survfit.stansurv <- function(object, # Obtain a vector of unique subject ids if (is.null(newdata)) { - id_list <- seq(nrow(object$model_data)) + id_list <- seq(nrow(get_model_data(object))) } else { id_list <- seq(nrow(newdata)) } diff --git a/R/ps_check.R b/R/ps_check.R index ee78c9d62..d4c87f7a1 100644 --- a/R/ps_check.R +++ b/R/ps_check.R @@ -109,13 +109,14 @@ ps_check <- function(object, # Obtain the formula for KM curve type <- attr(response, "type") - form <- switch(type, - right = formula(survival::Surv(time, status, type = type) ~ 1), - counting = formula(survival::Surv(start, stop, status, type = type) ~ 1), - interval = formula(survival::Surv(time1, time2, status, type = 'interval') ~ 1), - interval2= formula(survival::Surv(time1, time2, status, type = 'interval') ~ 1), - stop("Bug found: invalid type of survival object.")) - + form <- switch( + type, + right = formula(survival::Surv(time, status, type = type) ~ 1), + counting = formula(survival::Surv(start, stop, status, type = type) ~ 1), + interval = formula(survival::Surv(time1, time2, status, type = 'interval') ~ 1), + interval2 = formula(survival::Surv(time1, time2, status, type = 'interval') ~ 1), + stop("Bug found: invalid type of survival object.")) + # Obtain the KM estimates kmfit <- survival::survfit(form, data = data.frame(unclass(response))) From 9793f0a387204011f18631831ed138ee739ece2b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 17:36:18 +1100 Subject: [PATCH 043/225] Add mice lung tumor data to example datasets --- R/doc-datasets.R | 21 +++++++++++++++++++++ data/mice.rda | Bin 0 -> 557 bytes 2 files changed, 21 insertions(+) create mode 100644 data/mice.rda diff --git a/R/doc-datasets.R b/R/doc-datasets.R index e946ec443..3ba6b5a42 100644 --- a/R/doc-datasets.R +++ b/R/doc-datasets.R @@ -64,6 +64,24 @@ #' \item \code{mom_age} Mother's age #' } #' } +#' \item{\code{mice}}{ +#' Lung tumor development in 144 RFM mice allocated to either a conventional +#' environment or germ-free environment. Mice were sacrificed and examined +#' for presence of a lung tumor. The outcome variables in the dataset +#' (\code{l} and \code{u}) denote a left-censored or right-censored time +#' interval within which the development of the first lung tumor must have +#' occurred. +#' +#' Source: Hoel and Walburg (1972) +#' +#' 144 obs. of 3 variables +#' \itemize{ +#' \item \code{l} Lower limit of the interval. +#' \item \code{u} Upper limit of the interval. +#' \item \code{grp} Experimental group (\code{ce} = conventional environment, +#' \code{ge} = germ-free environment). +#' } +#' } #' \item{\code{mortality}}{ #' Surgical mortality rates in 12 hospitals performing cardiac surgery #' in babies. @@ -181,6 +199,9 @@ #' @template reference-gelman-hill #' #' @references +#' Hoel, D. and Walburg, H. (1972) Statistical analysis of survival experiments. +#' \emph{The Annals of Statistics} \strong{18}:1259-1294. +#' #' Spiegelhalter, D., Thomas, A., Best, N., & Gilks, W. (1996) BUGS 0.5 #' Examples. MRC Biostatistics Unit, Institute of Public health, Cambridge, UK. #' diff --git a/data/mice.rda b/data/mice.rda new file mode 100644 index 0000000000000000000000000000000000000000..ef4af546f26d8d7fa316651a284134b8c576c59b GIT binary patch literal 557 zcmV+|0@D2-iwFP!000002JO~6Y|}s(!10USqBasJ5({HTrYd4$^neg!#gs8ta37FT zD=maa+t^O*I*9`rJ7#3;$e6KXMn*=)j!X?szyC$b2^c}3Sh9b2zSnp5`Q)dMDi4a4 zqEgCI_G&>{cAi|Z@=HOjsP$Q9f3M~#W#7%yv%)+1IaL4Y;XDq+-Ld%mtN3C=^h;R9 zk=QJY@2 z{iHmn?i;Z$@hp#@AI{sc7*xgi`*p;a_n7khyFQZd@&5aPm~nqVy$=&T)XhHRG$rqx z;OQ3Q-$T|(NWUTLAu1!~^L5R*9s221P~WGYnEA%cFJ}DsN=#Tk3H1}kNvWUGZ_52H z`JR-wq?@Hnf2$Lg#J1l5MvEq8@hlMM`x^Ug>LcGp*TF5MyhpyL^ZGkwJ@?rs`&Aqp zPEZ1OGUCtJSM_(E4Goz`c4V|DnS2{Hv$+Z=VbQ+_&o9 zYp;Hor%E@aa@WfL!%6LUMvK*2-96L|=G|<&wWEVZp1L-xzjXIKUEStpp{^6JNZ30K v-)OnsIB0I_*0Z&51^Hzr$=XXkbqoLi2B9lk literal 0 HcmV?d00001 From fc368d17902f486201aca7d071d14b3f12b6a184 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 17:39:14 +1100 Subject: [PATCH 044/225] Update stan_surv documentation --- R/stan_surv.R | 183 +++++++++++++++++++++++++++----------------------- 1 file changed, 99 insertions(+), 84 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index d379f09ec..dcb69e749 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -39,19 +39,22 @@ #' #' @param formula A two-sided formula object describing the model. #' The left hand side of the formula should be a \code{Surv()} -#' object. See \code{\link[survival]{Surv}}. If you wish to include -#' time-dependent effect (i.e. time-dependent coefficients) in the model -#' then the covariate(s) that you wish to estimate a time-dependent for -#' should be specified as \code{tde(varname)} where \code{varname} is the -#' name of the covariate. See the \strong{Details} section for more -#' information on how the time-dependent effects are formulated, as well -#' as the \strong{Examples} section. +#' object. Left censored, right censored, and interval censored data +#' are allowed, as well as delayed entry (i.e. left truncation). See +#' \code{\link[survival]{Surv}} for how to specify these outcome types. +#' If you wish to include time-dependent effects (i.e. time-dependent +#' coefficients, also known as non-proportional hazards) in the model +#' then any covariate(s) that you wish to estimate a time-dependent +#' coefficient for should be specified as \code{tde(varname)} where +#' \code{varname} is the name of the covariate. See the \strong{Details} +#' section for more information on how the time-dependent effects are +#' formulated, as well as the \strong{Examples} section. #' @param data A data frame containing the variables specified in #' \code{formula}. #' @param basehaz A character string indicating which baseline hazard to use #' for the event submodel. Current options are: #' \itemize{ -#' \item \code{"ms"}: a flexible parametric model using M-splines to +#' \item \code{"ms"}: a flexible parametric model using cubic M-splines to #' model the baseline hazard. The default locations for the internal knots, #' as well as the basis terms for the splines, are calculated with respect #' to time. If the model does \emph{not} include any time-dependendent @@ -60,35 +63,36 @@ #' On the other hand, if the model does include time-dependent effects then #' quadrature is used to evaluate the cumulative hazard at each MCMC #' iteration and, therefore, estimation of the model will be slower. -#' \item \code{"bs"}: a flexible parametric model using B-splines to model -#' the \emph{log} baseline hazard. The default locations for the internal -#' knots, as well as the basis terms for the splines, are calculated with -#' respect to time. A closed form solution for the cumulative hazard -#' is \strong{not} available (regardless of whether or not the model includes -#' time-dependent effects) and therefore quadrature is used to evaluate -#' the cumulative hazard at each MCMC iteration. Therefore, if the model +#' \item \code{"bs"}: a flexible parametric model using cubic B-splines to +#' model the \emph{log} baseline hazard. The default locations for the +#' internal knots, as well as the basis terms for the splines, are calculated +#' with respect to time. A closed form solution for the cumulative hazard +#' is \strong{not} available regardless of whether or not the model includes +#' time-dependent effects; instead, quadrature is used to evaluate +#' the cumulative hazard at each MCMC iteration. Therefore, if your model #' does not include any time-dependent effects, then estimation using the -#' \code{"ms"} baseline will be faster. +#' \code{"ms"} baseline hazard will be faster. #' \item \code{"exp"}: an exponential distribution for the event times. #' (i.e. a constant baseline hazard) #' \item \code{"weibull"}: a Weibull distribution for the event times. #' \item \code{"gompertz"}: a Gompertz distribution for the event times. #' } -#' Note that all spline-based models use splines of degree 3 (i.e. cubic -#' splines). +#' Note that all spline-based models use cubic splines. The number of degrees +#' of freedom and/or location of the knots can be changed #' @param basehaz_ops a named list specifying options related to the baseline #' hazard. Currently this can include: \cr #' \itemize{ #' \item \code{df}: a positive integer specifying the degrees of freedom -#' for the M-splines / I-splines. The default is 6. -#' \item \code{knots}: An optional numeric vector specifying the internal -#' knot locations for the splines if \code{basehaz = "ms"}. Knots cannot be -#' specified if \code{df} is specified. If not specified, then the -#' default is to use \code{df - 4} knots, which are +#' for the M-splines or B-splines. The default is 5, corresponding to +#' two boundary knots and two internal knots. +#' \item \code{knots}: An optional numeric vector specifying internal +#' knot locations for the M-splines or B-splines. Note that \code{knots} +#' cannot be specified if \code{df} is specified. If \code{knots} are not +#' specified, then the default is to use \code{df - 3} knots which are #' placed at equally spaced percentiles of the distribution of #' uncensored event times. -#' \item \code{bknots}: an optional numeric vector specifying the boundary -#' knot locations for the splines if \code{basehaz = "ms"}. +#' \item \code{bknots}: an optional numeric vector specifying boundary +#' knot locations for the M-splines or B-splines. #' If not specified, then the default is to place the boundary knots at the #' minimum and maximum of the event times (including both censored and #' uncensored events). @@ -97,11 +101,17 @@ #' that is used to evaluate the cumulative hazard when \code{basehaz = "bs"} #' or when time-dependent effects (i.e. non-proportional hazards) are #' specified. Options are 15 (the default), 11 or 7. -#' @param prior_aux The prior distribution for the parameters related to the -#' baseline hazard. The relevant "auxiliary" parameters differ depending on +#' @param prior_aux The prior distribution for "auxiliary" parameters related to +#' the baseline hazard. The relevant parameters differ depending #' on the type of baseline hazard specified in the \code{basehaz} #' argument. The following applies: #' \itemize{ +#' \item \code{basehaz = "ms"}: the auxiliary parameters are the coefficients +#' for the M-spline basis terms on the baseline hazard. These parameters +#' have a lower bound at zero. +#' \item \code{basehaz = "bs"}: the auxiliary parameters are the coefficients +#' for the B-spline basis terms on the log baseline hazard. These parameters +#' are unbounded. #' \item \code{basehaz = "exp"}: there is \strong{no} auxiliary parameter, #' since the log scale parameter for the exponential distribution is #' incorporated as an intercept in the linear predictor. @@ -113,12 +123,6 @@ #' scale parameter, while the log shape parameter for the Gompertz #' distribution is incorporated as an intercept in the linear predictor. #' The auxiliary parameter has a lower bound at zero. -#' \item \code{basehaz = "ms"}: the auxiliary parameters are the coefficients -#' for the M-spline basis terms on the baseline hazard. These parameters -#' have a lower bound at zero. -#' \item \code{basehaz = "bs"}: the auxiliary parameters are the coefficients -#' for the B-spline basis terms on the log baseline hazard. These parameters -#' are unbounded. #' } #' Currently, \code{prior_aux} can be a call to \code{normal}, \code{student_t} #' or \code{cauchy}. See \code{\link{priors}} for details on these functions. @@ -127,20 +131,22 @@ #' @param prior_smooth This is only relevant when time-dependent effects are #' specified in the model (i.e. the \code{tde()} function is used in the #' model formula. When that is the case, \code{prior_smooth} determines the -#' prior distribution for the hyperparameter of the smoothing function -#' for the time-dependent coefficients (specifically the standard deviation -#' of the cubic B-spline coefficients). Lower values for the hyperparameter -#' yield a less flexible smooth function. \code{prior_smooth} can be a call -#' to \code{exponential} to +#' prior distribution given to the hyperparameter (standard deviation) +#' contained in a random-walk prior for the cubic B-spline coefficients used +#' to model the time-dependent coefficient. Lower values for the hyperparameter +#' yield a less a flexible smooth function for the time-dependent coefficient. +#' Specifically, \code{prior_smooth} can be a call to \code{exponential} to #' use an exponential distribution, or \code{normal}, \code{student_t} or #' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy #' prior. See \code{\link{priors}} for details on these functions. To omit a #' prior ---i.e., to use a flat (improper) uniform prior--- set #' \code{prior_smooth} to \code{NULL}. The number of hyperparameters depends -#' on the model specification but a scalar prior will be recylced as necessary +#' on the model specification (i.e. the number of time-dependent effects +#' specified in the model) but a scalar prior will be recylced as necessary #' to the appropriate length. #' #' @details +#' \subsection{Time dependent effects (i.e. non-proportional hazards)}{ #' By default, any covariate effects specified in the \code{formula} are #' included in the model under a proportional hazards assumption. To relax #' this assumption, it is possible to estimate a time-dependent coefficient @@ -148,24 +154,42 @@ #' by wrapping the covariate name in the \code{tde()} function (note that #' this function is not an exported function, rather it is an internal function #' that can only be evaluated within the formula of a \code{stan_surv} call). +#' #' For example, if we wish to estimate a time-dependent effect for the #' covariate \code{sex} then we can specify \code{tde(sex)} in the #' \code{formula}, e.g. \code{Surv(time, status) ~ tde(sex) + age + trt}. #' The coefficient for \code{sex} will then be modelled #' using a flexible smooth function based on a cubic B-spline expansion of -#' time. The flexibility of the smooth function can be controlled through -#' the hyperparameters related the B-spline coefficients; see the -#' \code{prior_smooth} argument. Also, by default the cubic B-spline basis is -#' evaluated with 3 degrees of freedom (that is a cubic spline basis with -#' boundary knots at the limits of the time range, but no internal knots). If -#' you wish to increase the flexibility of the smooth function by using a +#' time. +#' +#' The flexibility of the smooth function can be controlled in two ways: +#' \itemize{ +#' \item First, through control of the prior distribution for the cubic B-spline +#' coefficients that are used to model the time-dependent coefficient. +#' Specifically, one can control the flexibility of the prior through +#' the hyperparameter (standard deviation) of the random walk prior used +#' for the B-spline coefficients; see the \code{prior_smooth} argument. +#' \item Second, one can increase or decrease the number of degrees of +#' freedom used for the cubic B-spline function that is used to model the +#' time-dependent coefficient. By default the cubic B-spline basis is +#' evaluated using 3 degrees of freedom (that is a cubic spline basis with +#' boundary knots at the limits of the time range, but no internal knots). +#' If you wish to increase the flexibility of the smooth function by using a #' greater number of degrees of freedom, then you can specify this as part -#' of the \code{tde} function call. For example, to use cubic B-splines with -#' 7 degrees of freedom we could specify \code{tde(sex, df = 7)} in the -#' model formula. See the \strong{Examples} section below for more details. +#' of the \code{tde} function call in the model formula. For example, to +#' use cubic B-splines with 7 degrees of freedom we could specify +#' \code{tde(sex, df = 7)} in the model formula instead of just +#' \code{tde(sex)}. See the \strong{Examples} section below for more +#' details. +#' } +#' In practice, the default \code{tde()} function should provide sufficient +#' flexibility for model most time-dependent effects. However, it is worth +#' noting that the reliable estimation of a time-dependent effect usually +#' requires a relatively large number of events in the data (e.g. >1000). +#' } #' #' @examples -#' +#' \donttest{ #' #---------- Proportional hazards #' #' # Simulated data @@ -183,38 +207,33 @@ #' mod1b <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "bs") #' mod1c <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "exp") #' mod1d <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "weibull") -#' #mod1e <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "gompertz") -#' do.call(cbind, lapply(list(mod1a, mod1b, mod1c, mod1d), fixef)) -#' bayesplot::bayesplot_grid(plot(mod1a), plot(mod1b), -#' plot(mod1c), plot(mod1d), -#' ylim = c(0, 0.8)) +#' mod1e <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "gompertz") +#' do.call(cbind, lapply(list(mod1a, mod1b, mod1c, mod1d, mod1e), fixef)) +#' bayesplot::bayesplot_grid(plot(mod1a), # compare baseline hazards +#' plot(mod1b), +#' plot(mod1c), +#' plot(mod1d), +#' plot(mod1e), +#' ylim = c(0, 0.6)) #' -#' # Breast cancer data -#' library(flexsurv) -#' dat2 <- flexsurv::bc -#' fm2 <- Surv(rectime, censrec) ~ group -#' mod2a <- stan_surv(fm2, dat2, chains = 1, iter = 1000) -#' mod2z <- flexsurv::flexsurvspline(fm2, dat2, k = 3) -#' print(mod2a, 4) -#' mod2z -#' #' # PBC data -#' dat3 <- survival::pbc -#' dat3$timeYears <- dat3$time / 365.25 -#' dat3$death <- (dat3$status == 2) -#' fm3 <- Surv(timeYears, death) ~ sex + trt -#' mod3a <- stan_surv(fm3, dat3, chains = 1, iter = 1000) -#' mod3z <- flexsurv::flexsurvspline(fm3, dat3, k = 3) -#' print(mod3a, 4) -#' mod3z -#' +#' mod2 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, +#' data = pbcSurv, chains = 1, iter = 1000) +#' print(mod2, 4) +#' +#' #---------- Interval censored data +#' +#' # Mice tumor data +#' mod3 <- stan_surv(Surv(l, u, type = "interval2") ~ grp, +#' data = mice, chains = 1, iter = 1000) +#' print(mod3, 4) +#' #' #---------- Non-proportional hazards #' #' # Simulated data #' library(simsurv) -#' library(rstpm2) -#' covs <- data.frame(id = 1:1000, -#' trt = stats::rbinom(1000, 1L, 0.5)) +#' covs <- data.frame(id = 1:500, +#' trt = stats::rbinom(500, 1L, 0.5)) #' dat4 <- simsurv(lambdas = 0.1, #' gammas = 1.5, #' betas = c(trt = -0.5), @@ -222,15 +241,11 @@ #' x = covs, #' maxt = 5) #' dat4 <- merge(dat4, covs) -#' fm4 <- Surv(eventtime, status) ~ tde(trt) -#' mod4a <- stan_surv(Surv(eventtime, status) ~ tde(trt), -#' dat4, chains = 1, iter = 1000) -#' mod4z <- rstpm2::stpm2(Surv(eventtime, status) ~ trt, -#' dat4, tvc = list(trt = 5)) -#' print(mod4a, 4) -#' mod4z -#' plot(mod4a, "tde") -#' plot(mod4z, newdata = data.frame(trt = 0), type = "hr", var = "trt") +#' mod4 <- stan_surv(Surv(eventtime, status) ~ tde(trt), +#' data = dat4, chains = 1, iter = 1000) +#' print(mod4, 4) +#' plot(mod4, "tde") # time-dependent hazard ratio +#' } #' stan_surv <- function(formula, data, From 3172a0e6c9fe24ad432879ada36516cae7ea49bf Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 17:54:41 +1100 Subject: [PATCH 045/225] Add additional models to tests for stan_surv --- tests/testthat/test_stan_surv.R | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 59ef954ab..e1af2a108 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -194,7 +194,10 @@ test_that("basehaz argument works", { #-------- Check post-estimation functions work - # fit the models + pbcSurv$t0 <- 0 + pbcSurv$t0[pbcSurv$futimeYears > 2] <- 1 # delayed entry + + # different baseline hazards o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, data = pbcSurv, basehaz = "ms", @@ -208,12 +211,21 @@ test_that("basehaz argument works", { o<-SW(f4 <- update(f1, basehaz = "weibull")) o<-SW(f5 <- update(f1, basehaz = "gompertz")) - o<-SW(f6 <- update(f1, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f7 <- update(f2, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f8 <- update(f3, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f9 <- update(f4, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f10 <- update(f5, formula. = Surv(futimeYears, death) ~ sex + tde(trt))) - + # time-dependent effects + o<-SW(f6 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f7 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f8 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f9 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f10 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt))) + + # start-stop notation (incl. delayed entry) + o<-SW(f11 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) + o<-SW(f12 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) + + # interval censoring + o<-SW(f13 <- update(f1, Surv(l, u, type = "interval2") ~ grp, data = mice)) + o<-SW(f14 <- update(f1, Surv(l, u, type = "interval2") ~ tde(grp), data = mice)) + # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] From 126f9722a93bd7e2965afe1811bad3e895cd75ca Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 18:07:13 +1100 Subject: [PATCH 046/225] Fix small bug in stan_surv design matrix Bug was only encountered when both interval censoring and quadrature were present. --- R/stan_surv.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/stan_surv.R b/R/stan_surv.R index dcb69e749..7980b6e3f 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -432,6 +432,7 @@ stan_surv <- function(formula, rep_rows(x_lcens, times = qnodes), rep_rows(x_rcens, times = qnodes), rep_rows(x_icens, times = qnodes), + rep_rows(x_icens, times = qnodes), rep_rows(x_delay, times = qnodes)) } From 34f8bf1de5c44e2aaf9c827d806296240be1b118 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 18:07:42 +1100 Subject: [PATCH 047/225] Fix small bug in surv.stan with interval censoring and quadrature combined --- src/stan_files/functions/hazard_functions.stan | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan index 009727c65..b7a71a40a 100644 --- a/src/stan_files/functions/hazard_functions.stan +++ b/src/stan_files/functions/hazard_functions.stan @@ -98,7 +98,7 @@ vector[M] hazard_lower = exp(log_hazard_lower); vector[M] hazard_upper = exp(log_hazard_upper); matrix[N,qnodes] qwts_lower_mat = to_matrix(qwts_lower, N, qnodes); - matrix[N,qnodes] qwts_upper_mat = to_matrix(qwts_lower, N, qnodes); + matrix[N,qnodes] qwts_upper_mat = to_matrix(qwts_upper, N, qnodes); matrix[N,qnodes] haz_lower_mat = to_matrix(hazard_lower, N, qnodes); matrix[N,qnodes] haz_upper_mat = to_matrix(hazard_upper, N, qnodes); vector[N] chaz_lower = rows_dot_product(qwts_lower_mat, haz_lower_mat); From 91bbf829c6946acde58e64fcd3b1e3203a9592bf Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 29 Oct 2018 18:39:41 +1100 Subject: [PATCH 048/225] Add dummy = in a bunch of places to get around Stan parser messages --- src/stan_files/functions/jm_functions.stan | 7 +- src/stan_files/functions/mvmer_functions.stan | 20 +++-- src/stan_files/jm.stan | 32 +++++--- src/stan_files/model/mvmer_lp.stan | 17 ++-- src/stan_files/model/priors_mvmer.stan | 78 ++++++++++++------- src/stan_files/mvmer.stan | 10 +-- src/stan_files/surv.stan | 35 +++++---- 7 files changed, 123 insertions(+), 76 deletions(-) diff --git a/src/stan_files/functions/jm_functions.stan b/src/stan_files/functions/jm_functions.stan index 7bf6d71cf..f058f1f16 100644 --- a/src/stan_files/functions/jm_functions.stan +++ b/src/stan_files/functions/jm_functions.stan @@ -3,7 +3,7 @@ * * @param aux_unscaled A vector, the unscaled auxiliary parameters * @param prior_dist Integer, the type of prior distribution - * @param prior_mean,prior_scale Vectors, the mean and scale + * @param prior_mean,prior_scale Vectors, the mean and scale * of the prior distribution * @return A vector, corresponding to the scaled auxiliary parameters */ @@ -28,9 +28,9 @@ * @param dist Integer specifying the type of prior distribution * @param scale Real specifying the scale for the prior distribution * @param df Real specifying the df for the prior distribution - * @return nothing + * @return Nothing */ - void basehaz_lp(vector aux_unscaled, int dist, vector scale, vector df) { + real basehaz_lp(vector aux_unscaled, int dist, vector scale, vector df) { if (dist > 0) { if (dist == 1) target += normal_lpdf(aux_unscaled | 0, 1); @@ -39,6 +39,7 @@ else target += exponential_lpdf(aux_unscaled | 1); } + return target(); } /** diff --git a/src/stan_files/functions/mvmer_functions.stan b/src/stan_files/functions/mvmer_functions.stan index bafcf6451..7650ed4b2 100644 --- a/src/stan_files/functions/mvmer_functions.stan +++ b/src/stan_files/functions/mvmer_functions.stan @@ -242,9 +242,9 @@ * @param prior_dist Integer, the type of prior distribution * @param prior_mean,prior_scale Vectors of mean and scale parameters * for the prior distributions - * @return A vector containing the population level parameters (coefficients) + * @return Nothing */ - void glm_lp(vector y_real, int[] y_integer, vector eta, real[] aux, + real glm_lp(vector y_real, int[] y_integer, vector eta, real[] aux, int family, int link, real sum_log_y, vector sqrt_y, vector log_y) { if (family == 1) { // gaussian if (link == 1) target += normal_lpdf(y_real | eta, aux[1]); @@ -274,6 +274,7 @@ else target += neg_binomial_2_lpmf(y_integer | linkinv_count(eta, link), aux[1]); } else reject("Invalid family."); + return target(); } /** @@ -288,9 +289,9 @@ * @param global Real, the global parameter * @param mix Vector of shrinkage parameters * @param one_over_lambda Real - * @return nothing + * @return Nothing */ - void beta_lp(vector z_beta, int prior_dist, vector prior_scale, + real beta_lp(vector z_beta, int prior_dist, vector prior_scale, vector prior_df, real global_prior_df, vector[] local, real[] global, vector[] mix, real[] one_over_lambda, real slab_df, real[] caux) { @@ -328,6 +329,7 @@ target += normal_lpdf(z_beta | 0, 1); } /* else prior_dist is 0 and nothing is added */ + return target(); } /** @@ -338,14 +340,15 @@ * @param mean Real, mean of prior distribution * @param scale Real, scale for the prior distribution * @param df Real, df for the prior distribution - * @return nothing + * @return Nothing */ - void gamma_lp(real gamma, int dist, real mean, real scale, real df) { + real gamma_lp(real gamma, int dist, real mean, real scale, real df) { if (dist == 1) // normal target += normal_lpdf(gamma | mean, scale); else if (dist == 2) // student_t target += student_t_lpdf(gamma | df, mean, scale); /* else dist is 0 and nothing is added */ + return target(); } /** @@ -356,9 +359,9 @@ * @param dist Integer specifying the type of prior distribution * @param scale Real specifying the scale for the prior distribution * @param df Real specifying the df for the prior distribution - * @return nothing + * @return Nothing */ - void aux_lp(real aux_unscaled, int dist, real scale, real df) { + real aux_lp(real aux_unscaled, int dist, real scale, real df) { if (dist > 0 && scale > 0) { if (dist == 1) target += normal_lpdf(aux_unscaled | 0, 1); @@ -367,6 +370,7 @@ else target += exponential_lpdf(aux_unscaled | 1); } + return target(); } /** diff --git a/src/stan_files/jm.stan b/src/stan_files/jm.stan index f30f3da67..adc7da847 100644 --- a/src/stan_files/jm.stan +++ b/src/stan_files/jm.stan @@ -116,17 +116,27 @@ model { //---- Log priors // increments target with mvmer priors #include /model/priors_mvmer.stan - beta_lp(e_z_beta, e_prior_dist, e_prior_scale, e_prior_df, - e_global_prior_df, e_local, e_global, e_mix, e_ool, - e_slab_df, e_caux); - beta_lp(a_z_beta, a_prior_dist, a_prior_scale, a_prior_df, - a_global_prior_df, a_local, a_global, a_mix, a_ool, - a_slab_df, a_caux); - basehaz_lp(e_aux_unscaled, e_prior_dist_for_aux, - e_prior_scale_for_aux, e_prior_df_for_aux); - if (e_has_intercept == 1) - gamma_lp(e_gamma[1], e_prior_dist_for_intercept, e_prior_mean_for_intercept, - e_prior_scale_for_intercept, e_prior_df_for_intercept); + if (e_K > 0) { + real dummy = beta_lp(e_z_beta, e_prior_dist, e_prior_scale, e_prior_df, + e_global_prior_df, e_local, e_global, e_mix, e_ool, + e_slab_df, e_caux); + } + if (a_K > 0) { + real dummy = beta_lp(a_z_beta, a_prior_dist, a_prior_scale, a_prior_df, + a_global_prior_df, a_local, a_global, a_mix, a_ool, + a_slab_df, a_caux); + } + if (basehaz_df > 0) { + real dummy = basehaz_lp(e_aux_unscaled, e_prior_dist_for_aux, + e_prior_scale_for_aux, e_prior_df_for_aux); + } + if (e_has_intercept == 1) { + real dummy = gamma_lp(e_gamma[1], + e_prior_dist_for_intercept, + e_prior_mean_for_intercept, + e_prior_scale_for_intercept, + e_prior_df_for_intercept); + } } generated quantities { real e_alpha; // transformed intercept for event submodel diff --git a/src/stan_files/model/mvmer_lp.stan b/src/stan_files/model/mvmer_lp.stan index 69524ada5..690598642 100644 --- a/src/stan_files/model/mvmer_lp.stan +++ b/src/stan_files/model/mvmer_lp.stan @@ -28,9 +28,16 @@ // Log-likelihoods if (prior_PD == 0) { - glm_lp(yReal1, yInt1, yEta1, yAux1, family[1], link[1], sum_log_y1, sqrt_y1, log_y1); - if (M > 1) - glm_lp(yReal2, yInt2, yEta2, yAux2, family[2], link[2], sum_log_y2, sqrt_y2, log_y2); - if (M > 2) - glm_lp(yReal3, yInt3, yEta3, yAux3, family[3], link[3], sum_log_y3, sqrt_y3, log_y3); + if (M > 0) { + real dummy = glm_lp(yReal1, yInt1, yEta1, yAux1, family[1], link[1], + sum_log_y1, sqrt_y1, log_y1); + } + if (M > 1) { + real dummy = glm_lp(yReal2, yInt2, yEta2, yAux2, family[2], link[2], + sum_log_y2, sqrt_y2, log_y2); + } + if (M > 2) { + real dummy = glm_lp(yReal3, yInt3, yEta3, yAux3, family[3], link[3], + sum_log_y3, sqrt_y3, log_y3); + } } diff --git a/src/stan_files/model/priors_mvmer.stan b/src/stan_files/model/priors_mvmer.stan index 88d94cc95..5ad818f0e 100644 --- a/src/stan_files/model/priors_mvmer.stan +++ b/src/stan_files/model/priors_mvmer.stan @@ -1,38 +1,56 @@ // Log-priors, auxiliary params - if (has_aux[1] == 1) - aux_lp(yAux1_unscaled[1], y_prior_dist_for_aux[1], - y_prior_scale_for_aux[1], y_prior_df_for_aux[1]); - if (M > 1 && has_aux[2] == 1) - aux_lp(yAux2_unscaled[1], y_prior_dist_for_aux[2], - y_prior_scale_for_aux[2], y_prior_df_for_aux[2]); - if (M > 2 && has_aux[3] == 1) - aux_lp(yAux3_unscaled[1], y_prior_dist_for_aux[3], - y_prior_scale_for_aux[3], y_prior_df_for_aux[3]); + if (M > 0 && has_aux[1] == 1) { + real dummy = aux_lp(yAux1_unscaled[1], y_prior_dist_for_aux[1], + y_prior_scale_for_aux[1], y_prior_df_for_aux[1]); + } + if (M > 1 && has_aux[2] == 1) { + real dummy = aux_lp(yAux2_unscaled[1], y_prior_dist_for_aux[2], + y_prior_scale_for_aux[2], y_prior_df_for_aux[2]); + } + if (M > 2 && has_aux[3] == 1) { + real dummy = aux_lp(yAux3_unscaled[1], y_prior_dist_for_aux[3], + y_prior_scale_for_aux[3], y_prior_df_for_aux[3]); + } // Log priors, intercepts - if (intercept_type[1] > 0) - gamma_lp(yGamma1[1], y_prior_dist_for_intercept[1], y_prior_mean_for_intercept[1], - y_prior_scale_for_intercept[1], y_prior_df_for_intercept[1]); - if (M > 1 && intercept_type[2] > 0) - gamma_lp(yGamma2[1], y_prior_dist_for_intercept[2], y_prior_mean_for_intercept[2], - y_prior_scale_for_intercept[2], y_prior_df_for_intercept[2]); - if (M > 2 && intercept_type[3] > 0) - gamma_lp(yGamma3[1], y_prior_dist_for_intercept[3], y_prior_mean_for_intercept[3], - y_prior_scale_for_intercept[3], y_prior_df_for_intercept[3]); + if (M > 0 && intercept_type[1] > 0) { + real dummy = gamma_lp(yGamma1[1], + y_prior_dist_for_intercept[1], + y_prior_mean_for_intercept[1], + y_prior_scale_for_intercept[1], + y_prior_df_for_intercept[1]); + } + if (M > 1 && intercept_type[2] > 0) { + real dummy = gamma_lp(yGamma2[1], + y_prior_dist_for_intercept[2], + y_prior_mean_for_intercept[2], + y_prior_scale_for_intercept[2], + y_prior_df_for_intercept[2]); + } + if (M > 2 && intercept_type[3] > 0) { + real dummy = gamma_lp(yGamma3[1], + y_prior_dist_for_intercept[3], + y_prior_mean_for_intercept[3], + y_prior_scale_for_intercept[3], + y_prior_df_for_intercept[3]); + } // Log priors, population level params - if (yK[1] > 0) - beta_lp(z_yBeta1, y_prior_dist[1], y_prior_scale1, y_prior_df1, - y_global_prior_df[1], yLocal1, yGlobal1, yMix1, yOol1, - y_slab_df[1], y_caux1); - if (M > 1 && yK[2] > 0) - beta_lp(z_yBeta2, y_prior_dist[2], y_prior_scale2, y_prior_df2, - y_global_prior_df[2], yLocal2, yGlobal2, yMix2, yOol2, - y_slab_df[2], y_caux2); - if (M > 2 && yK[3] > 0) - beta_lp(z_yBeta3, y_prior_dist[3], y_prior_scale3, y_prior_df3, - y_global_prior_df[3], yLocal3, yGlobal3, yMix3, yOol3, - y_slab_df[3], y_caux3); + if (M > 0 && yK[1] > 0) { + real dummy = beta_lp(z_yBeta1, y_prior_dist[1], y_prior_scale1, y_prior_df1, + y_global_prior_df[1], yLocal1, yGlobal1, yMix1, yOol1, + y_slab_df[1], y_caux1); + } + if (M > 1 && yK[2] > 0) { + real dummy = beta_lp(z_yBeta2, y_prior_dist[2], y_prior_scale2, y_prior_df2, + y_global_prior_df[2], yLocal2, yGlobal2, yMix2, yOol2, + y_slab_df[2], y_caux2); + } + if (M > 2 && yK[3] > 0) { + real dummy = beta_lp(z_yBeta3, y_prior_dist[3], y_prior_scale3, y_prior_df3, + y_global_prior_df[3], yLocal3, yGlobal3, yMix3, yOol3, + y_slab_df[3], y_caux3); + } // Log priors, group level terms if (prior_dist_for_cov == 1) { // decov diff --git a/src/stan_files/mvmer.stan b/src/stan_files/mvmer.stan index 428f1ff28..b07b15dae 100644 --- a/src/stan_files/mvmer.stan +++ b/src/stan_files/mvmer.stan @@ -21,8 +21,8 @@ data { // family, link, y{1,2,3}_Z{1,2}, y{1,2,3}_Z{1,2}_id, // y_prior_dist{_for_intercept,_for_aux,_for_cov}, prior_PD #include /data/data_mvmer.stan - - // declares: y_prior_{mean,scale,df}{1,2,3,_for_intercept,_for_aux}, + + // declares: y_prior_{mean,scale,df}{1,2,3,_for_intercept,_for_aux}, // y_global_prior_{df,scale}, len_{concentration,regularization}, // b_prior_{shape,scale,concentration,regularization}, // b{1,2}_prior_{scale,df,regularization} @@ -36,12 +36,12 @@ transformed data { parameters { // declares: yGamma{1,2,3}, z_yBeta{1,2,3}, z_b, z_T, rho, // zeta, tau, bSd{1,2}, z_bMat{1,2}, bCholesky{1,2}, - // yAux{1,2,3}_unscaled, yGlobal{1,2,3}, yLocal{1,2,3}, + // yAux{1,2,3}_unscaled, yGlobal{1,2,3}, yLocal{1,2,3}, // yOol{1,2,3}, yMix{1,2,3} #include /parameters/parameters_mvmer.stan } -transformed parameters { - // declares and defines: yBeta{1,2,3}, yAux{1,2,3}, yAuxMaximum, +transformed parameters { + // declares and defines: yBeta{1,2,3}, yAux{1,2,3}, yAuxMaximum, // theta_L, bMat{1,2} #include /tparameters/tparameters_mvmer.stan } diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 544057384..c11a3384b 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -156,9 +156,9 @@ functions { * @param global Real, the global parameter * @param mix Vector of shrinkage parameters * @param one_over_lambda Real - * @return nothing + * @return Nothing */ - void beta_lp(vector z_beta, int prior_dist, vector prior_scale, + real beta_lp(vector z_beta, int prior_dist, vector prior_scale, vector prior_df, real global_prior_df, vector[] local, real[] global, vector[] mix, real[] one_over_lambda, real slab_df, real[] caux) { @@ -196,6 +196,7 @@ functions { target += normal_lpdf(z_beta | 0, 1); } /* else prior_dist is 0 and nothing is added */ + return target(); } /** @@ -206,14 +207,15 @@ functions { * @param mean Real, mean of prior distribution * @param scale Real, scale for the prior distribution * @param df Real, df for the prior distribution - * @return nothing + * @return Nothing */ - void gamma_lp(real gamma, int dist, real mean, real scale, real df) { + real gamma_lp(real gamma, int dist, real mean, real scale, real df) { if (dist == 1) // normal target += normal_lpdf(gamma | mean, scale); else if (dist == 2) // student_t target += student_t_lpdf(gamma | df, mean, scale); /* else dist is 0 and nothing is added */ + return target(); } /** @@ -223,9 +225,9 @@ functions { * auxiliary parameter(s) * @param dist Integer specifying the type of prior distribution * @param df Real specifying the df for the prior distribution - * @return nothing + * @return Nothing */ - void basehaz_lp(vector aux_unscaled, int dist, vector df) { + real basehaz_lp(vector aux_unscaled, int dist, vector df) { if (dist > 0) { if (dist == 1) target += normal_lpdf(aux_unscaled | 0, 1); @@ -234,6 +236,7 @@ functions { else target += exponential_lpdf(aux_unscaled | 1); } + return target(); } /** @@ -245,9 +248,9 @@ functions { * smoothing sds * @param df Vector of reals specifying the df for the prior distribution * for the smoothing sds - * @return nothing + * @return Nothing */ - void smooth_lp(vector z_beta_tde, vector smooth_sd_raw, int dist, vector df) { + real smooth_lp(vector z_beta_tde, vector smooth_sd_raw, int dist, vector df) { target += normal_lpdf(z_beta_tde | 0, 1); if (dist > 0) { real log_half = -0.693147180559945286; @@ -258,6 +261,7 @@ functions { else if (dist == 3) target += exponential_lpdf(smooth_sd_raw | 1); } + return target(); } /** @@ -772,24 +776,27 @@ model { // log priors for coefficients if (K > 0) { - beta_lp(z_beta, prior_dist, prior_scale, prior_df, global_prior_df, - local, global, mix, ool, slab_df, caux); + real dummy = beta_lp(z_beta, prior_dist, prior_scale, prior_df, + global_prior_df, local, global, mix, ool, + slab_df, caux); } // log prior for intercept if (has_intercept == 1) { - gamma_lp(gamma[1], prior_dist_for_intercept, prior_mean_for_intercept, - prior_scale_for_intercept, prior_df_for_intercept); + real dummy = gamma_lp(gamma[1], prior_dist_for_intercept, + prior_mean_for_intercept, prior_scale_for_intercept, + prior_df_for_intercept); } // log priors for baseline hazard parameters if (nvars > 0) { - basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); + real dummy = basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); } // log priors for tde spline coefficients and their smoothing parameters if (S > 0) { - smooth_lp(z_beta_tde, smooth_sd_raw, prior_dist_for_smooth, prior_df_for_smooth); + real dummy = smooth_lp(z_beta_tde, smooth_sd_raw, + prior_dist_for_smooth, prior_df_for_smooth); } } From d3150964508ab67e01032d4cfa29d77fef9b333f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 30 Oct 2018 09:53:37 +1100 Subject: [PATCH 049/225] Add simsurv to DESCRIPTION Suggests Used in stan_surv examples and vignettes --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 6c28a9525..c0e226f57 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -59,6 +59,7 @@ Suggests: mgcv (>= 1.8-13), rmarkdown, roxygen2, + simsurv (>= 0.2.2), testthat (>= 1.0.2) LinkingTo: StanHeaders (>= 2.18.0), rstan (>= 2.18.1), BH (>= 1.66.0), Rcpp (>= 0.12.0), RcppEigen (>= 0.3.3.3.0) From 42d5f887983b164360dd05ed6098d3ef99f72672 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 30 Oct 2018 15:23:07 +1100 Subject: [PATCH 050/225] Add the breast cancer survival dataset --- R/doc-datasets.R | 30 ++++++++++++++++++++++++++++-- data/bcancer.rda | Bin 0 -> 6961 bytes 2 files changed, 28 insertions(+), 2 deletions(-) create mode 100644 data/bcancer.rda diff --git a/R/doc-datasets.R b/R/doc-datasets.R index 3ba6b5a42..890ae44f4 100644 --- a/R/doc-datasets.R +++ b/R/doc-datasets.R @@ -50,6 +50,22 @@ #' \item \code{K} Number of at-bats #' } #' } +#' \item{\code{bcancer}}{ +#' The German Breast Cancer Study Group dataset, containing time to death or +#' recurrence for 686 patients with primary node positive breast cancer +#' recruited between 1984-1989. +#' +#' Source: Royston and Parmar (2002) +#' +#' 686 obs. of 4 variables +#' \itemize{ +#' \item \code{recdays} Time to death or censoring (in days) +#' \item \code{recyrs} Time to death or censoring (in years) +#' \item \code{status} Event indicator (0 = right censored, 1 = event) +#' \item \code{group} Prognostic group, based on a regression model developed +#' by Sauerbrei and Royston (1999) (\code{Good}, \code{Medium}, \code{Poor}) +#' } +#' } #' \item{\code{kidiq}}{ #' Data from a survey of adult American women and their children #' (a subsample from the National Longitudinal Survey of Youth). @@ -200,9 +216,19 @@ #' #' @references #' Hoel, D. and Walburg, H. (1972) Statistical analysis of survival experiments. -#' \emph{The Annals of Statistics} \strong{18}:1259-1294. +#' \emph{The Annals of Statistics} \strong{18}:1259--1294. +#' +#' Royston, P. and Parmar, M. (2002) Flexible parametric proportional-hazards +#' and proportional-odds models for censored survival data, with application +#' to prognostic modelling and estimation of treatment effects. +#' \emph{Statistics in Medicine} \strong{21}(1):2175--2197. +#' +#' Sauerbrei, W. and Royston, P. (1999) Building multivariable prognostic and +#' diagnostic models: transformation of the predictors using fractional +#' polynomials. \emph{Journal of the Royal Statistical Society, Series A} +#' \strong{162}:71--94. #' -#' Spiegelhalter, D., Thomas, A., Best, N., & Gilks, W. (1996) BUGS 0.5 +#' Spiegelhalter, D., Thomas, A., Best, N., and Gilks, W. (1996) BUGS 0.5 #' Examples. MRC Biostatistics Unit, Institute of Public health, Cambridge, UK. #' #' Tarone, R. E. (1982) The use of historical control information in testing for diff --git a/data/bcancer.rda b/data/bcancer.rda new file mode 100644 index 0000000000000000000000000000000000000000..75cb67b949e4a62a860aa61f149ec6a8f1939b4b GIT binary patch literal 6961 zcmdtm`8(9>{|E4MQi%zbB!ncDY-y|!MW`exS+Zx1853eK!yK{|5rr%fDtq?#*eA;& z8OA=$Fk@e58fF;A81p^f^ZD&_K7YZvpZE2;p4a2Le}4UNOUEDi?eBA#ngy?wHez+b zx9wXzUQrRz3uzrNV0xt@=9u{N=~9 zm*n$o?yu)+T{aP@#|!Ep=c{6qq(qIrXlx5u3wv`lUSG~Ku?P&ahs|!mH#io}`cg{V z7`ntIR1BxNp9t$u0gqAk3=#bk1q<+?yu=A<1%WJv8nmqV`B1ASynHJ6dQlu|U z)4wG~UEQ8zA#10O;?sgrn!6vO=?bUupi9z!TnnsqhzhkU(B&mdeP<&ES|w-$=5sS% z_ydx)Dg_nv{UV0-B-*Iuj@L`r7j-0Owcq zq;livIhS<$!fVA|U8~5Ox}?iJN>;hSa%(2yh$R}walxW4&8li^mA0Id6&BZd!rD#+ zZd!-(L0!6sgo9C+R>eoOg>j{M)UE;cfp75-P@W??N63ywVuAU3lW>D9oee?GX!j>l z`uZMxq+>_6>`|cdH`nzrQTs{@*0B-d5$agm^)7U7euC-++SC3I<|{nSI=nRB?y1@9 ziw`3D3Su{?ez14*miA7@EZy3+fG~|!$ZHT(c>G(`h86dZtGn`TQeQmY)4r?sRKUb& z!U+m7)XT)_Db0<9t#T4ba^w!P%Vy&nf0JdBL711d6jP%ZDI$uLjp3?IH|PrBtw^Hh zcAkrH&ijVjRII8GbP=pSIkge+g11`2D;|aN<7pN#*Vignmf_>*B6 z>?lG``lIVjFzG;geC*)zn$Bt2F1zrt?nDXCl>DiS1BR&7ck4(I5}AU}i)6j8x<8sb zCl*jtP7Ax*3JT0dIYY&#T^A6|xt&Fi{5EQ3f7##&qxHvf>+aWLL_`S}OI^g(UuFEoHoQ+FhzZ0GSc_?t(rB!lvIM5{13uM^ z`keq>Qaj^f_yAZv{HW-zVu$&=>kmX%z5vfotL!O;NOB^0Q(@DQ=3S2ldB@86Q7SUz zkxv%>tizC^mN#p9_5;N?(G*HTa7p_0;nKK|^aj1O*>GGZfAACDij=B)NBV}NVWPY~ zRqR+p!>>g=k!68A|Ld=J&duH8X>GlqU#~qy2F!7R?LP5E;i>7c+NkV@G1Bj=Jk-bY zHbtb08AIvzj`ipt?Cb+LDx>+jeNo(s5nY#(#eg zSgII)!F++d{k{1!2>KSaW;1+ZM-sDy2a82sOP>>~%5he@>uf5bYH>)kG%jNIY%{zu zvEu`RLf^9@dG>m;?cdk$O}++U?_5D=_NpX`q71}1Cd%9v3P;l)5>p}fqnwYDTqfeL zhpgI*c4j?gl*B#uB0fA zn4GbyswnzH#l2G1z`oNaE2V}Um;E6$PQdkWU;T^e2{U2&ppc*mi~7bq31`Vw1==PTd{izW{% zI0BKENi0ymQIfR-kTz9h?J?gU{mNOqTj_od&wX1o99c*7e7fbURF?Tlk#0!r3=`Ipd{g)wh224U)k4Rxw=qDF21UZA`yIp$Iz%c zGZQmMI8jsut)wHcyZjx5f)Ru2cN+>uRG=?I!WVc|Y@8LQ%mp-Y6;BsAl>Be$+{&Dc zVt7d4Rynge6_Lp8-ri>!N;m*R`xiBJJ?+{9h&PF_Al!z^hm}Vce+BM$fuJjs+8Buu zb^>)gxa~9NN#VqCX~@P#2d0I9C1KTr`v7=2gRZ7G1ZZWXN>{&0azGL`vrukXNq#(t z9^)n7CaYdslxqApDx1_8V3P67XEK;l({uOF?OkgWve#olK4^JIznR(dDvOZ%u5bY% z1aT`c6hv%iN+UgDJB;C($+@Av$q-}WtM%kihXlr<*q`m&`kPbzNx*nb0thqxM zqO1#GHraj%U5L*9NaM;c-ez|@C$Rwh?-CA>EGsUhJe_&k+xjO~o^siTGx}JSla=tK zma$X9TJG&XizXcQjGh5Q#;6&Zghb~g!eocaadN{LKn)lMNn>{bYO_CjZQCBx(WS4w z>33U{gU;a?ca%7FhVEaGs4sUO()opmlLUry%?XG#eFBg)c}u#=&{~H!2-o}Q8jH(8 zW!h2;fvp%e@J*VdKx_>+nG*t6fy~2&Wt{R-NVmsAPlX;g0s6dG zefAph(Bs>Lv_djmA(fp<#bWCKNsZ4|*EkWHeMT8N30G+54$?VSIs_5jfn^XpxwVNb zTi9%mEl>|A7=$djA-)Yt!fKSlwOOKlxdk)Y?>uZf*L#i(^Lx7=0RMQAJ$ykqsoC8)g(9;q` zD=d?clm#^j7|WwJwja7(kReH#&_H(OJrA+##kyeaTqFrdAg-YgQ+=Di9=uksbo%-Lfh%* zk~+wik|UqK-)pkQ&?VZxB};U(KY2N+{j+g7z+s=Lf*6D;Z%zUH{-XUfRz)iDUd^+HiY1xkj zx!zfochN2W2~f-hkXzFb2G?zM<|8xPs~6sI=z2R)-;GDP#y$>@mSUnm_Ji>CRdGCc zZvu<G*QM1Pa604g`p{@{c|o}J3zavm)IBhoRD0Y z<3sFdj^sd#w`u9dXzsX%r$=#CH0bIdANG$GYGZoC9Vln_cun6C$yh;#SARS0Eb-JV z=6LC5ch;C1$F{BxDjzUC;}JUj0{V1OE9k+r1!wo@F#xow%i1@jtgB|UQ9hM`5(bS( zd`z{PsY={OADuTm3ojUVD{*hJ&>(eCd*geDTIzE%DItK>dQ=fOMHv*Q->LOI^%j`w z(G7O#zXLY(KtWO(CVl}EM%|y1C`V#(~!MqtCj6h&&7rtPLvePu7vEHccKM=*@c&WD1+ zMR}Xb&uAr2(hlqyNi-;`?eG)D=;rZD#gdfCXLws+)+(%mVYUbihkFnmGLc?6Az&J1Pi!9K|85l`&C=|Ivs z7EO=HzaWe}-aP6xrL4EmAdle9si)klN}Iz{UCA`Gc#XT>_!wvZXWC1Bb=Hn1NEg$$ zsi^d(R#L|Ns9?}D5aZ~Y^VdT;i~CtSewiydK8wOITBKcBiSm>)0J> zCTD0PVAON*`*SQW4@_nR_8x<+1@0THD2w;ga9f-jRQx$v-W#+Ve7Sz;iZ!)st8AFZOXm$7`Sb>r&4lYY$AiclF2KH{l$48s=jigqOZe(NEp77ck5LXy)GQ@VS zD9&$%+9ahqG=?E9`Xz`!EaSa8Hh)^B&jn-GKj{i0HWUzp9qiUaY<}d9VzF6Ee!eDA zeg`pNT2xrDE83J&4k&C&GihJBUyr^8{v;AFM07CV@I?Hxtd4NB9HoNJ!6kfWSDLGX zk*(mG_V9*NO#J}EY@;@FLPx9GIKF<6!xitL?D zqJ5VIZ+(VDK;$W+r8yEoHscj)p%`%P0_!KP8+oSx(3hj^i}RDUR6W#b{p?XtVp^o{ z6dPS0yG?bGwx(yR4;$D=h1E!|;+xiq8kj1uwC{Vl{z;OD#k7f*XXeC={c%=3U^b&$ z_b`qf`ojs_LjE8>gUk#-J~$0C95>fw2RP*LLT4{k_QwPbEMp^Hb6_7lXL4P*&Wll; zhbS#;;4oM07qHQ%GCs~u%1EVkAd#8-GTXDAo5|1}E#j3-oUS!C|1EyD5(VwSO}UT> zvmx#}oRD6ufZs;z(wB@iPUk(rrFSMgG#*c=;SVya;SxO?%<+}Dy6*_aL#@As_hUiq zksy@sRb|i_HQF7p?0O#c6@Db`-mzt~Ezjt)02soB**ySc6NL*&5H;{4UdpKbD;)E9QTUd|c zk)@AFF7xI%ZPYN^Bm%_J)=0qJ0Q)1c=DNpMGU|hQ8t-IE{5tYMPBI?OR&$vE``jD>;@m?=a}gT=Zg1 zZR@N%(kYW!O*lHjbRsJCN^LwOsgzY9UUmJXr=KK{{<*3- zFs(Ky9u=SdT!|EP2YPtOfl#+&lh(bMi=Im9QX61%qxgEOduIXroH`p)>;BeM_1-hv zR&+gSh@e7ZGFDZ}In}EwLPEUN!*oEph~~~(yirxJ_)%`uPKs-rImJ8s^F}MsyrwfS zp5Bd1UuymAb0_fd(2jZ64q0j`rAzf~OZtK^&xG4qC#SJ(oX%Lpu01J4d4+f*$hQ6Q z&+UrbnyJ@5f7Z?JqFPf#@PE}U{lHW!dxdWzc<#?F7}w4^5W6gFoFpdg&b=n;#39my zT)Pv0`cSThj#zX{ze7zxDdT?eTNc_#?2nBQQKN2?1YKlgskoATS!hRn)kR+<<%g?r z?1gbtwvZp(@mR>s#Y3s0FC1?(49p#u`#@oNZ(qP3zHf|AxpcSsQgQz0_=iv4hrWIY zv$(8wD^G@Bz``re!0@Da{=l*5m`nd5TdyAmhNr}<2i``ICw1^7>bHF{)dJPWR=wZ*9hf*lVea&IIt|Q z_K%7lSXNRC1-&5|6#RGH<$u#^P*5?jtf2N^)xKb)rRRcTP|YQq_llQKsmII5Usq&S z->&m534BzZ;9&6?-t9oFHclPLyN~u>l{nA9+v-21y7_$ zcZhwysEXtF-!z|Yd#BI<0IB_%WNcF9^a*>M1-CmtFJ@{{?6vbq>SLaR7+n(z= zaVPC|^{o`Se=p_#IAN4_srpv3+-pS(w^!#(Pul*ADN}LK?bQWSHQW526J}{%)wkZs z{d*}TMNZ!KUpOM=CY;jKP8o6cMN8fk7~enLuyK6OSPC4vfkAQ7G57vd;8tt+Zq5`K v=cwuFT5SXm)z3cLi%J$w#N}Q#Nt8hB`B^YE>jvAoJo3@k4uC9w`|bY#0Eh&6 literal 0 HcmV?d00001 From 02dfb33325e9ba80b14d9676790289a449cf8dea Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 30 Oct 2018 15:23:25 +1100 Subject: [PATCH 051/225] Update stan_surv help documentation --- R/stan_surv.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 7980b6e3f..94d2c03fe 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -19,13 +19,14 @@ #' Bayesian survival models via Stan #' #' \if{html}{\figure{stanlogo.png}{options: width="25px" alt="http://mc-stan.org/about/logo/"}} -#' Bayesian inference for proportional or non-proportional hazards regression -#' models. The user can specify a variety of standard parametric distributions -#' for the baseline hazard, or a flexible parametric model (using either -#' M-splines for modelling the baseline hazard, or B-splines for modelling -#' the log baseline hazard). Covariate effects can be accommodated under -#' proportional hazards or non-proportional hazards (i.e. time-dependent -#' effects). +#' Bayesian inference for survival models (sometimes known as models for +#' time-to-event data). Currently, the command fits standard parametric +#' (exponential, Weibull and Gompertz) and flexible parametric (cubic +#' spline-based) survival models on the hazard scale, with covariates included +#' under assumptions of either proportional or non-proportional hazards. +#' Where relevant, non-proportional hazards are modelled using a flexible +#' cubic spline-based function for the time-dependent effect (i.e. the +#' time-dependent hazard ratio). #' #' @export #' @importFrom splines bs From 0e627e91547590cb96427a9201dce4694173da0b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 30 Oct 2018 15:51:31 +1100 Subject: [PATCH 052/225] log_lik.R: fix small bug in baseline survival evaluator for Gompertz --- R/log_lik.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/log_lik.R b/R/log_lik.R index 16f83f83f..e6b74b3fd 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -1162,7 +1162,7 @@ log_basesurv_weibull <- function(x, shape, log_scale) { -exp(as.vector(log_scale) + linear_predictor(shape, log(x))) } log_basesurv_gompertz <- function(x, scale, log_shape) { - -(as.vector(log_shape / scale)) * (exp(linear_predictor(scale, x)) - 1) + -(as.vector(exp(log_shape) / scale)) * (exp(linear_predictor(scale, x)) - 1) } log_basesurv_ms <- function(x, coefs, basis) { -linear_predictor(coefs, basis_matrix(x, basis = basis, integrate = TRUE)) From 65aea84d6da5c7af7e57804cd21b33c088551d0d Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 30 Oct 2018 17:01:02 +1100 Subject: [PATCH 053/225] Update aliases for rstanarm datasets documentation --- R/doc-datasets.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/doc-datasets.R b/R/doc-datasets.R index 890ae44f4..27134f9fe 100644 --- a/R/doc-datasets.R +++ b/R/doc-datasets.R @@ -20,7 +20,8 @@ #' Small datasets for use in \pkg{rstanarm} examples and vignettes. #' #' @name rstanarm-datasets -#' @aliases kidiq roaches wells bball1970 bball2006 mortality tumors radon pbcLong pbcSurv +#' @aliases bball1970 bball2006 bcancer kidiq mice mortality +#' @aliases pbcLong pbcSurv tumors radon roaches wells #' @format #' \describe{ #' \item{\code{bball1970}}{ From fe903fa1d71f06217f440d13ccaec00b8842d22e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 30 Oct 2018 17:29:34 +1100 Subject: [PATCH 054/225] Drop response from model frame when building x in pp_data_surv --- R/pp_data.R | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index 46b45ca00..a07115c63 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -293,13 +293,9 @@ pp_data <- } # time-fixed predictor matrix - mf <- make_model_frame(formula = formula$tf_form, - data = newdata, - check_constant = FALSE)$mf - x <- make_x(formula = formula$tf_form, - model_frame = mf, - xlevs = object$xlevs, - check_constant = FALSE)$x + tf_form <- reformulate_rhs(rhs(formula$tf_form)) + mf <- make_model_frame(tf_form, newdata, check_constant = FALSE)$mf + x <- make_x(tf_form, mf, xlevs= object$xlevs, check_constant = FALSE)$x if (has_quadrature && at_quadpoints) { x <- rep_rows(x, times = qnodes) } From f2c44acc0ca7b2279ab9b31c684288d5b083ef1e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 30 Oct 2018 18:12:50 +1100 Subject: [PATCH 055/225] Add vignette for stan_surv --- vignettes/surv.Rmd | 426 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 426 insertions(+) create mode 100644 vignettes/surv.Rmd diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd new file mode 100644 index 000000000..96da15ecd --- /dev/null +++ b/vignettes/surv.Rmd @@ -0,0 +1,426 @@ +--- +title: "Estimating Survival (Time-to-Event) Models with rstanarm" +author: "Sam Brilleman" +date: "`r Sys.Date()`" +output: + html_vignette: + toc: true + number_sections: false +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + + + + + +```{r, child="children/SETTINGS-knitr.txt"} +``` +```{r, child="children/SETTINGS-gg.txt"} +``` +```{r, child="children/SETTINGS-rstan.txt"} +``` +```{r, child="children/SETTINGS-loo.txt"} +``` + +```{r setup_jm, include=FALSE, message=FALSE} +knitr::opts_chunk$set(fig.width=10, fig.height=4) +library(rstanarm) +``` + + +# Preamble + +This vignette provides an introduction to the `stan_surv` modelling function in the __rstanarm__ package. The `stan_surv` function allows the user to fit survival models (sometimes known as models for time-to-event data) under a Bayesian framework. + +Currently, the command fits standard parametric (exponential, Weibull and Gompertz) and flexible parametric (cubic spline-based) survival models on the hazard scale, with covariates included under assumptions of either proportional or non-proportional hazards. Where relevant, non-proportional hazards are modelled using a flexible cubic spline-based function for the time-dependent effect (i.e. the time-dependent hazard ratio). + + +# Introduction + +Survival (a.k.a. time-to-event) analysis is generally concerned with the time from some defined baseline (e.g. diagnosis of a disease) until an event of interest occurs (e.g. death or disease progression). In standard survival analysis, one event time is measured for each observational unit. In practice however, that event time may be unobserved due to left, right, or interval censoring, in which case the event time is only known to have occurred within the relevant censoring interval. A number of extensions to standard survival analysis have also been proposed, for example, multiple (recurrent) events, competing events, clustered survival data, cure models, and more. + +In general, there are two common approaches to modelling time-to-event data. The first is to model the time-to-event outcome directly (e.g. the class of models known as accelerated failure time models). The second is to model the *rate* of the event (e.g. the class of models known as proportional and non-proportional hazards regression models). Currently, the `stan_surv` modelling function focusses on the latter. + +The intention is for the `stan_surv` modelling function in the **rstanarm** package to provide functionality for fitting a wide range of Bayesian survival models. The current implementation allows for a hazard-scale regression model with + +- a standard parametric or flexible parametric baseline hazard +- covariates included under proportional or non-proportional hazards +- time-varying covariates +- left, right or interval censoring +- delayed entry (i.e. left truncation) + +Future plans include extensions to allow for + +- group-specific parameters (i.e. random/frailty effects) +- shared frailty models +- accelerated failure time (AFT) specification + + +# Technical details + +## Data and notation + +We assume that a true event time for individual $i$ ($i = 1,...,N$) exists, denoted $T_i^*$, but that in practice may or may not observed due to left, right, or interval censoring. Therefore, in practice we observe outcome data $\mathcal{D}_i = \{T_i, T_i^U, T_i^E, d_i\}$ for individual $i$ where + +- $T_i$: the observed event or censoring time +- $T_i^U$: the observed upper limit for interval censored individuals +- $T_i^E$: the observed entry time (i.e. the time at which an individual became at risk for the event) + +and $d_i \in \{0,1,2,3\}$ denotes an event indicator taking value + +- 0 if individual $i$ was right censored (i.e. $T_i^* > T_i$) +- 1 if individual $i$ was uncensored (i.e. $T_i^* = T_i$) +- 2 if individual $i$ was left censored (i.e. $T_i^* < T_i$) +- 3 if individual $i$ was interval censored (i.e. $T_i < T_i^* < T_i^U$) + +## The hazard rate, cumulative hazard, and survival probability + +The hazard of the event at time $t$ is the instantaneous rate of occurrence for the event at time $t$. Mathematically, it is defined as +\ +\begin{equation} +\begin{split} +h_i(t) = \lim_{\Delta t \to 0} + \frac{P(t \leq T_i^* < t + \Delta t | T_i^* > t)}{\Delta t} +\end{split} +\end{equation} +\ +where $\Delta t$ is the width of some small time interval. The numerator in is the conditional probability of the individual experiencing the event during the time interval $[t, t + \Delta t)$, given that they were still at risk of the event at time $t$. The denominator in the equation converts the conditional probability to a rate per unit of time. As $\Delta t$ approaches the limit, the width of the interval approaches zero and the instantaneous event rate is obtained. + +The cumulative hazard is defined as +\ +\begin{equation} +\begin{split} +H_i(t) = \int_{s=0}^t h_i(s) ds +\end{split} +\end{equation} + +The survival probability is defined as +\ +\begin{equation} +\begin{split} +S_i(t) = \exp \left[ -H_i(t) \right] = \exp \left[ -\int_{s=0}^t h_i(s) ds \right] +\end{split} +\end{equation} + +## Model formulation + +We model the hazard of the event for individual $i$ using the following regression model +\ +\begin{equation} +\begin{split} +h_i(t) = h_0(t) \exp \left[ \eta_i(t) \right] +\end{split} +\end{equation} +\ +where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the (possibly time-dependent) linear predictor evaluated for individual $i$ at time $t$. + +We further define the baseline hazard and linear predictor in the next sections. + +### Baseline hazard + +The `stan_surv` modelling function, via its `basehaz` argument, allows the baseline hazard $h_0(t)$ to be specified using any of the following parametric formulations. + +- **Exponential distribution**: for scale parameter $\lambda > 0$ we have + +\begin{equation} +h_0(t) = \lambda +\end{equation} + +- **Weibull distribution**: for scale parameter $\lambda > 0$ and shape parameter $\gamma > 0$ we have + +\begin{equation} +h_0(t) = \gamma t^{\gamma-1} \lambda +\end{equation} + +- **Gompertz distribution**: for shape parameter $\lambda > 0$ and scale parameter $\gamma > 0$ we have + +\begin{equation} +h_0(t) = \exp(\gamma t) \lambda +\end{equation} + +- **M-splines**, the default: letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have + +\begin{equation} +h_0(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +\end{equation} + +- **B-splines** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have + +\begin{equation} +\log h_0(t) = B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +\end{equation} + +Note that for the exponential, Weibull, and Gompertz baseline hazards, $\log \lambda$ is absorbed as an intercept term in the linear predictor $\eta_i(t)$. It is therefore shown as such in the output for `stan_surv`. + +### Linear predictor + +The effects of covariates are introduced through the linear predictor under proportional or non-proportional hazards assumptions. That is, we define our linear predictor as +\ +\begin{equation} +\begin{split} +\eta_i(t) = \boldsymbol{X_i^T(t)} \boldsymbol{\beta(t)} +\end{split} +\end{equation} +\ +where $\boldsymbol{X_i^T(t)}$ is a vector of covariates (possibly time-varying) for individual $i$, and $\boldsymbol{\beta(t)} = \{ \beta_p(t); p = 1,...,P \}$ is a vector of parameters with each element defined as +\ +\begin{align} +\beta_p(t) = + \begin{cases} + \theta_{p,0} + & \text{for proportional hazards} \\ + \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) + & \text{for non-proportional hazards} + \end{cases} +\end{align} +\ +such that $\theta_{p,0}$ is a time-fixed hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent hazard ratio as a smooth function of time. + +In the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent hazard ratio for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. + +## Likelihood + +Allowing for the three forms of censoring, and potential delayed entry (i.e. left truncation), the likelihood takes the form +\ +\begin{align} +\begin{split} +p(\mathcal{D}_i | \boldsymbol{\gamma}, \boldsymbol{\beta}) = + & {\left[ h_i(T_i) \right]}^{I(d_i=1)} \\ + & \times {\left[ S_i(T_i) \right]}^{I(d_i \in \{0,1\})} \\ + & \times {\left[ 1 - S_i(T_i) \right]}^{I(d_i=2)} \\ + & \times {\left[ S_i(T_i) - S_i(T_i^U) \right]}^{I(d_i=3)} \\ + & \times {\left[ S_i(T_i^E) \right]}^{-1} +\end{split} +\end{align} + +## Priors + +The prior distribution for the baseline hazard parameters (i.e. $\gamma$ for Weibull or Gompertz baseline hazards, or $\boldsymbol{\gamma}$ for the M-spline or B-spline baseline hazards) is specified via the `prior_aux` argument to `stan_surv`. Choices of prior distribution include half-normal, half-t or half-Cauchy for the Weibull, Gompertz and M-spline baseline hazards, or normal, t, or Cauchy for the B-splines log baseline hazard. These choices are described in greater detail in the `stan_surv` help file. + +For the exponential, Weibull, or Gompertz baseline hazards the prior distribution for the intercept parameter in the linear predictor, that is $\log \lambda$, is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. + +The choice of prior distribution for the time-fixed hazard ratios $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the priors [vignette](priors.html) and the `stan_surv` help file for details. + +The B-spline coefficients related to each time-dependent effect, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. + + +# Usage examples + +## Example: a flexible parametric proportional hazards model + +We will use the German Breast Cancer Study Group dataset (see `?rstanarm-datasets` for details and references). In brief, the data consist of +$N = 686$ patients with primary node positive breast cancer recruited between 1984-1989. The primary response is time to recurrence or death. Median follow-up time was 1084 days. Overall, there were 299 (44%) events and the remaining 387 (56%) individuals were right censored. We concern our analysis here with a 3-category baseline covariate for cancer prognosis (good/medium/poor). + +First, let us load the data and fit the proportional hazards model + +```{r, warning = FALSE, message = FALSE, results='hide'} +library(rstanarm) +fm <- Surv(recyrs, status) ~ group +mod1 <- stan_surv(fm, data = bcancer, seed = 123321) +``` + +The model here is estimated using the default cubic M-splines (with 5 degrees of freedom) for modelling the baseline hazard. Since there are no time-dependent effects in the model (i.e. we did not wrap any covariates in the `tde()` function) there is a closed form expression for the cumulative hazard and survival function and so the model is relatively fast to fit. Specifically, the model takes ~3.5 sec for each MCMC chain based on the default 2000 (1000 warm up, 1000 sampling) MCMC iterations. + +We can easily obtain the estimated hazard ratios for the 3-catgeory group covariate using the generic `print` method for `stansurv` objects, as follows + +```{r} +print(mod1, digits = 3) +``` + +We see from this output we see that individuals in the groups with `Poor` or `Medium` prognosis have much higher rates of death relative to the group with `Good` prognosis (as we might expect!). The hazard of death in the `Poor` prognosis group is approximately 4.6-fold higher than the hazard of death in the `Good` prognosis group. Similarly, the hazard of death in the `Medium` prognosis group is approximately 2.1-fold higher than the hazard of death in the `Good` prognosis group. + +It may also be of interest to compare the different types of the baseline hazard we could potentially use. Here, we will fit a series of models, each with a different baseline hazard specification and then plot those baseline hazards with 95% posterior uncertainty limits + +```{r, warning = FALSE, message = FALSE, results='hide'} +mod1_exp <- stan_surv(fm, data = bcancer, basehaz = "exp") +mod1_weibull <- stan_surv(fm, data = bcancer, basehaz = "weibull") +mod1_gompertz <- stan_surv(fm, data = bcancer, basehaz = "gompertz") +mod1_bspline <- stan_surv(fm, data = bcancer, basehaz = "bs") +mod1_mspline1 <- stan_surv(fm, data = bcancer, basehaz = "ms") +mod1_mspline2 <- stan_surv(fm, data = bcancer, basehaz = "ms", + basehaz_ops = list(df = 10)) +``` + +```{r, echo=FALSE, fig.height=5} +library(ggplot2) + +p_exp <- + plot(mod1_exp, plotfun = "basehaz") + + ggplot2::coord_cartesian(ylim = c(0,0.4)) + + ggplot2::labs(title = "Exponential") + + ggplot2::theme(plot.title = element_text(hjust = 0.5)) + +p_weibull <- + plot(mod1_weibull, plotfun = "basehaz") + + ggplot2::coord_cartesian(ylim = c(0,0.4)) + + ggplot2::labs(title = "Weibull") + + ggplot2::theme(plot.title = element_text(hjust = 0.5)) + +p_gompertz <- + plot(mod1_gompertz, plotfun = "basehaz") + + ggplot2::coord_cartesian(ylim = c(0,0.4)) + + ggplot2::labs(title = "Gompertz") + + ggplot2::theme(plot.title = element_text(hjust = 0.5)) + +p_bspline <- + plot(mod1_bspline, plotfun = "basehaz") + + ggplot2::coord_cartesian(ylim = c(0,0.4)) + + ggplot2::labs(title = "B-splines with df = 5") + + ggplot2::theme(plot.title = element_text(hjust = 0.5)) + +p_mspline1 <- + plot(mod1_mspline1, plotfun = "basehaz") + + ggplot2::coord_cartesian(ylim = c(0,0.4)) + + ggplot2::labs(title = "M-splines with df = 5") + + ggplot2::theme(plot.title = element_text(hjust = 0.5)) + +p_mspline2 <- + plot(mod1_mspline2, plotfun = "basehaz") + + ggplot2::coord_cartesian(ylim = c(0,0.4)) + + ggplot2::labs(title = "M-splines with df = 10") + + ggplot2::theme(plot.title = element_text(hjust = 0.5)) + +bayesplot::bayesplot_grid(p_exp, + p_weibull, + p_gompertz, + p_bspline, + p_mspline1, + p_mspline2, + grid_args = list(ncol = 3)) +``` + +We can also compare the fit of these models using the `loo` method for `stansurv` objects + +```{r, message=FALSE} +compare_models(loo(mod1_exp), + loo(mod1_weibull), + loo(mod1_gompertz), + loo(mod1_bspline), + loo(mod1_mspline1), + loo(mod1_mspline2)) +``` + +where we see that models with a flexible parametric (spline-based) baseline hazard fit the data best followed by the standard parametric (Weibull, Gompertz, exponential) models. Specifically, B-splines used to approximate the log baseline hazard appear to perform best, followed by the M-spline model with a greater number of degrees of freedom for the M-splines leading to a marginally better fit. However, overall, the differences in `elpd` or `looic` between models are small relative to their standard errors. + +After fitting the survival model, we often want to estimate the predicted survival function for individual's with different covariate patterns. Here, let us estimate the predicted survival function between 0 and 5 years for an individual in each of the prognostic groups. To do this, we can use the `posterior_survfit` method for `stansurv` objects, and it's associated `plot` method. First let us construct the prediction (covariate) data + +```{r preddata} +nd <- data.frame(group = c("Good", "Medium", "Poor")) +head(nd) +``` + +and then we will generate the posterior predictions + +```{r predresults} +ps <- posterior_survfit(mod1, newdata = nd, times = 0, extrapolate = TRUE, + control = list(edist = 5)) +head(ps) +``` + +Here we note that the `id` variable in the data frame of posterior predictions identifies which row of `newdata` the predictions correspond to. For demonstration purposes we have also shown a couple of other arguments in the `posterior_survfit` call, namely + +- the `times = 0` argument says that we want to predict at time = 0 (i.e. baseline) for each individual in the `newdata` (this is the default anyway) +- the `extrapolate = TRUE` argument says that we want to extrapolate forward from time 0 (this is also the default) +- the `control = list(edist = 5)` identifies the control of the extrapolation; this is saying extrapolate the survival function forward from time 0 for a distance of 5 time units (the default would have been to extrapolate as far as the largest event or censoring time in the estimation dataset, which is 7.28 years in the `brcancer` data). + +Let us now plot the survival predictions. We will relabel the `id` variable with meaningful labels identifying the covariate profile of each new individual in our prediction data + +```{r predplot} +panel_labels <- c('1' = "Good", '2' = "Medium", '3' = "Poor") +plot(ps) + + ggplot2::facet_wrap(~ id, labeller = ggplot2::labeller(id = panel_labels)) +``` + +We can see from the plot that predicted survival is worst for patients with a `Poor` diagnosis, and best for patients with a `Good` diagnosis, as we would expect based on our previous model estimates. + +Alternatively, if we wanted to obtain and plot the predicted *hazard* function for each individual in our new data (instead of their *survival* function), then we just need to specify `type = "haz"` in our `posterior_survfit` call (the default is `type = "surv"`), as follows + +```{r predhaz} +ph <- posterior_survfit(mod1, newdata = nd, type = "haz") +plot(ph) + + ggplot2::facet_wrap(~ id, labeller = ggplot2::labeller(id = panel_labels)) +``` + +We can quite clearly see in the plot the assumption of proportional hazards. We can also see that the hazard is highest in the `Poor` prognosis group (i.e. worst survival) and the hazard is lowest in the `Good` prognosis group (i.e. best survival). This corresponds to what we saw in the plot of the survival functions previously. + +## Example: a model with non-proportional hazards + +To demonstrate the implementation of time-dependent effects in `stan_surv` we will use a simulated dataset, generated using the **simsurv** package (Brilleman, 2018). + +We will simulate a dataset with $N = 200$ individuals with event times generated under the following Weibull hazard function +\ +\begin{align} +h_i(t) = \gamma t^{\gamma-1} \lambda exp( \beta(t) x_i ) +\end{align} +\ +with scale parameter $\lambda = 0.1$, shape parameter $\gamma = 1.5$, binary baseline covariate $X_i \sim \text{Bern}(0.5)$, and time-dependent hazard ratio $\beta(t) = -0.5 + 0.2 t$. We will enforce administrative censoring at 5 years if an individual's simulated event time is >5 years. + +```{r simsurv-simdata} +# load package +library(simsurv) + +# set seed for reproducibility +set.seed(999111) + +# simulate covariate data +covs <- data.frame(id = 1:100, + trt = rbinom(100, 1L, 0.5)) + +# simulate event times +dat <- simsurv(lambdas = 0.1, + gammas = 1.5, + betas = c(trt = -0.5), + tde = c(trt = 0.2), + x = covs, + maxt = 5) + +# merge covariate data and event times +dat <- merge(dat, covs) + +# examine first few rows of data +head(dat) +``` + +Now that we have our simulated dataset, let us fit a model with time-dependent hazard ratio for `trt` + +```{r, warning = FALSE, message = FALSE, results='hide'} +# define formula +fm <- Surv(eventtime, status) ~ tde(trt) + +# fit Stan model with time-dependent hazard ratio +mod2 <- stan_surv(formula = fm, data = dat, seed = 5544, iter = 500) +``` + +By default the cubic B-spline basis used for modelling the time-dependent hazard ratio is evaluated with 3 degrees of freedom (i.e. two boundary knots placed at the limits of the range of event times, but no internal knots). For a more or less flexible spline function we can specify the `df` arugment to `tde()` function. For example, we could specify the model formula as + +```{r, warning = FALSE, message = FALSE, results='hide', eval=FALSE} +fm <- Surv(eventtime, status) ~ tde(trt, df = 5) +``` + +so that we use 5 degrees of freedom for modelling the time-dependent effect (i.e. two boundary knots placed at the limits of the range of event times, as well as two internal knots placed - by default - at the 33.3rd and 66.6th percentiles of the distribution of uncensored event times). + +Let us now plot the estimated time-dependent hazard ratio from the fitted model. We can do this using the generic `plot` method for `stansurv` objects, for which we can specify the `plotfun = "tde"` argument. (Note that in this case, there is only one covariate in the model with a time-dependent effect, but if there were others, we could specify which covariate(s) we want to plot the time-dependent effect for by specifying the `pars` argument to the `plot` call). + +```{r, fig.height=5} +plot(mod2, plotfun = "tde") +``` + +From the plot, we can see how the hazard ratio (i.e. the effect of treatment on the hazard of the event) changes as a function of time. The treatment appears to be protective during the first few years following baseline (i.e. HR < 1), and then the treatment appears to become harmful after about 4 years post-baseline (of course, this is the model we simulated under!). + +The plot shows a large amount of uncertainty around the estimated time-dependent hazard ratio. This is to be expected, since we only simulated a dataset of 200 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is little data (i.e. few events) with which to reliably estimate the time-dependent hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-dependent hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-dependent hazard ratio equals 1 at around ~4 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. + + +# References + +Brilleman, S. (2018) *simsurv: Simulate Survival Data.* R package version 0.2.2. \url{https://CRAN.R-project.org/package=simsurv} From fff4798c40a7f577fdd7c0018a362067418c7479 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 10:39:43 +1100 Subject: [PATCH 056/225] Small changes to stan_surv vignette --- vignettes/surv.Rmd | 63 +++++++++++++++------------------------------- 1 file changed, 20 insertions(+), 43 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 96da15ecd..6d78168a3 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -36,6 +36,7 @@ h1 { /* Header 1 */ ```{r setup_jm, include=FALSE, message=FALSE} knitr::opts_chunk$set(fig.width=10, fig.height=4) library(rstanarm) +set.seed(989898) ``` @@ -210,7 +211,7 @@ The prior distribution for the baseline hazard parameters (i.e. $\gamma$ for Wei For the exponential, Weibull, or Gompertz baseline hazards the prior distribution for the intercept parameter in the linear predictor, that is $\log \lambda$, is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. -The choice of prior distribution for the time-fixed hazard ratios $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the priors [vignette](priors.html) and the `stan_surv` help file for details. +The choice of prior distribution for the time-fixed hazard ratios $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. The B-spline coefficients related to each time-dependent effect, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. @@ -225,7 +226,6 @@ $N = 686$ patients with primary node positive breast cancer recruited between 19 First, let us load the data and fit the proportional hazards model ```{r, warning = FALSE, message = FALSE, results='hide'} -library(rstanarm) fm <- Surv(recyrs, status) ~ group mod1 <- stan_surv(fm, data = bcancer, seed = 123321) ``` @@ -240,7 +240,7 @@ print(mod1, digits = 3) We see from this output we see that individuals in the groups with `Poor` or `Medium` prognosis have much higher rates of death relative to the group with `Good` prognosis (as we might expect!). The hazard of death in the `Poor` prognosis group is approximately 4.6-fold higher than the hazard of death in the `Good` prognosis group. Similarly, the hazard of death in the `Medium` prognosis group is approximately 2.1-fold higher than the hazard of death in the `Good` prognosis group. -It may also be of interest to compare the different types of the baseline hazard we could potentially use. Here, we will fit a series of models, each with a different baseline hazard specification and then plot those baseline hazards with 95% posterior uncertainty limits +It may also be of interest to compare the different types of the baseline hazard we could potentially use. Here, we will fit a series of models, each with a different baseline hazard specification ```{r, warning = FALSE, message = FALSE, results='hide'} mod1_exp <- stan_surv(fm, data = bcancer, basehaz = "exp") @@ -252,44 +252,24 @@ mod1_mspline2 <- stan_surv(fm, data = bcancer, basehaz = "ms", basehaz_ops = list(df = 10)) ``` -```{r, echo=FALSE, fig.height=5} +and then plot the baseline hazards with 95% posterior uncertainty limits using the generic `plot` method for `stansurv` objects (note that the default `plot` for `stansurv` objects is the estimated baseline hazard). We will write a little helper function to adjust the y-axis limits, add a title, and centre the title, on each plot, as follows + +```{r, fig.height=5} library(ggplot2) -p_exp <- - plot(mod1_exp, plotfun = "basehaz") + - ggplot2::coord_cartesian(ylim = c(0,0.4)) + - ggplot2::labs(title = "Exponential") + - ggplot2::theme(plot.title = element_text(hjust = 0.5)) - -p_weibull <- - plot(mod1_weibull, plotfun = "basehaz") + - ggplot2::coord_cartesian(ylim = c(0,0.4)) + - ggplot2::labs(title = "Weibull") + - ggplot2::theme(plot.title = element_text(hjust = 0.5)) - -p_gompertz <- - plot(mod1_gompertz, plotfun = "basehaz") + - ggplot2::coord_cartesian(ylim = c(0,0.4)) + - ggplot2::labs(title = "Gompertz") + - ggplot2::theme(plot.title = element_text(hjust = 0.5)) - -p_bspline <- - plot(mod1_bspline, plotfun = "basehaz") + - ggplot2::coord_cartesian(ylim = c(0,0.4)) + - ggplot2::labs(title = "B-splines with df = 5") + - ggplot2::theme(plot.title = element_text(hjust = 0.5)) - -p_mspline1 <- - plot(mod1_mspline1, plotfun = "basehaz") + - ggplot2::coord_cartesian(ylim = c(0,0.4)) + - ggplot2::labs(title = "M-splines with df = 5") + - ggplot2::theme(plot.title = element_text(hjust = 0.5)) - -p_mspline2 <- - plot(mod1_mspline2, plotfun = "basehaz") + - ggplot2::coord_cartesian(ylim = c(0,0.4)) + - ggplot2::labs(title = "M-splines with df = 10") + - ggplot2::theme(plot.title = element_text(hjust = 0.5)) +plotfun <- function(model, title) { + plot(model, plotfun = "basehaz") + # plot baseline hazard + coord_cartesian(ylim = c(0,0.4)) + # adjust y-axis limits + labs(title = title) + # add plot title + theme(plot.title = element_text(hjust = 0.5)) # centre plot title +} + +p_exp <- plotfun(mod1_exp, title = "Exponential") +p_weibull <- plotfun(mod1_weibull, title = "Weibull") +p_gompertz <- plotfun(mod1_gompertz, title = "Gompertz") +p_bspline <- plotfun(mod1_bspline, title = "B-splines with df = 5") +p_mspline1 <- plotfun(mod1_mspline1, title = "M-splines with df = 5") +p_mspline2 <- plotfun(mod1_mspline2, title = "M-splines with df = 10") bayesplot::bayesplot_grid(p_exp, p_weibull, @@ -395,10 +375,7 @@ head(dat) Now that we have our simulated dataset, let us fit a model with time-dependent hazard ratio for `trt` ```{r, warning = FALSE, message = FALSE, results='hide'} -# define formula fm <- Surv(eventtime, status) ~ tde(trt) - -# fit Stan model with time-dependent hazard ratio mod2 <- stan_surv(formula = fm, data = dat, seed = 5544, iter = 500) ``` @@ -418,7 +395,7 @@ plot(mod2, plotfun = "tde") From the plot, we can see how the hazard ratio (i.e. the effect of treatment on the hazard of the event) changes as a function of time. The treatment appears to be protective during the first few years following baseline (i.e. HR < 1), and then the treatment appears to become harmful after about 4 years post-baseline (of course, this is the model we simulated under!). -The plot shows a large amount of uncertainty around the estimated time-dependent hazard ratio. This is to be expected, since we only simulated a dataset of 200 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is little data (i.e. few events) with which to reliably estimate the time-dependent hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-dependent hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-dependent hazard ratio equals 1 at around ~4 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. +The plot shows a large amount of uncertainty around the estimated time-dependent hazard ratio. This is to be expected, since we only simulated a dataset of 100 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-dependent hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-dependent hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-dependent hazard ratio equals 1 at around ~4 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. # References From 446be1d268d6fd139697f1eceec4b1580e76d862 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 11:24:07 +1100 Subject: [PATCH 057/225] Add a couple more useful error messages to stan_surv --- R/stan_surv.R | 30 +++++++++++++++++++++++++++--- 1 file changed, 27 insertions(+), 3 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 94d2c03fe..24da15d58 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -396,6 +396,8 @@ stan_surv <- function(formula, len_cpts <- 0L idx_cpts <- matrix(0,7,2) + if (!qnodes == 15) # warn user if qnodes is not equal to the default + warning2("There is no quadrature required so 'qnodes' is being ignored.") } #----- basis terms for baseline hazard @@ -471,7 +473,6 @@ stan_surv <- function(formula, nvars, has_intercept, has_quadrature, - qnodes, smooth_map, smooth_idx, cpts, @@ -506,6 +507,8 @@ stan_surv <- function(formula, ibasis_icenu = if (has_quadrature) matrix(0,0,nvars) else ibasis_icenu, ibasis_delay = if (has_quadrature) matrix(0,0,nvars) else ibasis_delay, + qnodes = if (!has_quadrature) 0L else qnodes, + Nevent = if (!has_quadrature) 0L else nevent, qevent = if (!has_quadrature) 0L else qevent, qlcens = if (!has_quadrature) 0L else qlcens, @@ -796,6 +799,13 @@ handle_basehaz_surv <- function(basehaz, "be used to evaluate default knot locations for splines.") tt <- times } + + if (!is.null(knots)) { + if (any(knots < min_t)) + stop2("'knots' cannot be placed before the earliest entry time.") + if (any(knots > max_t)) + stop2("'knots' cannot be placed beyond the latest event time.") + } bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) @@ -823,7 +833,14 @@ handle_basehaz_surv <- function(basehaz, "be used to evaluate default knot locations for splines.") tt <- times } - + + if (!is.null(knots)) { + if (any(knots < min_t)) + stop2("'knots' cannot be placed before the earliest entry time.") + if (any(knots > max_t)) + stop2("'knots' cannot be placed beyond the latest event time.") + } + bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) basis <- get_basis(tt, iknots = iknots, bknots = bknots, type = "ms") @@ -848,7 +865,14 @@ handle_basehaz_surv <- function(basehaz, "be used to evaluate default knot locations for piecewise basehaz.") tt <- times } - + + if (!is.null(knots)) { + if (any(knots < min_t)) + stop2("'knots' cannot be placed before the earliest entry time.") + if (any(knots > max_t)) + stop2("'knots' cannot be placed beyond the latest event time.") + } + bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) basis <- NULL # spline basis From 3d453ef253abbd2b062ea89ddac5592ae03c963d Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 11:41:18 +1100 Subject: [PATCH 058/225] Add more tests for stan_surv --- tests/testthat/test_stan_surv.R | 158 ++++++++++++++++++++------------ 1 file changed, 99 insertions(+), 59 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index e1af2a108..02ed50ef8 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -19,10 +19,9 @@ # tests can be run using devtools::test() or manually by loading testthat # package and then running the code below possibly with options(mc.cores = 4). -#library(testthat) +library(testthat) library(rstanarm) library(survival) -library(rstpm2) library(simsurv) ITER <- 1000 CHAINS <- 1 @@ -50,15 +49,16 @@ source(test_path("helpers", "recover_pars_surv.R")) eo <- function(...) { expect_output (...) } ee <- function(...) { expect_error (...) } ew <- function(...) { expect_warning(...) } +es <- function(...) { expect_stanreg(...) } up <- function(...) { update(...) } #----------------------------- Models ----------------------------------- #--- Time fixed covariates, time fixed coefficients -cov1 <- data.frame(id = 1:1000, - x1 = stats::rbinom(1000, 1, 0.5), - x2 = stats::rnorm (1000, -1, 0.5)) +cov1 <- data.frame(id = 1:50, + x1 = stats::rbinom(50, 1, 0.5), + x2 = stats::rnorm (50, -1, 0.5)) dat1 <- simsurv(lambdas = 0.1, gammas = 1.5, betas = c(x1 = -0.5, x2 = -0.3), @@ -66,73 +66,97 @@ dat1 <- simsurv(lambdas = 0.1, maxt = 5) dat1 <- merge(dat1, cov1) fm1 <- Surv(eventtime, status) ~ x1 + x2 -mod1a <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "ms") -mod1b <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "bs") -mod1c <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "exp") -mod1d <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "weibull") -mod1e <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "gompertz") +o<-SW(testmod <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 50, basehaz = "ms")) +# mod1a <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "ms") +# mod1b <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "bs") +# mod1c <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "exp") +# mod1d <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "weibull") +# mod1e <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "gompertz") -#-------------------------- Arguments ----------------------------------- -testmod <- mod1a +#-------------------------- Arguments ----------------------------------- test_that("prior_PD argument works", { - eo(update(testmod, prior_PD = TRUE)) + es(up(testmod, prior_PD = TRUE)) }) test_that("adapt_delta argument works", { - eo(up(testmod, adapt_delta = NULL)) - eo(up(testmod, adapt_delta = 0.8)) - eo(up(testmod, control = list(adapt_delta = NULL))) - eo(up(testmod, control = list(adapt_delta = 0.8))) + es(up(testmod, adapt_delta = NULL)) + es(up(testmod, adapt_delta = 0.8)) + es(up(testmod, control = list(adapt_delta = NULL))) + es(up(testmod, control = list(adapt_delta = 0.8))) }) test_that("init argument works", { - eo(up(testmod, init = "prefit")) - eo(up(testmod, init = "0")) - eo(up(testmod, init = 0)) - eo(up(testmod, init = "random")) + es(up(testmod, init = "prefit")) + es(up(testmod, init = "0")) + es(up(testmod, init = 0)) + es(up(testmod, init = "random")) }) test_that("qnodes argument works", { - eo(up(testmod, qnodes = 7)) - eo(up(testmod, qnodes = 11)) - eo(up(testmod, qnodes = 15)) - ee(up(testmod, qnodes = 1), "must be either 7, 11 or 15") - ee(up(testmod, qnodes = c(1,2)), "numeric vector of length 1") - ee(up(testmod, qnodes = "wrong"), "numeric vector of length 1") + es(up(testmod, qnodes = 7, basehaz = "bs")) + es(up(testmod, qnodes = 11, basehaz = "bs")) + es(up(testmod, qnodes = 15, basehaz = "bs")) + + ew(up(testmod, qnodes = 1), "is being ignored") + ew(up(testmod, qnodes = c(1,2)), "is being ignored") + ew(up(testmod, qnodes = "wrong"), "is being ignored") + + ee(up(testmod, qnodes = 1, basehaz = "bs"), "7, 11 or 15") + ee(up(testmod, qnodes = c(1,2), basehaz = "bs"), "numeric vector of length 1") + ee(up(testmod, qnodes = "wrong", basehaz = "bs"), "numeric vector of length 1") }) test_that("basehaz argument works", { - eo(up(testmod, basehaz = "exp")) - eo(up(testmod, basehaz = "weibull")) - eo(up(testmod, basehaz = "gompertz")) - eo(up(testmod, basehaz = "ms")) - eo(up(testmod, basehaz = "bs")) - eo(up(testmod, basehaz = "piecewise")) + es(up(testmod, basehaz = "exp")) + es(up(testmod, basehaz = "weibull")) + es(up(testmod, basehaz = "gompertz")) + es(up(testmod, basehaz = "ms")) + es(up(testmod, basehaz = "bs")) dfl <- list(df = 5) knl <- list(knots = c(1,3,5)) - eo(up(testmod, basehaz = "ms", basehaz_ops = dfl)) - eo(up(testmod, basehaz = "ms", basehaz_ops = knl)) - eo(up(testmod, basehaz = "bs", basehaz_ops = dfl)) - eo(up(testmod, basehaz = "bs", basehaz_ops = knl)) - eo(up(testmod, basehaz = "piecewise", basehaz_ops = dfl)) - eo(up(testmod, basehaz = "piecewise", basehaz_ops = knl)) - - eo(ew(up(testmod, basehaz = "exp", basehaz_ops = dfl), "'df' will be ignored")) - eo(ew(up(testmod, basehaz = "exp", basehaz_ops = knl), "'knots' will be ignored")) - eo(ew(up(testmod, basehaz = "weibull", basehaz_ops = dfl), "'df' will be ignored")) - eo(ew(up(testmod, basehaz = "weibull", basehaz_ops = knl), "'knots' will be ignored")) - eo(ew(up(testmod, basehaz = "gompertz",basehaz_ops = dfl), "'df' will be ignored")) - eo(ew(up(testmod, basehaz = "gompertz",basehaz_ops = knl), "'knots' will be ignored")) - - ee(up(testmod, basehaz_ops = list(df = 1)), "must be at least 3") - ee(up(testmod, basehaz_ops = list(knots = -1)), "'knots' must be non-negative") - ee(up(testmod, basehaz_ops = list(knots = c(1,2,50))), "cannot be greater than the largest event time") + es(up(testmod, basehaz = "ms", basehaz_ops = dfl)) + es(up(testmod, basehaz = "ms", basehaz_ops = knl)) + es(up(testmod, basehaz = "bs", basehaz_ops = dfl)) + es(up(testmod, basehaz = "bs", basehaz_ops = knl)) + + ee(up(testmod, basehaz_ops = list(junk = 3)), "can only include") + + ee(up(testmod, basehaz_ops = list(df = 1)), "cannot be negative") + ee(up(testmod, basehaz_ops = list(knots = -1)), "earliest entry time") + ee(up(testmod, basehaz_ops = list(knots = c(1,2,50))), "latest event time") + +}) +test_that("prior arguments work", { + es(up(testmod, prior = normal())) + es(up(testmod, prior = student_t())) + es(up(testmod, prior = cauchy())) + es(up(testmod, prior = hs())) + es(up(testmod, prior = hs_plus())) + es(up(testmod, prior = lasso())) + es(up(testmod, prior = laplace())) + + es(up(testmod, prior_intercept = normal())) + es(up(testmod, prior_intercept = student_t())) + es(up(testmod, prior_intercept = cauchy())) + + es(up(testmod, prior_aux = normal())) + es(up(testmod, prior_aux = student_t())) + es(up(testmod, prior_aux = cauchy())) + + es(up(testmod, prior_smooth = exponential())) + es(up(testmod, prior_smooth = normal())) + es(up(testmod, prior_smooth = student_t())) + es(up(testmod, prior_smooth = cauchy())) + + ee(up(testmod, prior_intercept = lasso()), "prior distribution") + ee(up(testmod, prior_aux = lasso()), "prior distribution") + ee(up(testmod, prior_smooth = lasso()), "prior distribution") }) @@ -158,7 +182,22 @@ test_that("basehaz argument works", { tol = tols$fixef[[i]], info = basehaz) } - + + #---- weibull data + + set.seed(543634) + covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) + dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) + dat <- merge(dat, covs) + + compare_surv(data = dat, basehaz = "exp") + #---- weibull data set.seed(543634) @@ -174,7 +213,8 @@ test_that("basehaz argument works", { compare_surv(data = dat, basehaz = "weibull") compare_surv(data = dat, basehaz = "ms") - + compare_surv(data = dat, basehaz = "bs") + #---- gompertz data set.seed(45357) @@ -189,7 +229,6 @@ test_that("basehaz argument works", { dat <- merge(dat, covs) compare_surv(data = dat, basehaz = "gompertz") - compare_surv(data = dat, basehaz = "ms") #-------- Check post-estimation functions work @@ -224,14 +263,14 @@ test_that("basehaz argument works", { # interval censoring o<-SW(f13 <- update(f1, Surv(l, u, type = "interval2") ~ grp, data = mice)) - o<-SW(f14 <- update(f1, Surv(l, u, type = "interval2") ~ tde(grp), data = mice)) + #o<-SW(f14 <- update(f1, Surv(l, u, type = "interval2") ~ tde(grp), data = mice)) # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models - for (j in c(1:10)) { + for (j in c(1:13)) { mod <- try(get(paste0("f", j)), silent = TRUE) @@ -262,10 +301,11 @@ test_that("basehaz argument works", { expect_equivalent_loo(mod) }) - test_that("posterior_survfit works with estimation data", { - SW(ps <- posterior_survfit(mod)) - expect_survfit(ps) - }) + if (mod$ndelayed == 0) # only test if no delayed entry + test_that("posterior_survfit works with estimation data", { + SW(ps <- posterior_survfit(mod)) + expect_survfit(ps) + }) test_that("posterior_survfit works with new data (one individual)", { SW(ps <- posterior_survfit(mod, newdata = nd1)) From 9ee4c3d7cfa8b33967b019af9a78d5575a8e1786 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 14:20:15 +1100 Subject: [PATCH 059/225] Don't check_constant_vars for Surv objects --- R/misc.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/misc.R b/R/misc.R index 7f6ed6d3d..92b64fdc8 100644 --- a/R/misc.R +++ b/R/misc.R @@ -364,8 +364,9 @@ validate_glm_formula <- function(f) { # @return If no constant variables are found mf is returned, otherwise an error # is thrown. check_constant_vars <- function(mf) { - # don't check if columns are constant for binomial - mf1 <- if (NCOL(mf[, 1]) == 2) mf[, -1, drop=FALSE] else mf + # don't check if columns are constant for binomial or Surv object + mf1 <- if (NCOL(mf[, 1]) == 2 || survival::is.Surv(mf[, 1])) + mf[, -1, drop=FALSE] else mf lu1 <- function(x) !all(x == 1) && length(unique(x)) == 1 nocheck <- c("(weights)", "(offset)", "(Intercept)") From c82e68354272ba5b958a762d7c9e991797e71695 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 14:20:44 +1100 Subject: [PATCH 060/225] stan_surv tests: use PBC data for interval censoring test --- tests/testthat/test_stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 02ed50ef8..57f38a865 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -262,8 +262,8 @@ test_that("prior arguments work", { o<-SW(f12 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) # interval censoring - o<-SW(f13 <- update(f1, Surv(l, u, type = "interval2") ~ grp, data = mice)) - #o<-SW(f14 <- update(f1, Surv(l, u, type = "interval2") ~ tde(grp), data = mice)) + o<-SW(f13 <- update(f1, Surv(t0, futimeYears, type = "interval2") ~ sex + trt)) + #o<-SW(f14 <- update(f1, Surv(t0, futimeYears, type = "interval2") ~ sex + tde(trt))) # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] From af029d317bf9a16c27aa459e5c522b5fdfa4d8df Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 16:31:18 +1100 Subject: [PATCH 061/225] Add stan_surv test for interval censoring --- DESCRIPTION | 1 + tests/testthat/test_stan_surv.R | 39 +++++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index c0e226f57..6278c0648 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -54,6 +54,7 @@ Suggests: digest, gridExtra, HSAUR3, + icenReg (> 2.0.8), knitr (>= 1.15.1), MASS, mgcv (>= 1.8-13), diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 57f38a865..27a9474f6 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -231,6 +231,45 @@ test_that("prior arguments work", { compare_surv(data = dat, basehaz = "gompertz") +#---- Compare parameter estimates: stan_surv vs icenReg + + #---- interval censored weibull data + + library(icenReg) + set.seed(321) + sim_data <- simIC_weib(n = 5000, + b1 = 0.3, + b2 = -0.3, + model = 'ph', + shape = 2, + scale = 2, + inspections = 6, + inspectLength = 1) + fm <- Surv(l, u, type = 'interval2') ~ x1 + x2 + ic_icen <- ic_par(fm, data = sim_data) + ic_stan <- stan_surv(fm, data = sim_data, basehaz = "weibull") + truepars <- c('x1' = 0.3, 'x2' = -0.3, 'weibull-shape' = 2) + stanpars <- fixef(ic_stan) + ll_icen <- ic_icen$llk + ll_stan <- mean(rowSums(log_lik(ic_stan))) + expect_equal(stanpars[['x1']], + truepars[['x1']], + tol = 0.01, + info = "compare estimates (x1) with icenReg") + expect_equal(stanpars[['x2']], + truepars[['x2']], + tol = 0.01, + info = "compare estimates (x2) with icenReg") + expect_equal(stanpars[['weibull-shape']], + truepars[['weibull-shape']], + tol = 0.1, + info = "compare estimates (weibull-shape) with icenReg") + expect_equal(ll_icen, + ll_stan, + tol = 5, + info = "compare log lik with icenReg") + + #-------- Check post-estimation functions work pbcSurv$t0 <- 0 From b1650fae86e8cdad4a1f8c1e07ef7342312d41c2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 17:28:19 +1100 Subject: [PATCH 062/225] stan_surv: disallow event or censoring times equal to zero This avoids a degenerate estimate of the log hazard for some distributions, caused by the evaluation of log(0) --- R/stan_surv.R | 7 +++++++ tests/testthat/test_stan_surv.R | 1 + 2 files changed, 8 insertions(+) diff --git a/R/stan_surv.R b/R/stan_surv.R index 24da15d58..293725bb9 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -297,6 +297,13 @@ stan_surv <- function(formula, t_end <- make_t(mf, type = "end") # exit time t_upp <- make_t(mf, type = "upp") # upper time for interval censoring + # ensure no event or censoring times are zero (leads to degenerate + # estimate for log hazard for most baseline hazards, due to log(0)) + check1 <- any(t_end <= 0, na.rm = TRUE) + check2 <- any(t_upp <= 0, na.rm = TRUE) + if (check1 || check2) + stop2("All event and censoring times must be greater than 0.") + # event indicator for each row of data status <- make_d(mf) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 27a9474f6..43441654b 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -245,6 +245,7 @@ test_that("prior arguments work", { scale = 2, inspections = 6, inspectLength = 1) + sim_data$l[sim_data$l == 0] <- -Inf # left limit = 0 is actually left censoring fm <- Surv(l, u, type = 'interval2') ~ x1 + x2 ic_icen <- ic_par(fm, data = sim_data) ic_stan <- stan_surv(fm, data = sim_data, basehaz = "weibull") From e71a1e63a06650871a705cb4fd99680d37c6adaa Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 18:29:43 +1100 Subject: [PATCH 063/225] Add more stan_surv tests --- tests/testthat/test_stan_surv.R | 97 +++++++++++++++++++++++++++------ 1 file changed, 79 insertions(+), 18 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 43441654b..e81f4200c 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -169,8 +169,8 @@ test_that("prior arguments work", { stan1 <- stan_surv(formula = fm, data = data, basehaz = basehaz, - iter = 1000, - refresh = 0L, + iter = ITER, + refresh = REFRESH, chains = CHAINS, seed = SEED, ...) tols <- get_tols(surv1, tolscales = TOLSCALES) @@ -231,12 +231,13 @@ test_that("prior arguments work", { compare_surv(data = dat, basehaz = "gompertz") -#---- Compare parameter estimates: stan_surv vs icenReg +#---- Compare parameter estimates: stan_surv vs icenReg (interval censored) - #---- interval censored weibull data + #---- simulated interval censored weibull data - library(icenReg) - set.seed(321) + library(icenReg); set.seed(321) + + # simulate interval censored data sim_data <- simIC_weib(n = 5000, b1 = 0.3, b2 = -0.3, @@ -245,14 +246,23 @@ test_that("prior arguments work", { scale = 2, inspections = 6, inspectLength = 1) - sim_data$l[sim_data$l == 0] <- -Inf # left limit = 0 is actually left censoring + + # lower limit = 0 is actually left censoring (stan_surv doesn't accept 0's) + sim_data$l[sim_data$l == 0] <- -Inf + + # fit stan model to interval censored data fm <- Surv(l, u, type = 'interval2') ~ x1 + x2 - ic_icen <- ic_par(fm, data = sim_data) - ic_stan <- stan_surv(fm, data = sim_data, basehaz = "weibull") + ic_stan <- stan_surv(fm, + data = sim_data, + basehaz = "weibull", + iter = ITER, + refresh = REFRESH, + chains = CHAINS, + seed = SEED) + + # compare stan estimates to known values from data generating model truepars <- c('x1' = 0.3, 'x2' = -0.3, 'weibull-shape' = 2) stanpars <- fixef(ic_stan) - ll_icen <- ic_icen$llk - ll_stan <- mean(rowSums(log_lik(ic_stan))) expect_equal(stanpars[['x1']], truepars[['x1']], tol = 0.01, @@ -265,26 +275,77 @@ test_that("prior arguments work", { truepars[['weibull-shape']], tol = 0.1, info = "compare estimates (weibull-shape) with icenReg") + + # fit model using icenReg package & compare log_lik with stan model + ic_icen <- ic_par(fm, data = sim_data) + ll_icen <- ic_icen$llk + ll_stan <- mean(rowSums(log_lik(ic_stan))) expect_equal(ll_icen, ll_stan, tol = 5, info = "compare log lik with icenReg") + + +#---- Compare parameter estimates: stan_surv vs phreg (tvc & delayed entry) + + #---- mortality data: contains a time-varying covariate + + library(eha); library(dplyr); set.seed(987) + # add a time-fixed covariate to the mortality data + data(mort); mort <- mort %>% group_by(id) %>% mutate(sesfixed = ses[[1]]) + # fit models using the time-fixed covariate & compare HR estimates + fm <- Surv(enter, exit, event) ~ sesfixed + f_weib <- phreg(fm, data = mort) + f_stan <- stan_surv(fm, + data = mort, + basehaz = "weibull", + iter = ITER, + refresh = REFRESH, + chains = CHAINS, + seed = SEED) + expect_equal(coef(f_weib)['sesfixedupper'], + coef(f_stan)['sesfixedupper'], + tol = 0.01) + + # fit models using the time-varying covariate & compare HR estimates + fm <- Surv(enter, exit, event) ~ ses + v_weib <- phreg(fm, data = mort) + v_stan <- stan_surv(fm, + data = mort, + basehaz = "weibull", + iter = ITER, + refresh = REFRESH, + chains = CHAINS, + seed = SEED) + expect_equal(coef(v_weib)['sesupper'], + coef(v_stan)['sesupper'], + tol = 0.01) + + # stupidity check; to make sure the hazard ratios actually differed + # between the models with the time-fixed and time-varying covariate + expect_error(expect_equal(coef(f_weib)['sesfixedupper'][[1]], + coef(v_weib)['sesupper'][[1]], + tol = 0.1), "not equal") + + #-------- Check post-estimation functions work pbcSurv$t0 <- 0 pbcSurv$t0[pbcSurv$futimeYears > 2] <- 1 # delayed entry + pbcSurv$t1 <- pbcSurv$futimeYears - 1 # lower limit for interval censoring + pbcSurv$t1[pbcSurv$t1 <= 0] <- -Inf # left censoring + # different baseline hazards o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, data = pbcSurv, basehaz = "ms", chains = 1, - cores = 1, iter = 40, - refresh = 0, - seed = 12345)) + refresh = REFRESH, + seed = SEED)) o<-SW(f2 <- update(f1, basehaz = "bs")) o<-SW(f3 <- update(f1, basehaz = "exp")) o<-SW(f4 <- update(f1, basehaz = "weibull")) @@ -301,16 +362,16 @@ test_that("prior arguments work", { o<-SW(f11 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) o<-SW(f12 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) - # interval censoring - o<-SW(f13 <- update(f1, Surv(t0, futimeYears, type = "interval2") ~ sex + trt)) - #o<-SW(f14 <- update(f1, Surv(t0, futimeYears, type = "interval2") ~ sex + tde(trt))) + # left and interval censoring + o<-SW(f13 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) + o<-SW(f14 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models - for (j in c(1:13)) { + for (j in c(1:14)) { mod <- try(get(paste0("f", j)), silent = TRUE) From b84c760fafed4e35fe64423f6281a4387abbbfde Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 18:40:42 +1100 Subject: [PATCH 064/225] Improve generalisability of the subset_ids function --- R/misc.R | 19 ++++++++++++------- R/posterior_traj.R | 4 ++-- R/pp_data.R | 4 ++-- 3 files changed, 16 insertions(+), 11 deletions(-) diff --git a/R/misc.R b/R/misc.R index 92b64fdc8..76cf18fa8 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1353,19 +1353,23 @@ validate_newdatas <- function(object, newdataLong = NULL, newdataEvent = NULL, # Return data frames only including the specified subset of individuals # -# @param object A stanmvreg object # @param data A data frame, or a list of data frames # @param ids A vector of ids indicating which individuals to keep +# @param id_var Character string, the name of the ID variable # @return A data frame, or a list of data frames, depending on the input -subset_ids <- function(object, data, ids) { +subset_ids <- function(data, ids, id_var) { + if (is.null(data)) return(NULL) - validate_stanmvreg_object(object) - id_var <- object$id_var + is_list <- is(data, "list") - if (!is_list) data <- list(data) - is_df <- sapply(data, is.data.frame) - if (!all(is_df)) stop("'data' should be a data frame, or list of data frames.") + if (!is_list) + data <- list(data) # convert to list + + is_df <- sapply(data, inherits, "data.frame") + if (!all(is_df)) + stop("'data' should be a data frame, or list of data frames.") + data <- lapply(data, function(x) { if (!id_var %in% colnames(x)) STOP_no_var(id_var) sel <- which(!ids %in% x[[id_var]]) @@ -1374,6 +1378,7 @@ subset_ids <- function(object, data, ids) { paste(ids[[sel]], collapse = ", ")) x[x[[id_var]] %in% ids, , drop = FALSE] }) + if (is_list) return(data) else return(data[[1]]) } diff --git a/R/posterior_traj.R b/R/posterior_traj.R index 71f59c21c..9555dc8c3 100644 --- a/R/posterior_traj.R +++ b/R/posterior_traj.R @@ -316,8 +316,8 @@ posterior_traj <- function(object, m = 1, newdata = NULL, newdataLong = NULL, ndE <- dats[["Event"]] } if (!is.null(ids)) { # user specified a subset of ids - ndL <- subset_ids(object, ndL, ids) - ndE <- subset_ids(object, ndE, ids) + ndL <- subset_ids(ndL, ids, id_var) + ndE <- subset_ids(ndE, ids, id_var) } id_list <- factor(unique(ndL[[m]][[id_var]])) # order of ids from data, not ids arg diff --git a/R/pp_data.R b/R/pp_data.R index a07115c63..6290e975f 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -378,8 +378,8 @@ pp_data <- # possibly subset if (!is.null(ids)) { - ndL <- subset_ids(object, ndL, ids) - ndE <- subset_ids(object, ndE, ids) + ndL <- subset_ids(ndL, ids, id_var) + ndE <- subset_ids(ndE, ids, id_var) } id_list <- unique(ndE[[id_var]]) # unique subject id list From c3d8661832ee5281228dca3916748208bd1cfc79 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 18:41:38 +1100 Subject: [PATCH 065/225] Clean up plot.survfit function This is so that the plot method can be used with cumulative hazard, hazard, etc. rather than just survival functions. --- R/posterior_survfit.R | 89 ++++++++++++++++++++++--------------------- 1 file changed, 46 insertions(+), 43 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 59a416ca8..75cf86434 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -535,8 +535,8 @@ posterior_survfit.stanjm <- function(object, ndE <- newdatas[["Event"]] } if (!is.null(ids)) { # user specified a subset of ids - ndL <- subset_ids(object, ndL, ids) - ndE <- subset_ids(object, ndE, ids) + ndL <- subset_ids(ndL, ids, id_var) + ndE <- subset_ids(ndE, ids, id_var) } id_list <- factor(unique(ndE[[id_var]])) # order of ids from data, not ids arg @@ -1102,29 +1102,30 @@ print.survfit.stanjm <- function(x, digits = 4, ...) { #' plot(ps2) #' } #' -plot.survfit.stanjm <- function(x, ids = NULL, +plot.survfit.stanjm <- function(x, + ids = NULL, limits = c("ci", "none"), - xlab = NULL, ylab = NULL, facet_scales = "free", + xlab = NULL, + ylab = NULL, + facet_scales = "free", ci_geom_args = NULL, ...) { - limits <- match.arg(limits) - ci <- (limits == "ci") + limits <- match.arg (limits) + ci <- as.logical(limits == "ci") + + type <- attr(x, "type") standardise <- attr(x, "standardise") - id_var <- attr(x, "id_var") - time_var <- attr(x, "time_var") + id_var <- attr(x, "id_var") + time_var <- attr(x, "time_var") + if (is.null(xlab)) xlab <- paste0("Time (", time_var, ")") - if (is.null(ylab)) ylab <- "Event free probability" + if (is.null(ylab)) ylab <- get_survpred_name(type) + if (!is.null(ids)) { if (standardise) stop("'ids' argument cannot be specified when plotting standardised ", "survival probabilities.") - if (!id_var %in% colnames(x)) - stop("Bug found: could not find 'id_var' column in the data frame.") - ids_missing <- which(!ids %in% x[[id_var]]) - if (length(ids_missing)) - stop("The following 'ids' are not present in the survfit.stanjm object: ", - paste(ids[[ids_missing]], collapse = ", "), call. = FALSE) - x <- x[(x[[id_var]] %in% ids), , drop = FALSE] + x <- subset_ids(x, ids, id_var) } else { ids <- if (!standardise) attr(x, "ids") else NULL } @@ -1132,39 +1133,41 @@ plot.survfit.stanjm <- function(x, ids = NULL, x$time <- x[[time_var]] geom_defaults <- list(color = "black") - geom_args <- set_geom_args(geom_defaults, ...) + geom_mapp <- list(mapping = aes_string(x = "time", y = "median")) + geom_args <- do.call("set_geom_args", + c(defaults = list(geom_defaults), list(...))) - lim_defaults <- list(alpha = 0.3) - lim_args <- do.call("set_geom_args", c(defaults = list(lim_defaults), ci_geom_args)) + lim_defaults <- list(alpha = 0.3) + lim_mapp <- list(mapping = aes_string(ymin = "ci_lb", ymax = "ci_ub")) + lim_args <- do.call("set_geom_args", + c(defaults = list(lim_defaults), ci_geom_args)) - if ((!standardise) && (length(ids) > 60L)) { + if ((!standardise) && (length(ids) > 60L)) stop("Too many individuals to plot for. Perhaps consider limiting ", "the number of individuals by specifying the 'ids' argument.") - } else if ((!standardise) && (length(ids) > 1L)) { - graph <- ggplot(x, aes_string(x = "time", y = "median")) + - theme_bw() + - do.call("geom_line", geom_args) + - coord_cartesian(ylim = c(0, 1)) + + + graph_base <- + ggplot(x) + + theme_bw() + + coord_cartesian(ylim = get_survpred_ylim(type)) + + do.call("geom_line", c(geom_mapp, geom_args)) + + graph_facet <- + if ((!standardise) && (length(ids) > 1L)) { facet_wrap(~ id, scales = facet_scales) + } else NULL + + graph_limits <- if (ci) { - lim_mapp <- list(mapping = aes_string(ymin = "ci_lb", ymax = "ci_ub")) - graph_limits <- do.call("geom_ribbon", c(lim_mapp, lim_args)) - } else graph_limits <- NULL - } else { - graph <- ggplot(x, aes_string(x = "time", y = "median")) + - theme_bw() + - do.call("geom_line", geom_args) + - coord_cartesian(ylim = c(0, 1)) - if (ci) { - lim_mapp <- list(mapping = aes_string(ymin = "ci_lb", ymax = "ci_ub")) - graph_limits <- do.call("geom_ribbon", c(lim_mapp, lim_args)) - } else graph_limits <- NULL - } - - ret <- graph + graph_limits + labs(x = xlab, y = ylab) - class_ret <- class(ret) - class(ret) <- c("plot.survfit.stanjm", class_ret) - ret + do.call("geom_ribbon", c(lim_mapp, lim_args)) + } else NULL + + graph_labels <- labs(x = xlab, y = ylab) + + gg <- graph + graph_facet + graph_limits + graph_labels + class_gg <- class(gg) + class(gg) <- c("plot.survfit.stanjm", class_gg) + gg } From 5135e6039f4b923ed162394815c86c3c83c2b725 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 18:42:28 +1100 Subject: [PATCH 066/225] Remove icenReg from Suggests --- DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6278c0648..c0e226f57 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -54,7 +54,6 @@ Suggests: digest, gridExtra, HSAUR3, - icenReg (> 2.0.8), knitr (>= 1.15.1), MASS, mgcv (>= 1.8-13), From 57838b3c98793a54cd6a18e134154432e2bbf4a3 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 18:50:49 +1100 Subject: [PATCH 067/225] Fix up plot.survfit --- R/posterior_survfit.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 75cf86434..f491baa46 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -1133,12 +1133,15 @@ plot.survfit.stanjm <- function(x, x$time <- x[[time_var]] geom_defaults <- list(color = "black") - geom_mapp <- list(mapping = aes_string(x = "time", y = "median")) + geom_mapp <- list(mapping = aes_string(x = "time", + y = "median")) geom_args <- do.call("set_geom_args", c(defaults = list(geom_defaults), list(...))) lim_defaults <- list(alpha = 0.3) - lim_mapp <- list(mapping = aes_string(ymin = "ci_lb", ymax = "ci_ub")) + lim_mapp <- list(mapping = aes_string(x = "time", + ymin = "ci_lb", + ymax = "ci_ub")) lim_args <- do.call("set_geom_args", c(defaults = list(lim_defaults), ci_geom_args)) @@ -1164,7 +1167,7 @@ plot.survfit.stanjm <- function(x, graph_labels <- labs(x = xlab, y = ylab) - gg <- graph + graph_facet + graph_limits + graph_labels + gg <- graph_base + graph_facet + graph_limits + graph_labels class_gg <- class(gg) class(gg) <- c("plot.survfit.stanjm", class_gg) gg From 639e5256e549831aab5b2822ca7c32f0fbd47bdb Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 31 Oct 2018 18:52:17 +1100 Subject: [PATCH 068/225] Comment out stan_surv tests to avoid adding packages to Suggests --- tests/testthat/test_stan_surv.R | 194 ++++++++++++++++---------------- 1 file changed, 97 insertions(+), 97 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index e81f4200c..34bf5a6cd 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -231,103 +231,103 @@ test_that("prior arguments work", { compare_surv(data = dat, basehaz = "gompertz") -#---- Compare parameter estimates: stan_surv vs icenReg (interval censored) - - #---- simulated interval censored weibull data - - library(icenReg); set.seed(321) - - # simulate interval censored data - sim_data <- simIC_weib(n = 5000, - b1 = 0.3, - b2 = -0.3, - model = 'ph', - shape = 2, - scale = 2, - inspections = 6, - inspectLength = 1) - - # lower limit = 0 is actually left censoring (stan_surv doesn't accept 0's) - sim_data$l[sim_data$l == 0] <- -Inf - - # fit stan model to interval censored data - fm <- Surv(l, u, type = 'interval2') ~ x1 + x2 - ic_stan <- stan_surv(fm, - data = sim_data, - basehaz = "weibull", - iter = ITER, - refresh = REFRESH, - chains = CHAINS, - seed = SEED) - - # compare stan estimates to known values from data generating model - truepars <- c('x1' = 0.3, 'x2' = -0.3, 'weibull-shape' = 2) - stanpars <- fixef(ic_stan) - expect_equal(stanpars[['x1']], - truepars[['x1']], - tol = 0.01, - info = "compare estimates (x1) with icenReg") - expect_equal(stanpars[['x2']], - truepars[['x2']], - tol = 0.01, - info = "compare estimates (x2) with icenReg") - expect_equal(stanpars[['weibull-shape']], - truepars[['weibull-shape']], - tol = 0.1, - info = "compare estimates (weibull-shape) with icenReg") - - # fit model using icenReg package & compare log_lik with stan model - ic_icen <- ic_par(fm, data = sim_data) - ll_icen <- ic_icen$llk - ll_stan <- mean(rowSums(log_lik(ic_stan))) - expect_equal(ll_icen, - ll_stan, - tol = 5, - info = "compare log lik with icenReg") - - -#---- Compare parameter estimates: stan_surv vs phreg (tvc & delayed entry) - - #---- mortality data: contains a time-varying covariate - - library(eha); library(dplyr); set.seed(987) - - # add a time-fixed covariate to the mortality data - data(mort); mort <- mort %>% group_by(id) %>% mutate(sesfixed = ses[[1]]) - - # fit models using the time-fixed covariate & compare HR estimates - fm <- Surv(enter, exit, event) ~ sesfixed - f_weib <- phreg(fm, data = mort) - f_stan <- stan_surv(fm, - data = mort, - basehaz = "weibull", - iter = ITER, - refresh = REFRESH, - chains = CHAINS, - seed = SEED) - expect_equal(coef(f_weib)['sesfixedupper'], - coef(f_stan)['sesfixedupper'], - tol = 0.01) - - # fit models using the time-varying covariate & compare HR estimates - fm <- Surv(enter, exit, event) ~ ses - v_weib <- phreg(fm, data = mort) - v_stan <- stan_surv(fm, - data = mort, - basehaz = "weibull", - iter = ITER, - refresh = REFRESH, - chains = CHAINS, - seed = SEED) - expect_equal(coef(v_weib)['sesupper'], - coef(v_stan)['sesupper'], - tol = 0.01) - - # stupidity check; to make sure the hazard ratios actually differed - # between the models with the time-fixed and time-varying covariate - expect_error(expect_equal(coef(f_weib)['sesfixedupper'][[1]], - coef(v_weib)['sesupper'][[1]], - tol = 0.1), "not equal") +# #---- Compare parameter estimates: stan_surv vs icenReg (interval censored) +# +# #---- simulated interval censored weibull data +# +# library(icenReg); set.seed(321) +# +# # simulate interval censored data +# sim_data <- simIC_weib(n = 5000, +# b1 = 0.3, +# b2 = -0.3, +# model = 'ph', +# shape = 2, +# scale = 2, +# inspections = 6, +# inspectLength = 1) +# +# # lower limit = 0 is actually left censoring (stan_surv doesn't accept 0's) +# sim_data$l[sim_data$l == 0] <- -Inf +# +# # fit stan model to interval censored data +# fm <- Surv(l, u, type = 'interval2') ~ x1 + x2 +# ic_stan <- stan_surv(fm, +# data = sim_data, +# basehaz = "weibull", +# iter = ITER, +# refresh = REFRESH, +# chains = CHAINS, +# seed = SEED) +# +# # compare stan estimates to known values from data generating model +# truepars <- c('x1' = 0.3, 'x2' = -0.3, 'weibull-shape' = 2) +# stanpars <- fixef(ic_stan) +# expect_equal(stanpars[['x1']], +# truepars[['x1']], +# tol = 0.01, +# info = "compare estimates (x1) with icenReg") +# expect_equal(stanpars[['x2']], +# truepars[['x2']], +# tol = 0.01, +# info = "compare estimates (x2) with icenReg") +# expect_equal(stanpars[['weibull-shape']], +# truepars[['weibull-shape']], +# tol = 0.1, +# info = "compare estimates (weibull-shape) with icenReg") +# +# # fit model using icenReg package & compare log_lik with stan model +# ic_icen <- ic_par(fm, data = sim_data) +# ll_icen <- ic_icen$llk +# ll_stan <- mean(rowSums(log_lik(ic_stan))) +# expect_equal(ll_icen, +# ll_stan, +# tol = 5, +# info = "compare log lik with icenReg") +# +# +# #---- Compare parameter estimates: stan_surv vs phreg (tvc & delayed entry) +# +# #---- mortality data: contains a time-varying covariate +# +# library(eha); library(dplyr); set.seed(987) +# +# # add a time-fixed covariate to the mortality data +# data(mort); mort <- mort %>% group_by(id) %>% mutate(sesfixed = ses[[1]]) +# +# # fit models using the time-fixed covariate & compare HR estimates +# fm <- Surv(enter, exit, event) ~ sesfixed +# f_weib <- phreg(fm, data = mort) +# f_stan <- stan_surv(fm, +# data = mort, +# basehaz = "weibull", +# iter = ITER, +# refresh = REFRESH, +# chains = CHAINS, +# seed = SEED) +# expect_equal(coef(f_weib)['sesfixedupper'], +# coef(f_stan)['sesfixedupper'], +# tol = 0.01) +# +# # fit models using the time-varying covariate & compare HR estimates +# fm <- Surv(enter, exit, event) ~ ses +# v_weib <- phreg(fm, data = mort) +# v_stan <- stan_surv(fm, +# data = mort, +# basehaz = "weibull", +# iter = ITER, +# refresh = REFRESH, +# chains = CHAINS, +# seed = SEED) +# expect_equal(coef(v_weib)['sesupper'], +# coef(v_stan)['sesupper'], +# tol = 0.01) +# +# # stupidity check; to make sure the hazard ratios actually differed +# # between the models with the time-fixed and time-varying covariate +# expect_error(expect_equal(coef(f_weib)['sesfixedupper'][[1]], +# coef(v_weib)['sesupper'][[1]], +# tol = 0.1), "not equal") #-------- Check post-estimation functions work From e577c4aec9215b0f94cea8e891c930a9824eb7eb Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 11:00:37 +1100 Subject: [PATCH 069/225] Update rename_e_aux function --- R/jm_data_block.R | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 811d00751..ae708cf0f 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -522,9 +522,13 @@ summarize_jm_prior <- # @param basehaz A list with information about the baseline hazard .rename_e_aux <- function(basehaz) { nm <- basehaz$type_name - if (nm == "weibull") "weibull-shape" else - if (nm == "bs") "spline-coefficients" else - if (nm == "piecewise") "piecewise-coefficients" else NA + switch(nm, + weibull = "weibull-shape", + gompertz = "gompertz-scale", + bs = "B-spline-coefficients", + ms = "M-spline-coefficients", + piecewise = "piecewise-coefficients", + NA) } # Check if priors were autoscaled From 786840cea232c7da3a37e55a344c6be4b9d41365 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 11:32:51 +1100 Subject: [PATCH 070/225] Tidy up priors documentation for stan_surv --- R/prior_summary.R | 3 ++- R/stan_surv.R | 48 ++++++++++++++++++++++++++++++----------------- 2 files changed, 33 insertions(+), 18 deletions(-) diff --git a/R/prior_summary.R b/R/prior_summary.R index d75dc5d66..49cd8096f 100644 --- a/R/prior_summary.R +++ b/R/prior_summary.R @@ -25,7 +25,8 @@ #' correspond to the intercept with the predictors as specified by the user #' (unmodified by \pkg{rstanarm}), but when \emph{specifying} the prior the #' intercept can be thought of as the expected outcome when the predictors are -#' set to their means. The only exception to this is for models fit with the +#' set to their means. The only exceptions to this are for models fit using +#' the \code{stan_surv} modelling function, or models fit with the #' \code{sparse} argument set to \code{TRUE} (which is only possible with a #' subset of the modeling functions and never the default). #' diff --git a/R/stan_surv.R b/R/stan_surv.R index 293725bb9..c10164ac9 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -78,30 +78,46 @@ #' \item \code{"weibull"}: a Weibull distribution for the event times. #' \item \code{"gompertz"}: a Gompertz distribution for the event times. #' } -#' Note that all spline-based models use cubic splines. The number of degrees -#' of freedom and/or location of the knots can be changed -#' @param basehaz_ops a named list specifying options related to the baseline +#' @param basehaz_ops A named list specifying options related to the baseline #' hazard. Currently this can include: \cr #' \itemize{ #' \item \code{df}: a positive integer specifying the degrees of freedom -#' for the M-splines or B-splines. The default is 5, corresponding to -#' two boundary knots and two internal knots. +#' for the M-splines or B-splines. The default is 5, corresponding to two +#' boundary knots and two internal knots. #' \item \code{knots}: An optional numeric vector specifying internal #' knot locations for the M-splines or B-splines. Note that \code{knots} -#' cannot be specified if \code{df} is specified. If \code{knots} are not -#' specified, then the default is to use \code{df - 3} knots which are -#' placed at equally spaced percentiles of the distribution of +#' cannot be specified if \code{df} is specified. If \code{knots} are +#' \strong{not} specified, then the default is to use \code{df - 3} knots +#' which are placed at equally spaced percentiles of the distribution of #' uncensored event times. -#' \item \code{bknots}: an optional numeric vector specifying boundary -#' knot locations for the M-splines or B-splines. -#' If not specified, then the default is to place the boundary knots at the -#' minimum and maximum of the event times (including both censored and -#' uncensored events). #' } +#' Note that for the M-splines and B-splines - in addition to any internal +#' \code{knots} - a lower boundary knot is placed at the earliest entry time +#' and an upper boundary knot is placed at the latest event or censoring time. +#' These boundary knot locations are the default and cannot be changed by the +#' user. #' @param qnodes The number of nodes to use for the Gauss-Kronrod quadrature #' that is used to evaluate the cumulative hazard when \code{basehaz = "bs"} #' or when time-dependent effects (i.e. non-proportional hazards) are #' specified. Options are 15 (the default), 11 or 7. +#' @param prior_intercept The prior distribution for the intercept. Note +#' that there will only be an intercept parameter when \code{basehaz} is set +#' equal to one of the standard parametric distributions, i.e. \code{"exp"}, +#' \code{"weibull"} or \code{"gompertz"}, in which case the intercept +#' corresponds to the parameter \emph{log(lambda)} as defined in the +#' \emph{stan_surv: Survival (Time-to-Event) Models} vignette. For the cubic +#' spline-based baseline hazards there is no intercept parameter since it is +#' absorbed into the spline basis and, therefore, the prior for the intercept +#' is effectively specified as part of \code{prior_aux}. +#' +#' Where relevant, \code{prior_intercept} can be a call to \code{normal}, +#' \code{student_t} or \code{cauchy}. See the \link[=priors]{priors help page} +#' for details on these functions. Note however that default scale for +#' \code{prior_intercept} is 20 for \code{stan_surv} models (rather than 10, +#' which is the default scale used for \code{prior_intercept} by most +#' \pkg{rstanarm} modelling functions). To omit a prior on the intercept +#' ---i.e., to use a flat (improper) uniform prior--- \code{prior_intercept} +#' can be set to \code{NULL}. #' @param prior_aux The prior distribution for "auxiliary" parameters related to #' the baseline hazard. The relevant parameters differ depending #' on the type of baseline hazard specified in the \code{basehaz} @@ -555,7 +571,7 @@ stan_surv <- function(formula, user_prior_stuff <- prior_stuff <- handle_glm_prior(prior, nvars = K, - default_scale = 2, + default_scale = 2.5, link = NULL, ok_dists = ok_dists) @@ -572,9 +588,7 @@ stan_surv <- function(formula, default_scale = get_default_aux_scale(basehaz), link = NULL, ok_dists = ok_aux_dists) - if (prior_PD && is.null(prior_aux)) - stop("'prior_aux' cannot be NULL if 'prior_PD' is TRUE") - + user_prior_smooth_stuff <- prior_smooth_stuff <- handle_glm_prior(prior_smooth, nvars = if (S) max(smooth_map) else 0, From 05643d2e4e49c7025b3fb716df99a8c9bd0aa0c2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 11:59:13 +1100 Subject: [PATCH 071/225] Update mice dataset using negative infinity for left censoring --- data/mice.rda | Bin 557 -> 563 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/data/mice.rda b/data/mice.rda index ef4af546f26d8d7fa316651a284134b8c576c59b..6da6d4ef6769ee2ee9426e3169cff431ec7bea51 100644 GIT binary patch delta 534 zcmV+x0_pv&1hWK?D1T8%TOg%YS_qG}v7Oj;UXYP7BV$L#j2$yFGBPqU)m-xZFH%l| zkphY(`*-JieP^Ffe*By84|EBja5cenIv#;XwEzvJv8OLI?D87}Bymxp)y^{;^)PG3%nJ2c4)NlDXLgERC zBlw8l#PAW)KAa-)hd;z<1F0WTKVqDSaiUAHt&sV(iL*ViWImn3FWj=cZ@G`mt24$6 z{ET0gjW;asVv3){#K!!um<5pD<2J{gi%F?sv)eq`W2FtX%n9y|5s*&HguDHYtkdfwnsU9CTbn42k{-SbFGu2&g=ISQ#l7ze0@U51cjl<@)X+2x}PM|MYmQm5otRV7F YD#w-W-4BLtB7vx@pRmzelywXM0GNs)$N&HU delta 528 zcmV+r0`L8^1g!*+D1TOPACOWjErdtg*iP&^i31rsW@PNhn6YC{iHmn?i;Z$@hp#@AI{sc7*xgi`*p;a_n7khyFQZd z@&5aPm~nqVy?+lAJ=D!Ume#5<@0sTxE=cGR8ZfipP2c^ z%r9pA_)1JzKMC~{#!0E4(r?QBF8Q96x1^h;OMj~qmc+K+|3-@@W$`Q!=ldG_ZR#W6 zMc2VCq`XJIr}O$dWj*)VC;L?#8%|IHcQWG7*jM#;o_`GunMZbMNIwJO9nk)x%=1q@ z|NNKewvzv$!t(s9r}b~23;*1=>fURwewe39H>Gmd%KyVj?RZ9u)mq&>)D7m{Y`e9i zgGQdZHmkpM_dQ+R=4PR;6R$|vI}P7xx!yQvZtB*vwQmLaWjdWw(ViMX6rZ_A?&fwQ SZz6%H>j@vp+Dkrl3;+P&r6D{3 From f0c73919992aafc5cd20310cc0bd006169e9b3ac Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 12:04:40 +1100 Subject: [PATCH 072/225] Shorten stan_surv examples --- R/stan_surv.R | 80 ++++++++++++++++++++++++--------------------------- 1 file changed, 37 insertions(+), 43 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index c10164ac9..65e9815fb 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -211,57 +211,51 @@ #' #' # Simulated data #' library(simsurv) -#' covs <- data.frame(id = 1:1000, -#' trt = stats::rbinom(1000, 1L, 0.5)) -#' dat1 <- simsurv(lambdas = 0.1, -#' gammas = 1.5, -#' betas = c(trt = -0.5), -#' x = covs, -#' maxt = 5) -#' dat1 <- merge(dat1, covs) -#' fm1 <- Surv(eventtime, status) ~ trt -#' mod1a <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "ms") -#' mod1b <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "bs") -#' mod1c <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "exp") -#' mod1d <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "weibull") -#' mod1e <- stan_surv(fm1, dat1, chains = 1, iter = 1000, basehaz = "gompertz") -#' do.call(cbind, lapply(list(mod1a, mod1b, mod1c, mod1d, mod1e), fixef)) -#' bayesplot::bayesplot_grid(plot(mod1a), # compare baseline hazards -#' plot(mod1b), -#' plot(mod1c), -#' plot(mod1d), -#' plot(mod1e), -#' ylim = c(0, 0.6)) +#' covs <- data.frame(id = 1:200, +#' trt = stats::rbinom(200, 1L, 0.5)) +#' d1 <- simsurv(lambdas = 0.1, +#' gammas = 1.5, +#' betas = c(trt = -0.5), +#' x = covs, +#' maxt = 5) +#' d1 <- merge(d1, covs) +#' f1 <- Surv(eventtime, status) ~ trt +#' m1a <- stan_surv(f1, d1, basehaz = "ms", chains=1,refresh=0,iter=600) +#' m1b <- stan_surv(f1, d1, basehaz = "exp", chains=1,refresh=0,iter=600) +#' m1c <- stan_surv(f1, d1, basehaz = "weibull", chains=1,refresh=0,iter=600) +#' m1d <- stan_surv(f1, d1, basehaz = "gompertz", chains=1,refresh=0,iter=600) +#' get_est <- function(x) { fixef(x)["trt"] } +#' do.call(rbind, lapply(list(m1a, m1b, m1c, m1d), get_est)) +#' bayesplot::bayesplot_grid(plot(m1a), # compare baseline hazards +#' plot(m1b), +#' plot(m1c), +#' plot(m1d), +#' ylim = c(0, 0.8)) #' -#' # PBC data -#' mod2 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, -#' data = pbcSurv, chains = 1, iter = 1000) -#' print(mod2, 4) -#' -#' #---------- Interval censored data +#' #---------- Left and right censored data #' #' # Mice tumor data -#' mod3 <- stan_surv(Surv(l, u, type = "interval2") ~ grp, -#' data = mice, chains = 1, iter = 1000) -#' print(mod3, 4) +#' m2 <- stan_surv(Surv(l, u, type = "interval2") ~ grp, +#' data = mice, chains = 1, refresh = 0, iter = 600) +#' print(m2, 4) #' #' #---------- Non-proportional hazards #' #' # Simulated data #' library(simsurv) -#' covs <- data.frame(id = 1:500, -#' trt = stats::rbinom(500, 1L, 0.5)) -#' dat4 <- simsurv(lambdas = 0.1, -#' gammas = 1.5, -#' betas = c(trt = -0.5), -#' tde = c(trt = 0.2), -#' x = covs, -#' maxt = 5) -#' dat4 <- merge(dat4, covs) -#' mod4 <- stan_surv(Surv(eventtime, status) ~ tde(trt), -#' data = dat4, chains = 1, iter = 1000) -#' print(mod4, 4) -#' plot(mod4, "tde") # time-dependent hazard ratio +#' covs <- data.frame(id = 1:250, +#' trt = stats::rbinom(250, 1L, 0.5)) +#' d3 <- simsurv(lambdas = 0.1, +#' gammas = 1.5, +#' betas = c(trt = -0.5), +#' tde = c(trt = 0.2), +#' x = covs, +#' maxt = 5) +#' d3 <- merge(d3, covs) +#' m3 <- stan_surv(Surv(eventtime, status) ~ tde(trt), +#' data = d3, chains = 1, refresh = 0, iter = 600) +#' print(m3, 4) +#' plot(m3, "tde") # time-dependent hazard ratio #' } #' stan_surv <- function(formula, From ffebbf83b1d7c81841ce3512ba5561a03a106e0d Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 15:03:14 +1100 Subject: [PATCH 073/225] Fixes to solve R CMD Check warnings --- R/doc-datasets.R | 3 +- R/jm_data_block.R | 14 ++++++++ R/log_lik.R | 6 ++-- R/posterior_survfit.R | 75 ++++++++----------------------------------- R/stan_surv.R | 7 ++-- 5 files changed, 36 insertions(+), 69 deletions(-) diff --git a/R/doc-datasets.R b/R/doc-datasets.R index 27134f9fe..2be6aac9e 100644 --- a/R/doc-datasets.R +++ b/R/doc-datasets.R @@ -20,8 +20,7 @@ #' Small datasets for use in \pkg{rstanarm} examples and vignettes. #' #' @name rstanarm-datasets -#' @aliases bball1970 bball2006 bcancer kidiq mice mortality -#' @aliases pbcLong pbcSurv tumors radon roaches wells +#' @aliases bball1970 bball2006 bcancer kidiq mice mortality pbcLong pbcSurv tumors radon roaches wells #' @format #' \describe{ #' \item{\code{bball1970}}{ diff --git a/R/jm_data_block.R b/R/jm_data_block.R index ae708cf0f..06539a833 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -1257,6 +1257,20 @@ make_basehaz_X <- function(times, basehaz) { X } +# Create a dummy indicator matrix for time intervals defined by 'knots' +# +# @param x A numeric vector with the original data. +# @param knots The cutpoints defining the desired categories of 'x'. +# @return A dummy matrix. +dummy_matrix <- function(x, knots) { + n_intervals <- length(knots) - 1 + interval <- cut(x, knots, include.lowest = TRUE, labels = FALSE) + out <- matrix(NA, length(interval), n_intervals) + for (i in 1:nvars) + out[, i] <- ifelse(interval == i, 1, 0) + as.matrix(out) +} + # Function to return standardised GK quadrature points and weights # # @param nodes The required number of quadrature nodes diff --git a/R/log_lik.R b/R/log_lik.R index e6b74b3fd..9d4ea9dd9 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -1217,9 +1217,9 @@ split2.matrix <- function(x, n_segments = 1, bycol = TRUE) { segment_length <- len %/% n_segments if (!len == (segment_length * n_segments)) stop("Dividing x by n_segments does not result in an integer.") - lapply(1:nsplits, function(k) { - if (bycol) x[, (k-1) * len_k + 1:segment_length, drop = FALSE] else - x[(k-1) * len_k + 1:len_k, , drop = FALSE]}) + lapply(1:n_segments, function(k) { + if (bycol) x[, (k-1) * segment_length + 1:segment_length, drop = FALSE] else + x[(k-1) * segment_length + 1:segment_length, , drop = FALSE]}) } # Split a vector or matrix into a specified number of segments diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index f491baa46..bab597901 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -31,6 +31,20 @@ #' @templateVar stanregArg object #' @template args-stansurv-stanjm-object #' +#' @param newdata Optionally, a data frame in which to look for variables with +#' which to predict. If omitted, the model matrix is used. If \code{newdata} +#' is provided and any variables were transformed (e.g. rescaled) in the data +#' used to fit the model, then these variables must also be transformed in +#' \code{newdata}. This only applies if variables were transformed before +#' passing the data to one of the modeling functions and \emph{not} if +#' transformations were specified inside the model formula. Also, +#' \code{newdata} can optionally include a variable with information +#' about the last known survival time for the new individuals -- +#' see the description for the \code{last_time} argument below +#' -- however also note that when generating the survival probabilities it +#' is of course assumed that all individuals in \code{newdata} have not +#' yet experienced the event (that is, any variable in \code{newdataEvent} +#' that corresponds to the event indicator will be ignored). #' @param newdataLong,newdataEvent Optionally, a data frame (or in the case of #' \code{newdataLong} this can be a list of data frames) in which to look #' for variables with which to predict. If omitted, the model matrices are used. @@ -845,67 +859,6 @@ posterior_survfit.stanjm <- function(object, stop("Invalid input to the 'type' argument.")) } -.pp_predict_surv.stanjm <- function(object, - data, - pars, - type = "surv") { - - # time-fixed part of linear predictor - eta <- linear_predictor(pars$e_beta, data$e_x) - - # add on association structure - if (length(pars$a_beta)) { - - # temporary stop, until make_assoc_terms can handle it - sel_stop <- grep("^shared", rownames(object$assoc)) - if (any(unlist(object$assoc[sel_stop,]))) - stop2("not yet implemented for shared_* association structures.") - - # order b_pars from stanmat according to predictor matrices - pars$b <- lapply(1:get_M(object), function(m) { - b_m <- pars$b[[m]] - Z_names_m <- data$assoc_parts[[m]][["mod_eta"]][["Z_names"]] - pp_b_ord(if (is.matrix(b_m)) b_m else t(b_m), Z_names_m) - }) - - # evaluate the implicit covariates in the association structure - a_x <- make_assoc_terms(parts = data$assoc_parts, - assoc = object$assoc, - family = object$family, - beta = pars$beta, - b = pars$b) - if (one_draw) { - eta <- eta + linear_predictor.default(pars$a_beta, a_x) - } else { for (k in 1:length(a_x)) - eta <- eta + sweep(a_x[[k]], 1L, pars$a_beta[,k], `*`) - } - - } - - # add on baseline hazard - args <- nlist(basehaz = get_basehaz(object), - times = data$pts, - aux = pars$e_aux, - intercept = pars$e_alpha) - lhaz <- do.call(evaluate_log_basehaz, args) + eta - - if (!type %in% c("loghaz", "haz")) { - # evaluate survival; with quadrature - lsurv <- -quadrature_sum(exp(lhaz), qnodes = data$qnodes, qwts = data$wts) - } - - switch(type, - loghaz = lhaz, - logcumhaz = log(-lsurv), - logsurv = lsurv, - logcdf = log(1 - exp(lsurv)), - haz = exp(lhaz), - surv = exp(lsurv), - cumhaz = -lsurv, - cdf = 1 - exp(lsurv), - stop("Invalid input to the 'type' argument.")) -} - # Summarise predictions into median, lower CI, upper CI # diff --git a/R/stan_surv.R b/R/stan_surv.R index 65e9815fb..f4fe51a8f 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -32,7 +32,7 @@ #' @importFrom splines bs #' @import splines2 #' -#' @template args-prior_intercept +#' @template args-dots #' @template args-priors #' @template args-prior_PD #' @template args-algorithm @@ -731,7 +731,7 @@ stan_surv <- function(formula, qnodes = if (has_quadrature) qnodes else NULL, algorithm, stan_function = "stan_surv", - rstanarm_version = packageVersion("rstanarm"), + rstanarm_version = utils::packageVersion("rstanarm"), call = match.call(expand.dots = TRUE)) stansurv(fit) } @@ -1067,7 +1067,8 @@ basis_matrix <- function(times, basis, integrate = FALSE) { out <- predict(basis, times) if (integrate) { stopifnot(inherits(basis, "mSpline")) - out <- splines2:::predict.iSpline(basis, times) + class(basis) <- c("matrix", "iSpline") + out <- predict(basis, times) } aa(out) } From 7cf9833a32d465fa73e2e56462e6113a4760e951 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 15:20:01 +1100 Subject: [PATCH 074/225] Fix failing mvmer test --- tests/testthat/test_stan_jm.R | 19 ++++++++++--------- tests/testthat/test_stan_mvmer.R | 31 ++++++++++++++++--------------- 2 files changed, 26 insertions(+), 24 deletions(-) diff --git a/tests/testthat/test_stan_jm.R b/tests/testthat/test_stan_jm.R index 5e9f20a78..81ebbb854 100644 --- a/tests/testthat/test_stan_jm.R +++ b/tests/testthat/test_stan_jm.R @@ -22,20 +22,22 @@ library(rstanarm) library(lme4) library(survival) -ITER <- 1000 -CHAINS <- 1 -SEED <- 12345 + +ITER <- 1000 +CHAINS <- 1 +SEED <- 12345 REFRESH <- 0L + set.seed(SEED) if (interactive()) options(mc.cores = parallel::detectCores()) TOLSCALES <- list( - lmer_fixef = 0.25, # how many SEs can stan_jm fixefs be from lmer fixefs - lmer_ranef = 0.05, # how many SDs can stan_jm ranefs be from lmer ranefs - glmer_fixef = 0.5, # how many SEs can stan_jm fixefs be from glmer fixefs - glmer_ranef = 0.1, # how many SDs can stan_jm ranefs be from glmer ranefs - event = 0.3 # how many SEs can stan_jm fixefs be from coxph fixefs + lmer_fixef = 0.25, # how many SEs can stan_jm fixefs be from lmer fixefs + lmer_ranef = 0.05, # how many SDs can stan_jm ranefs be from lmer ranefs + glmer_fixef = 0.5, # how many SEs can stan_jm fixefs be from glmer fixefs + glmer_ranef = 0.1, # how many SDs can stan_jm ranefs be from glmer ranefs + event = 0.3 # how many SEs can stan_jm fixefs be from coxph fixefs ) source(test_path("helpers", "expect_matrix.R")) @@ -45,7 +47,6 @@ source(test_path("helpers", "expect_survfit_jm.R")) source(test_path("helpers", "expect_ppd.R")) source(test_path("helpers", "expect_equivalent_loo.R")) source(test_path("helpers", "SW.R")) -# SW <- function(expr) eval(expr) source(test_path("helpers", "get_tols_jm.R")) source(test_path("helpers", "recover_pars_jm.R")) diff --git a/tests/testthat/test_stan_mvmer.R b/tests/testthat/test_stan_mvmer.R index 1b42263ad..9a6ebe97f 100644 --- a/tests/testthat/test_stan_mvmer.R +++ b/tests/testthat/test_stan_mvmer.R @@ -21,30 +21,32 @@ library(rstanarm) library(lme4) -ITER <- 1000 -CHAINS <- 1 -SEED <- 12345 + +ITER <- 1000 +CHAINS <- 1 +SEED <- 12345 REFRESH <- 0L + set.seed(SEED) if (interactive()) options(mc.cores = parallel::detectCores()) TOLSCALES <- list( - lmer_fixef = 0.25, # how many SEs can stan_jm fixefs be from lmer fixefs - lmer_ranef = 0.05, # how many SDs can stan_jm ranefs be from lmer ranefs - glmer_fixef = 0.3, # how many SEs can stan_jm fixefs be from glmer fixefs - glmer_ranef = 0.1 # how many SDs can stan_jm ranefs be from glmer ranefs + lmer_fixef = 0.25, # how many SEs can stan_jm fixefs be from lmer fixefs + lmer_ranef = 0.05, # how many SDs can stan_jm ranefs be from lmer ranefs + glmer_fixef = 0.3, # how many SEs can stan_jm fixefs be from glmer fixefs + glmer_ranef = 0.1 # how many SDs can stan_jm ranefs be from glmer ranefs ) source(test_path("helpers", "expect_matrix.R")) source(test_path("helpers", "expect_stanreg.R")) source(test_path("helpers", "expect_stanmvreg.R")) -source(test_path("helpers", "expect_survfit.R")) +source(test_path("helpers", "expect_survfit_jm.R")) source(test_path("helpers", "expect_ppd.R")) source(test_path("helpers", "expect_identical_sorted_stanmats.R")) source(test_path("helpers", "SW.R")) -source(test_path("helpers", "get_tols.R")) -source(test_path("helpers", "recover_pars.R")) +source(test_path("helpers", "get_tols_jm.R")) +source(test_path("helpers", "recover_pars_jm.R")) context("stan_mvmer") @@ -183,7 +185,7 @@ if (interactive()) { expect_equal(colMeans(log_lik(y1, newdata = nd)), colMeans(log_lik(y2, newdata = nd)), tol = 0.15) } - test_that("coefs same for stan_jm and stan_lmer/coxph", { + test_that("coefs same for stan_mvmer and stan_glmer", { compare_glmer(logBili ~ year + (1 | id), gaussian)}) # fails in some cases # test_that("coefs same for stan_jm and stan_glmer, bernoulli", { @@ -210,16 +212,15 @@ o<-SW(f3 <- update(m2, formula. = list(logBili ~ year + (year | id) + (1 | pract o<-SW(f4 <- update(f3, formula. = list(logBili ~ year + (year | id) + (1 | practice), albumin ~ year + (year | id) + (1 | practice)))) o<-SW(f5 <- update(f3, formula. = list(logBili ~ year + (year | id) + (1 | practice), - ybern ~ year + (year | id) + (1 | practice)), - family = list(gaussian, binomial))) + ybern ~ year + (year | id) + (1 | practice)), + family = list(gaussian, binomial))) for (j in 1:5) { mod <- get(paste0("f", j)) cat("Checking model:", paste0("f", j), "\n") expect_error(posterior_traj(mod), "stanjm") - expect_error(posterior_survfit(mod), "stanjm") - + test_that("posterior_predict works with estimation data", { pp <- posterior_predict(mod, m = 1) expect_ppd(pp) From 6a4b42f2d140a033631f5a034c0cec7d0a336bd4 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 16:31:55 +1100 Subject: [PATCH 075/225] Fix small bug in dummy_matrix function --- R/jm_data_block.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 06539a833..04d7863bd 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -1266,7 +1266,7 @@ dummy_matrix <- function(x, knots) { n_intervals <- length(knots) - 1 interval <- cut(x, knots, include.lowest = TRUE, labels = FALSE) out <- matrix(NA, length(interval), n_intervals) - for (i in 1:nvars) + for (i in 1:n_intervals) out[, i] <- ifelse(interval == i, 1, 0) as.matrix(out) } From 051625c4d78781462f7e81c5f1bd0633fe11a32e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 16:33:59 +1100 Subject: [PATCH 076/225] Change default df for M-splines to 6 --- R/stan_surv.R | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index f4fe51a8f..8f66d8dd0 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -82,14 +82,17 @@ #' hazard. Currently this can include: \cr #' \itemize{ #' \item \code{df}: a positive integer specifying the degrees of freedom -#' for the M-splines or B-splines. The default is 5, corresponding to two +#' for the M-splines or B-splines. An intercept is included in the spline +#' basis and included in the count of the degrees of freedom, such that +#' two boundary knots and \code{df - 4} internal knots are used to generate +#' the cubic spline basis. The default is \code{df = 6}; that is, two #' boundary knots and two internal knots. #' \item \code{knots}: An optional numeric vector specifying internal #' knot locations for the M-splines or B-splines. Note that \code{knots} #' cannot be specified if \code{df} is specified. If \code{knots} are -#' \strong{not} specified, then the default is to use \code{df - 3} knots -#' which are placed at equally spaced percentiles of the distribution of -#' uncensored event times. +#' \strong{not} specified, then \code{df - 4} internal knots are placed +#' at equally spaced percentiles of the distribution of uncensored event +#' times. #' } #' Note that for the M-splines and B-splines - in addition to any internal #' \code{knots} - a lower boundary knot is placed at the earliest entry time @@ -805,7 +808,7 @@ handle_basehaz_surv <- function(basehaz, stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") if (is.null(df)) - df <- 5L # default df for B-splines, assuming no intercept + df <- 6L # default df for B-splines, assuming an intercept is included # NB this is ignored if the user specified knots tt <- times[status == 1] # uncensored event times @@ -838,7 +841,7 @@ handle_basehaz_surv <- function(basehaz, tt <- times[status == 1] # uncensored event times if (is.null(df)) { - df <- 5L # default df for B-splines, assuming no intercept + df <- 6L # default df for M-splines, assuming an intercept is included # NB this is ignored if the user specified knots } From f441857baa1a7bdd4e893558c7997af3b1d85056 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 1 Nov 2018 16:53:38 +1100 Subject: [PATCH 077/225] Don't attach testthat in test_stan_surv --- tests/testthat/test_stan_surv.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 34bf5a6cd..0e9ea6c50 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -19,7 +19,6 @@ # tests can be run using devtools::test() or manually by loading testthat # package and then running the code below possibly with options(mc.cores = 4). -library(testthat) library(rstanarm) library(survival) library(simsurv) From 9db302a24b9749d96d5375529a827672563e0a02 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 19 Nov 2018 17:11:29 +1100 Subject: [PATCH 078/225] Remove intercept from spline basis --- R/misc.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/misc.R b/R/misc.R index 76cf18fa8..4cc691b32 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1744,7 +1744,7 @@ qtile <- function(x, nq = 2) { # Return the desired spline basis for the given knot locations get_basis <- function(x, iknots, bknots = range(x), - degree = 3, intercept = TRUE, + degree = 3, intercept = FALSE, type = c("bs", "is", "ms")) { type <- match.arg(type) if (type == "bs") { From 23bde3ac97826bf8c8e624106692b988ef438be2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 19 Nov 2018 17:12:10 +1100 Subject: [PATCH 079/225] Add explicit intercept parameter to baseline hazard and survival for spline models --- R/log_lik.R | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/R/log_lik.R b/R/log_lik.R index 9d4ea9dd9..f5eba8d2e 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -1098,8 +1098,8 @@ evaluate_log_basehaz <- function(times, basehaz, aux, intercept = NULL) { "exp" = log_basehaz_exponential(times, log_scale = intercept), "weibull" = log_basehaz_weibull (times, shape = aux, log_scale = intercept), "gompertz" = log_basehaz_gompertz(times, scale = aux, log_shape = intercept), - "ms" = log_basehaz_ms(times, coefs = aux, basis = basehaz$basis), - "bs" = log_basehaz_bs(times, coefs = aux, basis = basehaz$basis), + "ms" = log_basehaz_ms(times, coefs = aux, basis = basehaz$basis, intercept = intercept), + "bs" = log_basehaz_bs(times, coefs = aux, basis = basehaz$basis, intercept = intercept), "piecewise" = log_basehaz_pw(times, coefs = aux, knots = basehaz$knots), stop2("Bug found: unknown type of baseline hazard.")) } @@ -1113,11 +1113,11 @@ log_basehaz_weibull <- function(x, shape, log_scale) { log_basehaz_gompertz <- function(x, scale, log_shape) { as.vector(log_shape) + linear_predictor(scale, x) } -log_basehaz_ms <- function(x, coefs, basis) { - log(linear_predictor(coefs, basis_matrix(x, basis = basis))) +log_basehaz_ms <- function(x, coefs, basis, intercept) { + as.vector(intercept) + log(linear_predictor(coefs, basis_matrix(x, basis = basis))) } -log_basehaz_bs <- function(x, coefs, basis) { - linear_predictor(coefs, basis_matrix(x, basis = basis)) +log_basehaz_bs <- function(x, coefs, basis, intercept) { + as.vector(intercept) + linear_predictor(coefs, basis_matrix(x, basis = basis)) } log_basehaz_pw <- function(x, coefs, knots) { linear_predictor(coefs, dummy_matrix(x, knots = knots)) @@ -1151,7 +1151,7 @@ evaluate_log_basesurv <- function(times, basehaz, aux, intercept = NULL) { "exp" = log_basesurv_exponential(times, log_scale = intercept), "weibull" = log_basesurv_weibull (times, shape = aux, log_scale = intercept), "gompertz" = log_basesurv_gompertz(times, scale = aux, log_shape = intercept), - "ms" = log_basesurv_ms(times, coefs = aux, basis = basehaz$basis), + "ms" = log_basesurv_ms(times, coefs = aux, basis = basehaz$basis, intercept = intercept), stop2("Bug found: unknown type of baseline hazard.")) } @@ -1164,8 +1164,9 @@ log_basesurv_weibull <- function(x, shape, log_scale) { log_basesurv_gompertz <- function(x, scale, log_shape) { -(as.vector(exp(log_shape) / scale)) * (exp(linear_predictor(scale, x)) - 1) } -log_basesurv_ms <- function(x, coefs, basis) { - -linear_predictor(coefs, basis_matrix(x, basis = basis, integrate = TRUE)) +log_basesurv_ms <- function(x, coefs, basis, intercept) { + - exp(as.vector(intercept)) * + linear_predictor(coefs, basis_matrix(x, basis = basis, integrate = TRUE)) } evaluate_log_surv <- function(times, basehaz, betas, aux, intercept = NULL, x, ...) { From 8a92d3219b616807cda4e623200f7dddc2fa5b84 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 19 Nov 2018 17:13:00 +1100 Subject: [PATCH 080/225] Center predictor matrix, and center intercept using log crude event rate --- R/stan_surv.R | 71 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 45 insertions(+), 26 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 8f66d8dd0..ba35f71ca 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -103,15 +103,14 @@ #' that is used to evaluate the cumulative hazard when \code{basehaz = "bs"} #' or when time-dependent effects (i.e. non-proportional hazards) are #' specified. Options are 15 (the default), 11 or 7. -#' @param prior_intercept The prior distribution for the intercept. Note -#' that there will only be an intercept parameter when \code{basehaz} is set -#' equal to one of the standard parametric distributions, i.e. \code{"exp"}, -#' \code{"weibull"} or \code{"gompertz"}, in which case the intercept -#' corresponds to the parameter \emph{log(lambda)} as defined in the -#' \emph{stan_surv: Survival (Time-to-Event) Models} vignette. For the cubic -#' spline-based baseline hazards there is no intercept parameter since it is -#' absorbed into the spline basis and, therefore, the prior for the intercept -#' is effectively specified as part of \code{prior_aux}. +#' @param prior_intercept The prior distribution for the intercept. +#' All models include an intercept parameter. +#' If \code{basehaz} is set equal to one of the standard parametric +#' distributions, i.e. \code{"exp"}, \code{"weibull"} or \code{"gompertz"}, +#' then the intercept corresponds to the parameter \emph{log(lambda)} as +#' defined in the \emph{stan_surv: Survival (Time-to-Event) Models} vignette. +#' Also refer to the vignette for the definition of the intercept parameter +#' in the cubic spline-based baseline hazards. #' #' Where relevant, \code{prior_intercept} can be a call to \code{normal}, #' \code{student_t} or \code{cauchy}. See the \link[=priors]{priors help page} @@ -128,7 +127,12 @@ #' \itemize{ #' \item \code{basehaz = "ms"}: the auxiliary parameters are the coefficients #' for the M-spline basis terms on the baseline hazard. These parameters -#' have a lower bound at zero. +#' have a lower bound at zero. The prior specified by the user is for the +#' coefficients as defined on the postive real line. However, to ensure +#' identifiability of the model, these are transformed to constrained +#' parameters between 0 and 1 (forming a simplex) during the fitting of +#' the model. Refer to the \emph{stan_surv: Survival (Time-to-Event) Models} +#' vignette for further technical details. #' \item \code{basehaz = "bs"}: the auxiliary parameters are the coefficients #' for the B-spline basis terms on the log baseline hazard. These parameters #' are unbounded. @@ -334,6 +338,11 @@ stan_surv <- function(formula, t_icenu <- t_upp[status == 3] # upper limit of interval censoring time t_delay <- t_beg[delayed] # delayed entry time + # calculate log crude event rate + t_tmp <- sum(rowMeans(cbind(t_end, t_upp), na.rm = TRUE) - t_beg) + d_tmp <- sum(!status == 0) + log_crude_event_rate = log(d_tmp / t_tmp) + # dimensions nevent <- sum(status == 1) nrcens <- sum(status == 0) @@ -442,12 +451,15 @@ stan_surv <- function(formula, #----- predictor matrices # time-fixed predictor matrix - x <- make_x(formula$tf_form, mf)$x - x_event <- keep_rows(x, status == 1) - x_lcens <- keep_rows(x, status == 2) - x_rcens <- keep_rows(x, status == 0) - x_icens <- keep_rows(x, status == 3) - x_delay <- keep_rows(x, delayed) + x_stuff <- make_x(formula$tf_form, mf) + x <- x_stuff$x + x_bar <- x_stuff$x_bar + x_centered <- x_stuff$x_centered + x_event <- keep_rows(x_centered, status == 1) + x_lcens <- keep_rows(x_centered, status == 2) + x_rcens <- keep_rows(x_centered, status == 0) + x_icens <- keep_rows(x_centered, status == 3) + x_delay <- keep_rows(x_centered, delayed) K <- ncol(x) if (has_quadrature) { x_cpts <- rbind(x_event, @@ -490,7 +502,8 @@ stan_surv <- function(formula, standata <- nlist( K, S, - nvars, + nvars, + x_bar, has_intercept, has_quadrature, smooth_map, @@ -499,6 +512,7 @@ stan_surv <- function(formula, len_cpts, idx_cpts, type = basehaz$type, + log_crude_event_rate, nevent = if (has_quadrature) 0L else nevent, nlcens = if (has_quadrature) 0L else nlcens, @@ -661,11 +675,12 @@ stan_surv <- function(formula, stanfit <- stanmodels$surv # specify parameters for stan to monitor - stanpars <- c(if (standata$has_intercept) "gamma", + basehaz_pars <- ifelse(basehaz$type_name == "ms", "coefs_constrained", "coefs") + stanpars <- c(if (standata$has_intercept) "alpha", if (standata$K) "beta", if (standata$S) "beta_tde", if (standata$S) "smooth_sd", - if (standata$nvars) "coefs") + if (standata$nvars) basehaz_pars) # fit model using stan if (algorithm == "sampling") { # mcmc @@ -808,7 +823,7 @@ handle_basehaz_surv <- function(basehaz, stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") if (is.null(df)) - df <- 6L # default df for B-splines, assuming an intercept is included + df <- 5L # default df for B-splines, assuming no intercept # NB this is ignored if the user specified knots tt <- times[status == 1] # uncensored event times @@ -841,7 +856,7 @@ handle_basehaz_surv <- function(basehaz, tt <- times[status == 1] # uncensored event times if (is.null(df)) { - df <- 6L # default df for M-splines, assuming an intercept is included + df <- 5L # default df for M-splines, assuming no intercept # NB this is ignored if the user specified knots } @@ -979,7 +994,7 @@ get_iknots <- function(x, df = 6L, degree = 3L, iknots = NULL, intercept = TRUE) # @return A Logical. has_intercept <- function(basehaz) { nm <- get_basehaz_name(basehaz) - (nm %in% c("exp", "weibull", "gompertz")) + (nm %in% c("ms", "bs", "exp", "weibull", "gompertz")) } # Return the name of the tde spline coefs or smoothing parameters. @@ -1394,8 +1409,9 @@ make_model_frame <- function(formula, data, check_constant = TRUE) { # @param formula The parsed model formula. # @param model_frame The model frame. # @return A named list with the following elements: -# x: the fe model matrix, not centred and without intercept. -# xbar: the column means of the model matrix. +# x: the fe model matrix, not centered and without intercept. +# x_bar: the column means of the model matrix. +# x_centered: the fe model matrix, centered. # N,K: number of rows (observations) and columns (predictors) in the # fixed effects model matrix make_x <- function(formula, model_frame, xlevs = NULL, check_constant = TRUE) { @@ -1405,7 +1421,10 @@ make_x <- function(formula, model_frame, xlevs = NULL, check_constant = TRUE) { x <- drop_intercept(x) # column means of predictor matrix - xbar <- colMeans(x) + x_bar <- aa(colMeans(x)) + + # centered predictor matrix + x_centered <- sweep(x, 2, x_bar, FUN = "-") # identify any column of x with < 2 unique values (empty interaction levels) sel <- (apply(x, 2L, n_distinct) < 2) @@ -1414,7 +1433,7 @@ make_x <- function(formula, model_frame, xlevs = NULL, check_constant = TRUE) { stop2("Cannot deal with empty interaction levels found in columns: ", cols) } - nlist(x, xbar, N = NROW(x), K = NCOL(x)) + nlist(x, x_centered, x_bar, N = NROW(x), K = NCOL(x)) } # Return a predictor for the tde spline terms From 14f3bd9d810cfc2b95c9189c24df2af1822be335 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 19 Nov 2018 17:13:40 +1100 Subject: [PATCH 081/225] Center intercept, center predictor matrix, and use contrained coefficients for M-splines --- src/stan_files/surv.stan | 52 ++++++++++++++++++++++++++++++---------- 1 file changed, 40 insertions(+), 12 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index c11a3384b..5b09cfddc 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -426,6 +426,9 @@ data { int idx_cpts[7,2]; // index for breaking cpts into epts,qpts_event,etc int len_cpts; + // log crude event rate (used for centering log baseline hazard) + real log_crude_event_rate; + // response and time variables vector[nevent] t_event; // time of events vector[nlcens] t_lcens; // time of left censoring @@ -436,11 +439,12 @@ data { vector[len_cpts] cpts; // time at events and all quadrature points // predictor matrices (time-fixed) - matrix[nevent,K] x_event; // for rows with events - matrix[nlcens,K] x_lcens; // for rows with left censoring - matrix[nrcens,K] x_rcens; // for rows with right censoring - matrix[nicens,K] x_icens; // for rows with interval censoring - matrix[ndelay,K] x_delay; // for rows with delayed entry + vector[K] x_bar; // predictor means + matrix[nevent,K] x_event; // for rows with events + matrix[nlcens,K] x_lcens; // for rows with left censoring + matrix[nrcens,K] x_rcens; // for rows with right censoring + matrix[nicens,K] x_icens; // for rows with interval censoring + matrix[ndelay,K] x_delay; // for rows with delayed entry matrix[len_cpts,K] x_cpts; // for rows at events and all quadrature points // predictor matrices (time-varying) @@ -578,6 +582,7 @@ transformed parameters { // basehaz parameters vector[nvars] coefs; + simplex[type == 4 ? nvars : 1] coefs_constrained; // for M-splines only // tde spline coefficients and their hyperparameters vector[S] beta_tde; @@ -595,6 +600,9 @@ transformed parameters { if (nvars > 0) { coefs = z_coefs .* prior_scale_for_aux; } + if (type == 4) { // constrained coefs for M-splines (ensures identifiability) + coefs_constrained = softmax(coefs); + } // define tde spline coefficients using random walk if (S > 0) { @@ -653,6 +661,13 @@ model { if (ndelay > 0) eta_delay += gamma[1]; } + // add on log crude event rate (helps to center intercept) + if (nevent > 0) eta_event += log_crude_event_rate; + if (nlcens > 0) eta_lcens += log_crude_event_rate; + if (nrcens > 0) eta_rcens += log_crude_event_rate; + if (nicens > 0) eta_icens += log_crude_event_rate; + if (ndelay > 0) eta_delay += log_crude_event_rate; + // evaluate log hazard and log survival if (type == 5) { // exponential model if (nevent > 0) target += exponential_log_haz (eta_event); @@ -681,12 +696,12 @@ model { if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); } else if (type == 4) { // M-splines, on haz scale - if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs); - if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs); - if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs); - if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs); - if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs); - if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs); + if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs_constrained); + if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs_constrained); + if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs_constrained); + if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs_constrained); + if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs_constrained); + if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs_constrained); } else { reject("Bug found: invalid baseline hazard (without quadrature)."); @@ -725,6 +740,9 @@ model { if (has_intercept == 1) { eta += gamma[1]; } + + // add on log crude event rate (helps to center intercept) + eta += log_crude_event_rate; // evaluate log hazard if (type == 5) { // exponential model @@ -739,7 +757,7 @@ model { lhaz = gompertz_log_haz(eta, cpts, scale); } else if (type == 4) { // M-splines, on haz scale - lhaz = mspline_log_haz(eta, basis_cpts, coefs); + lhaz = mspline_log_haz(eta, basis_cpts, coefs_constrained); } else if (type == 2) { // B-splines, on log haz scale lhaz = bspline_log_haz(eta, basis_cpts, coefs); @@ -800,3 +818,13 @@ model { } } + +generated quantities { + real alpha; // transformed intercept + + if (has_intercept == 1) { + alpha = log_crude_event_rate - dot_product(x_bar, beta) + gamma[1]; + } else { + alpha = log_crude_event_rate - dot_product(x_bar, beta); + } +} From 69ecf9a6cb7f5beb34e863af8f5d2dd6ddcf9fb9 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 20 Nov 2018 13:44:40 +1100 Subject: [PATCH 082/225] Use array for constrained spline coefficients --- R/stan_surv.R | 5 ++--- src/stan_files/surv.stan | 30 ++++++++++++++++++------------ 2 files changed, 20 insertions(+), 15 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index ba35f71ca..5ae13bf58 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -675,12 +675,11 @@ stan_surv <- function(formula, stanfit <- stanmodels$surv # specify parameters for stan to monitor - basehaz_pars <- ifelse(basehaz$type_name == "ms", "coefs_constrained", "coefs") stanpars <- c(if (standata$has_intercept) "alpha", if (standata$K) "beta", if (standata$S) "beta_tde", if (standata$S) "smooth_sd", - if (standata$nvars) basehaz_pars) + if (standata$nvars) "aux") # fit model using stan if (algorithm == "sampling") { # mcmc @@ -1422,7 +1421,7 @@ make_x <- function(formula, model_frame, xlevs = NULL, check_constant = TRUE) { # column means of predictor matrix x_bar <- aa(colMeans(x)) - + # centered predictor matrix x_centered <- sweep(x, 2, x_bar, FUN = "-") diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 5b09cfddc..c17697544 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -580,9 +580,11 @@ transformed parameters { // log hazard ratios vector[K] beta; - // basehaz parameters + // unconstrained basehaz parameters vector[nvars] coefs; - simplex[type == 4 ? nvars : 1] coefs_constrained; // for M-splines only + + // constrained basehaz parameters; for M-splines, to ensure identifiability + simplex[nvars] coefs_constrained[type == 4]; // tde spline coefficients and their hyperparameters vector[S] beta_tde; @@ -601,9 +603,10 @@ transformed parameters { coefs = z_coefs .* prior_scale_for_aux; } if (type == 4) { // constrained coefs for M-splines (ensures identifiability) - coefs_constrained = softmax(coefs); + coefs_constrained[1] = softmax(coefs); } + // define tde spline coefficients using random walk if (S > 0) { smooth_sd = smooth_sd_raw .* prior_scale_for_smooth + prior_mean_for_smooth; @@ -696,12 +699,12 @@ model { if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); } else if (type == 4) { // M-splines, on haz scale - if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs_constrained); - if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs_constrained); - if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs_constrained); - if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs_constrained); - if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs_constrained); - if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs_constrained); + if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs_constrained[1]); + if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs_constrained[1]); + if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs_constrained[1]); + if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs_constrained[1]); + if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs_constrained[1]); + if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs_constrained[1]); } else { reject("Bug found: invalid baseline hazard (without quadrature)."); @@ -740,7 +743,7 @@ model { if (has_intercept == 1) { eta += gamma[1]; } - + // add on log crude event rate (helps to center intercept) eta += log_crude_event_rate; @@ -757,7 +760,7 @@ model { lhaz = gompertz_log_haz(eta, cpts, scale); } else if (type == 4) { // M-splines, on haz scale - lhaz = mspline_log_haz(eta, basis_cpts, coefs_constrained); + lhaz = mspline_log_haz(eta, basis_cpts, coefs_constrained[1]); } else if (type == 2) { // B-splines, on log haz scale lhaz = bspline_log_haz(eta, basis_cpts, coefs); @@ -820,8 +823,11 @@ model { } generated quantities { - real alpha; // transformed intercept + // baseline hazard parameters to return + vector[nvars] aux = (type == 4) ? coefs_constrained[1] : coefs; + // transformed intercept + real alpha; if (has_intercept == 1) { alpha = log_crude_event_rate - dot_product(x_bar, beta) + gamma[1]; } else { From 8ff50cb9dc057e8652d4324b4fc86986a097d83b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 21 Nov 2018 15:04:18 +1100 Subject: [PATCH 083/225] Use dirichlet prior directly on constrained M-spline coefficients --- src/stan_files/surv.stan | 47 ++++++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index c17697544..21f29df71 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -224,7 +224,8 @@ functions { * @param aux_unscaled Vector (potentially of length 1) of unscaled * auxiliary parameter(s) * @param dist Integer specifying the type of prior distribution - * @param df Real specifying the df for the prior distribution + * @param df Real specifying the df for the prior distribution, or in the case + * of the dirichlet distribution it is the concentration parameter(s) * @return Nothing */ real basehaz_lp(vector aux_unscaled, int dist, vector df) { @@ -233,8 +234,10 @@ functions { target += normal_lpdf(aux_unscaled | 0, 1); else if (dist == 2) target += student_t_lpdf(aux_unscaled | df, 0, 1); - else + else if (dist == 3) target += exponential_lpdf(aux_unscaled | 1); + else + target += dirichlet_lpdf(aux_unscaled | df); // df is concentration here } return target(); } @@ -505,7 +508,8 @@ data { // 1 = normal // 2 = student_t // 3 = exponential - int prior_dist_for_aux; + // 4 = dirichlet + int prior_dist_for_aux; // prior family: // 0 = none @@ -559,7 +563,8 @@ parameters { // gompertz model: nvars = 1, ie. scale parameter // M-spline model: nvars = number of basis terms, ie. spline coefs // B-spline model: nvars = number of basis terms, ie. spline coefs - vector[nvars] z_coefs; + vector[type == 4 ? 0 : nvars] z_coefs; + simplex[nvars] ms_coefs[type == 4]; // constrained coefs for M-splines // unscaled tde spline coefficients vector[S] z_beta_tde; @@ -580,11 +585,8 @@ transformed parameters { // log hazard ratios vector[K] beta; - // unconstrained basehaz parameters - vector[nvars] coefs; - - // constrained basehaz parameters; for M-splines, to ensure identifiability - simplex[nvars] coefs_constrained[type == 4]; + // basehaz parameters + vector[type == 4 ? 0 : nvars] coefs; // tde spline coefficients and their hyperparameters vector[S] beta_tde; @@ -599,13 +601,9 @@ transformed parameters { } // define basehaz parameters - if (nvars > 0) { + if (type != 4 && nvars > 0) { coefs = z_coefs .* prior_scale_for_aux; } - if (type == 4) { // constrained coefs for M-splines (ensures identifiability) - coefs_constrained[1] = softmax(coefs); - } - // define tde spline coefficients using random walk if (S > 0) { @@ -699,12 +697,12 @@ model { if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); } else if (type == 4) { // M-splines, on haz scale - if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs_constrained[1]); - if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs_constrained[1]); - if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs_constrained[1]); - if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs_constrained[1]); - if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs_constrained[1]); - if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs_constrained[1]); + if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, ms_coefs[1]); + if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, ms_coefs[1]); + if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, ms_coefs[1]); + if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, ms_coefs[1]); + if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, ms_coefs[1]); + if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, ms_coefs[1]); } else { reject("Bug found: invalid baseline hazard (without quadrature)."); @@ -760,7 +758,7 @@ model { lhaz = gompertz_log_haz(eta, cpts, scale); } else if (type == 4) { // M-splines, on haz scale - lhaz = mspline_log_haz(eta, basis_cpts, coefs_constrained[1]); + lhaz = mspline_log_haz(eta, basis_cpts, ms_coefs[1]); } else if (type == 2) { // B-splines, on log haz scale lhaz = bspline_log_haz(eta, basis_cpts, coefs); @@ -810,7 +808,10 @@ model { } // log priors for baseline hazard parameters - if (nvars > 0) { + if (type == 4) { + real dummy = basehaz_lp(ms_coefs[1], prior_dist_for_aux, prior_df_for_aux); + } + else if (nvars > 0) { real dummy = basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); } @@ -824,7 +825,7 @@ model { generated quantities { // baseline hazard parameters to return - vector[nvars] aux = (type == 4) ? coefs_constrained[1] : coefs; + vector[nvars] aux = (type == 4) ? ms_coefs[1] : coefs; // transformed intercept real alpha; From 6224e75a88e9cb47f2895d3cf576fa33562c9204 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 22 Nov 2018 14:56:28 +1100 Subject: [PATCH 084/225] Add dirichlet prior to handle_glm_prior function --- R/data_block.R | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/R/data_block.R b/R/data_block.R index 37a9ae70a..586cafc63 100644 --- a/R/data_block.R +++ b/R/data_block.R @@ -60,7 +60,8 @@ handle_glm_prior <- function(prior, nvars, default_scale, link, prior_scale = as.array(rep(1, nvars)), prior_df = as.array(rep(1, nvars)), prior_dist_name = NA, global_prior_scale = 0, global_prior_df = 0, - slab_df = 0, slab_scale = 0, + slab_df = 0, slab_scale = 0, + prior_concentration = as.array(rep(1, nvars)), prior_autoscale = FALSE)) if (!is.list(prior)) @@ -76,6 +77,7 @@ handle_glm_prior <- function(prior, nvars, default_scale, link, global_prior_df <- 0 slab_df <- 0 slab_scale <- 0 + prior_concentration <- 1 if (!prior_dist_name %in% unlist(ok_dists)) { stop("The prior distribution should be one of ", paste(names(ok_dists), collapse = ", ")) @@ -96,6 +98,14 @@ handle_glm_prior <- function(prior, nvars, default_scale, link, slab_scale <- prior$slab_scale } else if (prior_dist_name %in% "exponential") { prior_dist <- 3L # only used for scale parameters so 3 not a conflict with 3 for hs + } else if (prior_dist_name %in% "dirichlet") { + prior_dist <- 4L # only used by stan_surv for baseline hazard coefficients + prior_concentration <- prior$concentration + if (is.null(prior_concentration)) { + prior_concentration <- rep(1, nvars) + } else { + prior_concentration <- maybe_broadcast(prior_concentration, nvars) + } } prior_df <- maybe_broadcast(prior_df, nvars) @@ -103,7 +113,9 @@ handle_glm_prior <- function(prior, nvars, default_scale, link, prior_mean <- maybe_broadcast(prior_mean, nvars) prior_mean <- as.array(prior_mean) prior_scale <- maybe_broadcast(prior_scale, nvars) - + prior_concentration <- maybe_broadcast(prior_concentration, nvars) + prior_concentration <- as.array(prior_concentration) + nlist(prior_dist, prior_mean, prior_scale, @@ -113,5 +125,6 @@ handle_glm_prior <- function(prior, nvars, default_scale, link, global_prior_df, slab_df, slab_scale, + prior_concentration, prior_autoscale = isTRUE(prior$autoscale)) } From bffeb935d39e20d28d35aac09124eecd01d9cee6 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 22 Nov 2018 14:57:24 +1100 Subject: [PATCH 085/225] Add prior_concentration (for dirichlet) to summarize_jm_prior --- R/jm_data_block.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 04d7863bd..11d041f5a 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -466,7 +466,10 @@ summarize_jm_prior <- adjusted_priorEvent_aux_scale else NULL, df = if (!is.na(prior_dist_name) && prior_dist_name %in% "student_t") - prior_df else NULL, + prior_df else NULL, + concentration = if (!is.na(prior_dist_name) && + prior_dist_name %in% "dirichlet") + prior_concentration else NULL, aux_name = e_aux_name )) } From 33eb7b4d3b59c23743bd195762c5e2c2d23ef51f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 22 Nov 2018 14:57:56 +1100 Subject: [PATCH 086/225] Use dirichlet prior for M-spline coefficients --- R/stan_surv.R | 42 +++++++++++++++++++++++++++++++++++++--- src/stan_files/surv.stan | 5 +++-- 2 files changed, 42 insertions(+), 5 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 5ae13bf58..a1cba5741 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -575,9 +575,12 @@ stan_surv <- function(formula, "laplace", "lasso") # disallow product normal ok_intercept_dists <- ok_dists[1:3] - ok_aux_dists <- ok_dists[1:3] + ok_aux_dists <- get_ok_priors_for_aux(basehaz) ok_smooth_dists <- c(ok_dists[1:3], "exponential") + if (missing(prior_aux)) + prior_aux <- get_default_prior_for_aux(basehaz) + # priors user_prior_stuff <- prior_stuff <- handle_glm_prior(prior, @@ -640,6 +643,7 @@ stan_surv <- function(formula, standata$prior_df_for_intercept <- c(prior_intercept_stuff$prior_df) standata$prior_scale_for_aux <- prior_aux_stuff$prior_scale standata$prior_df_for_aux <- prior_aux_stuff$prior_df + standata$prior_conc_for_aux <- prior_aux_stuff$prior_concentration standata$prior_mean_for_smooth <- prior_smooth_stuff$prior_mean standata$prior_scale_for_smooth <- prior_smooth_stuff$prior_scale standata$prior_df_for_smooth <- prior_smooth_stuff$prior_df @@ -961,7 +965,7 @@ basehaz_for_stan <- function(basehaz_name) { # specified then 'df' is ignored. # @return A numeric vector of internal knot locations, or NULL if there are # no internal knots. -get_iknots <- function(x, df = 6L, degree = 3L, iknots = NULL, intercept = TRUE) { +get_iknots <- function(x, df = 5L, degree = 3L, iknots = NULL, intercept = FALSE) { # obtain number of internal knots if (is.null(iknots)) { @@ -1019,6 +1023,38 @@ get_smooth_name <- function(x, type = "smooth_coefs") { stop2("Bug found: invalid input to 'type' argument.")) } +# Return the valid prior distributions for 'prior_aux'. +# +# @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. +# @return A named list. +get_ok_priors_for_aux <- function(basehaz) { + nm <- get_basehaz_name(basehaz) + switch(nm, + exp = nlist(), + weibull = nlist("normal", student_t = "t", "cauchy", "exponential"), + gompertz = nlist("normal", student_t = "t", "cauchy", "exponential"), + ms = nlist("dirichlet"), + bs = nlist("normal", student_t = "t", "cauchy"), + piecewise = nlist("normal", student_t = "t", "cauchy"), + stop2("Bug found: unknown type of baseline hazard.")) +} + +# Return the default prior distribution for 'prior_aux'. +# +# @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. +# @return A list corresponding to the default prior. +get_default_prior_for_aux <- function(basehaz) { + nm <- get_basehaz_name(basehaz) + switch(nm, + exp = NULL, + weibull = normal(), + gompertz = normal(), + ms = dirichlet(), + bs = normal(), + piecewise = normal(), + stop2("Bug found: unknown type of baseline hazard.")) +} + # Return the default scale parameter for 'prior_aux'. # # @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. @@ -1071,7 +1107,7 @@ make_basis <- function(times, basehaz, integrate = FALSE) { "ms" = basis_matrix(times, basis = basehaz$basis, integrate = integrate), "bs" = basis_matrix(times, basis = basehaz$basis), "piecewise" = dummy_matrix(times, knots = basehaz$knots), - stop2("Bug found: type of baseline hazard unknown.")) + stop2("Bug found: unknown type of baseline hazard.")) } # Evaluate a spline basis matrix at the specified times diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 21f29df71..7110a044b 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -535,6 +535,7 @@ data { // hyperparameters (basehaz pars), set to 0 if there is no prior vector[nvars] prior_scale_for_aux; vector[nvars] prior_df_for_aux; + vector[nvars] prior_conc_for_aux; // dirichlet concentration pars // hyperparameters (tde smooths), set to 0 if there is no prior vector [S > 0 ? max(smooth_map) : 0] prior_mean_for_smooth; @@ -809,8 +810,8 @@ model { // log priors for baseline hazard parameters if (type == 4) { - real dummy = basehaz_lp(ms_coefs[1], prior_dist_for_aux, prior_df_for_aux); - } + real dummy = basehaz_lp(ms_coefs[1], prior_dist_for_aux, prior_conc_for_aux); + } else if (nvars > 0) { real dummy = basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); } From ae16e4d743bf16fe20048ff78356952ab8fc5c28 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 22 Nov 2018 15:44:03 +1100 Subject: [PATCH 087/225] Add exponential rate to summarize_jm_prior function --- R/jm_data_block.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 11d041f5a..596f31422 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -470,6 +470,9 @@ summarize_jm_prior <- concentration = if (!is.na(prior_dist_name) && prior_dist_name %in% "dirichlet") prior_concentration else NULL, + rate = if (!is.na(prior_dist_name) && + prior_dist_name %in% "exponential") + 1 / prior_scale else NULL, aux_name = e_aux_name )) } From dedcf8e3268a59cd0552a72309fbbfdee3bb5a4e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 22 Nov 2018 15:44:56 +1100 Subject: [PATCH 088/225] prior_summary: handle exponential and dirichlet distributions for stan_surv prior_aux --- R/prior_summary.R | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/R/prior_summary.R b/R/prior_summary.R index 49cd8096f..b37144a08 100644 --- a/R/prior_summary.R +++ b/R/prior_summary.R @@ -288,9 +288,9 @@ print.prior_summary.stanreg <- function(x, digits, ...) { if (!is.null(x[["priorEvent_aux"]])) { aux_name <- x[["priorEvent_aux"]][["aux_name"]] aux_dist <- x[["priorEvent_aux"]][["dist"]] - if ((aux_name %in% c("weibull-shape", "gompertz-scale")) && - (aux_dist %in% c("normal", "student_t", "cauchy"))) { # weibull, gompertz - x[["priorEvent_aux"]][["dist"]] <- paste0("half-", aux_dist) + if (aux_name %in% c("weibull-shape", "gompertz-scale")) { + if (aux_dist %in% c("normal", "student_t", "cauchy")) + x[["priorEvent_aux"]][["dist"]] <- paste0("half-", aux_dist) .print_scalar_prior( x[["priorEvent_aux"]], txt = paste0("\nAuxiliary (", aux_name, ")"), @@ -410,8 +410,11 @@ used.sparse <- function(x) { p$df2 <- .format_pars(p$scale, .f1) } else if (p$dist %in% c("hs")) { p$df <- .format_pars(p$df, .f1) - } else if (p$dist %in% c("product_normal")) + } else if (p$dist %in% c("product_normal")) { p$df <- .format_pars(p$df, .f1) + } else if (p$dist %in% c("dirichlet")) { + p$concentration <- .format_pars(p$concentration, .f1) + } } cat(paste0("\n", txt, "\n ~"), if (is.na(p$dist)) { @@ -432,6 +435,8 @@ used.sparse <- function(x) { paste0("hs(df = ", .f1(p$df), ")") } else if (p$dist %in% c("R2")) { paste0("R2(location = ", .f1(p$location), ", what = '", p$what, "')") + } else if (p$dist %in% c("dirichlet")) { + paste0("dirichlet(concentration = ", .f1(p$concentration), ")") }) if (!is.null(p$adjusted_scale)) From f95915c116db70d6b518dd5af794a29dcf670516 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 22 Nov 2018 17:05:17 +1100 Subject: [PATCH 089/225] Update stan_surv documentation and vignette Includes details of the simplex for the M-spline coefficients, the Dirichlet prior for the spline coefficients, and the priors for the new intercept parameter in the spline models. --- R/stan_surv.R | 77 ++++++++++++++++++++++----------------- vignettes/surv.Rmd | 89 ++++++++++++++++++++++++++++------------------ 2 files changed, 98 insertions(+), 68 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index a1cba5741..fab672282 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -82,15 +82,13 @@ #' hazard. Currently this can include: \cr #' \itemize{ #' \item \code{df}: a positive integer specifying the degrees of freedom -#' for the M-splines or B-splines. An intercept is included in the spline -#' basis and included in the count of the degrees of freedom, such that -#' two boundary knots and \code{df - 4} internal knots are used to generate -#' the cubic spline basis. The default is \code{df = 6}; that is, two -#' boundary knots and two internal knots. +#' for the M-splines or B-splines. Two boundary knots and \code{df - 3} +#' internal knots are used to generate the cubic spline basis. The default +#' is \code{df = 5}; that is, two boundary knots and two internal knots. #' \item \code{knots}: An optional numeric vector specifying internal #' knot locations for the M-splines or B-splines. Note that \code{knots} #' cannot be specified if \code{df} is specified. If \code{knots} are -#' \strong{not} specified, then \code{df - 4} internal knots are placed +#' \strong{not} specified, then \code{df - 3} internal knots are placed #' at equally spaced percentiles of the distribution of uncensored event #' times. #' } @@ -103,53 +101,66 @@ #' that is used to evaluate the cumulative hazard when \code{basehaz = "bs"} #' or when time-dependent effects (i.e. non-proportional hazards) are #' specified. Options are 15 (the default), 11 or 7. -#' @param prior_intercept The prior distribution for the intercept. -#' All models include an intercept parameter. -#' If \code{basehaz} is set equal to one of the standard parametric -#' distributions, i.e. \code{"exp"}, \code{"weibull"} or \code{"gompertz"}, -#' then the intercept corresponds to the parameter \emph{log(lambda)} as -#' defined in the \emph{stan_surv: Survival (Time-to-Event) Models} vignette. -#' Also refer to the vignette for the definition of the intercept parameter -#' in the cubic spline-based baseline hazards. -#' -#' Where relevant, \code{prior_intercept} can be a call to \code{normal}, +#' @param prior_intercept The prior distribution for the intercept in the +#' linear predictor. All models include an intercept parameter. +#' \code{prior_intercept} can be a call to \code{normal}, #' \code{student_t} or \code{cauchy}. See the \link[=priors]{priors help page} -#' for details on these functions. Note however that default scale for +#' for details on these functions. However, note that default scale for #' \code{prior_intercept} is 20 for \code{stan_surv} models (rather than 10, #' which is the default scale used for \code{prior_intercept} by most #' \pkg{rstanarm} modelling functions). To omit a prior on the intercept #' ---i.e., to use a flat (improper) uniform prior--- \code{prior_intercept} #' can be set to \code{NULL}. +#' +#' \strong{Note:} The prior distribution for the intercept is set so it +#' applies to the value \emph{when all predictors are centered} and with an +#' adjustment (i.e. "constant shift") equal to the \emph{log crude event rate}. +#' However, the reported \emph{estimates} for the intercept always correspond +#' to a parameterization without centered predictors and without the +#' "constant shift". That is, these adjustments are made internally to help +#' with numerical stability and sampling, but the necessary +#' back-transformations are made so that they are not relevant for the +#' estimates returned to the user. #' @param prior_aux The prior distribution for "auxiliary" parameters related to #' the baseline hazard. The relevant parameters differ depending #' on the type of baseline hazard specified in the \code{basehaz} -#' argument. The following applies: +#' argument. The following applies (however, for further technical details, +#' refer to the \emph{stan_surv: Survival (Time-to-Event) Models vignette)}: #' \itemize{ -#' \item \code{basehaz = "ms"}: the auxiliary parameters are the coefficients -#' for the M-spline basis terms on the baseline hazard. These parameters -#' have a lower bound at zero. The prior specified by the user is for the -#' coefficients as defined on the postive real line. However, to ensure -#' identifiability of the model, these are transformed to constrained -#' parameters between 0 and 1 (forming a simplex) during the fitting of -#' the model. Refer to the \emph{stan_surv: Survival (Time-to-Event) Models} -#' vignette for further technical details. -#' \item \code{basehaz = "bs"}: the auxiliary parameters are the coefficients -#' for the B-spline basis terms on the log baseline hazard. These parameters -#' are unbounded. +#' \item \code{basehaz = "ms"}: the auxiliary parameters are the +#' coefficients for the M-spline basis terms on the baseline hazard. +#' These coefficients are defined using a simplex; that is, they are +#' all between 0 and 1, and constrained to sum to 1. This constraint +#' is necessary for identifiability of the intercept in the linear +#' predictor. The default prior is a Dirichlet distribution with all +#' concentration parameters set equal to 1. That is, a uniform +#' prior over all points defined within the support of the simplex. +#' Specifying all concentration parameters equal and > 1 supports a more +#' even distribution (i.e. a smoother spline function), while specifying a +#' all concentration parameters equal and < 1 supports a more sparse +#' distribution (i.e. a less smooth spline function). +#' \item \code{basehaz = "bs"}: the auxiliary parameters are the +#' coefficients for the B-spline basis terms on the log baseline hazard. +#' These parameters are unbounded. The default prior is a normal +#' distribution with mean 0 and scale 20. #' \item \code{basehaz = "exp"}: there is \strong{no} auxiliary parameter, #' since the log scale parameter for the exponential distribution is #' incorporated as an intercept in the linear predictor. #' \item \code{basehaz = "weibull"}: the auxiliary parameter is the Weibull #' shape parameter, while the log scale parameter for the Weibull #' distribution is incorporated as an intercept in the linear predictor. -#' The auxiliary parameter has a lower bound at zero. +#' The auxiliary parameter has a lower bound at zero. The default prior is +#' a half-normal distribution with mean 0 and scale 2. #' \item \code{basehaz = "gompertz"}: the auxiliary parameter is the Gompertz #' scale parameter, while the log shape parameter for the Gompertz #' distribution is incorporated as an intercept in the linear predictor. -#' The auxiliary parameter has a lower bound at zero. +#' The auxiliary parameter has a lower bound at zero. The default prior is +#' a half-normal distribution with mean 0 and scale 2. #' } -#' Currently, \code{prior_aux} can be a call to \code{normal}, \code{student_t} -#' or \code{cauchy}. See \code{\link{priors}} for details on these functions. +#' Currently, \code{prior_aux} can be a call to \code{dirichlet}, +#' \code{normal}, \code{student_t}, \code{cauchy} or \code{exponential}. +#' See \code{\link{priors}} for details on these functions. Note that not +#' all prior distributions are allowed with all types of baseline hazard. #' To omit a prior ---i.e., to use a flat (improper) uniform prior--- set #' \code{prior_aux} to \code{NULL}. #' @param prior_smooth This is only relevant when time-dependent effects are diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 6d78168a3..fbd276518 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -124,71 +124,83 @@ h_i(t) = h_0(t) \exp \left[ \eta_i(t) \right] \end{split} \end{equation} \ -where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the (possibly time-dependent) linear predictor evaluated for individual $i$ at time $t$. +where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the (possibly time-dependent) linear predictor evaluated for individual $i$ at time $t$. All models defined below include an intercept parameter in the linear predictor We further define the baseline hazard and linear predictor in the next sections. +### Linear predictor + +The effects of covariates are introduced through the linear predictor under proportional or non-proportional hazards assumptions. That is, we define our linear predictor as +\ +\begin{equation} +\begin{split} +\eta_i(t) = \beta_0 + \boldsymbol{X_i^T(t)} \boldsymbol{\beta(t)} +\end{split} +\end{equation} +\ +where $\beta_0$ is an intercept parameter, $\boldsymbol{X_i^T(t)}$ is a vector of covariates (possibly time-varying) for individual $i$, and $\boldsymbol{\beta(t)} = \{ \beta_p(t); p = 1,...,P \}$ is a vector of parameters with each element defined as +\ +\begin{align} +\beta_p(t) = + \begin{cases} + \theta_{p,0} + & \text{for proportional hazards} \\ + \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) + & \text{for non-proportional hazards} + \end{cases} +\end{align} +\ +such that $\theta_{p,0}$ is a time-fixed hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent hazard ratio as a smooth function of time. + +In the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent hazard ratio for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. + ### Baseline hazard -The `stan_surv` modelling function, via its `basehaz` argument, allows the baseline hazard $h_0(t)$ to be specified using any of the following parametric formulations. +The `stan_surv` modelling function, via its `basehaz` argument, allows the baseline hazard $h_0(t)$ to be specified using any of the following parametric formulations. Since the intercept parameter from the linear predictor (i.e. $\beta_0$) effectively forms part of the baseline hazard, we include it in the definitions of the baseline hazards below. - **Exponential distribution**: for scale parameter $\lambda > 0$ we have \begin{equation} -h_0(t) = \lambda +h_0(t) = 1 +\end{equation} + +\begin{equation} +\beta_0 = \log \lambda \end{equation} - **Weibull distribution**: for scale parameter $\lambda > 0$ and shape parameter $\gamma > 0$ we have \begin{equation} -h_0(t) = \gamma t^{\gamma-1} \lambda +h_0(t) = \gamma t^{\gamma-1} +\end{equation} + +\begin{equation} +\beta_0 = \log \lambda \end{equation} - **Gompertz distribution**: for shape parameter $\lambda > 0$ and scale parameter $\gamma > 0$ we have \begin{equation} -h_0(t) = \exp(\gamma t) \lambda +h_0(t) = \exp(\gamma t) \end{equation} -- **M-splines**, the default: letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have - \begin{equation} -h_0(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +\beta_0 = \log \lambda \end{equation} -- **B-splines** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have +- **M-splines**, the default: letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have \begin{equation} -\log h_0(t) = B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +h_0(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) \end{equation} -Note that for the exponential, Weibull, and Gompertz baseline hazards, $\log \lambda$ is absorbed as an intercept term in the linear predictor $\eta_i(t)$. It is therefore shown as such in the output for `stan_surv`. +For identifiability of the intercept $\beta_0$ in the linear predictor $\eta_i$ we constrain the M-spline coefficients to a simplex, that is, $\sum_{j=1}^J{\gamma_j} = 1$. -### Linear predictor +- **B-splines** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have -The effects of covariates are introduced through the linear predictor under proportional or non-proportional hazards assumptions. That is, we define our linear predictor as -\ \begin{equation} -\begin{split} -\eta_i(t) = \boldsymbol{X_i^T(t)} \boldsymbol{\beta(t)} -\end{split} +\log h_0(t) = B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) \end{equation} -\ -where $\boldsymbol{X_i^T(t)}$ is a vector of covariates (possibly time-varying) for individual $i$, and $\boldsymbol{\beta(t)} = \{ \beta_p(t); p = 1,...,P \}$ is a vector of parameters with each element defined as -\ -\begin{align} -\beta_p(t) = - \begin{cases} - \theta_{p,0} - & \text{for proportional hazards} \\ - \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) - & \text{for non-proportional hazards} - \end{cases} -\end{align} -\ -such that $\theta_{p,0}$ is a time-fixed hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent hazard ratio as a smooth function of time. - -In the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent hazard ratio for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. ## Likelihood @@ -207,9 +219,16 @@ p(\mathcal{D}_i | \boldsymbol{\gamma}, \boldsymbol{\beta}) = ## Priors -The prior distribution for the baseline hazard parameters (i.e. $\gamma$ for Weibull or Gompertz baseline hazards, or $\boldsymbol{\gamma}$ for the M-spline or B-spline baseline hazards) is specified via the `prior_aux` argument to `stan_surv`. Choices of prior distribution include half-normal, half-t or half-Cauchy for the Weibull, Gompertz and M-spline baseline hazards, or normal, t, or Cauchy for the B-splines log baseline hazard. These choices are described in greater detail in the `stan_surv` help file. +The prior distribution for the baseline hazard parameters (i.e. $\gamma$ for Weibull or Gompertz baseline hazards, or $\boldsymbol{\gamma}$ for the M-spline or B-spline baseline hazards) is specified via the `prior_aux` argument to `stan_surv`. Choices of prior distribution include: + +- a Dirichlet prior is allowed for the M-spline coefficients $\boldsymbol{\gamma}$ +- a half-normal, half-t, half-Cauchy or exponential prior is allowed for the Weibull shape parameter $\gamma$ +- a half-normal, half-t, half-Cauchy or exponential prior is allowed for the Gompertz scale parameter $\gamma$ +- a normal, t, or Cauchy prior is allowed for the B-spline coefficients $\boldsymbol{\gamma}$ + +These choices are described in greater detail in the `stan_surv` or `priors` help file. -For the exponential, Weibull, or Gompertz baseline hazards the prior distribution for the intercept parameter in the linear predictor, that is $\log \lambda$, is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. +The prior distribution for the intercept parameter in the linear predictor, i.e. $\beta_0$, is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. The default is a normal distribution with mean zero and scale 20. Note that -- internally (but not in the reported parameter estimates) -- the prior is placed on the intercept *after* centering the predictors at their sample means and *after* applying a constant shift of $\log \left( \frac{E}{T} \right)$ where $E$ is the total number of events and $T$ is the total follow up time. For example, a prior specified by the user as `prior_intercept = normal(0,20)` is in fact not centered on an intercept of zero when all predictors are at their sample means, but rather, it is centered on the log crude event rate when all predictors are at their means. This helps with numerical stability and sampling, but does not impact on the reported estimates (i.e. the intercept is back-transformed before being returned to the user). The choice of prior distribution for the time-fixed hazard ratios $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. From 7734e302551ad1d34f4420122936094ce09c1a06 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 23 Nov 2018 12:43:01 +1100 Subject: [PATCH 090/225] Update vignette to align with an intercept being included in the spline baseline hazards --- vignettes/surv.Rmd | 34 +++++++++++++++++++++------------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index fbd276518..ef230a6f4 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -124,9 +124,9 @@ h_i(t) = h_0(t) \exp \left[ \eta_i(t) \right] \end{split} \end{equation} \ -where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the (possibly time-dependent) linear predictor evaluated for individual $i$ at time $t$. All models defined below include an intercept parameter in the linear predictor +where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the (possibly time-dependent) linear predictor evaluated for individual $i$ at time $t$. -We further define the baseline hazard and linear predictor in the next sections. +We further define the baseline hazard and linear predictor in the following sections. ### Linear predictor @@ -158,6 +158,18 @@ In the `stan_surv` modelling function the user specifies that they wish to estim The `stan_surv` modelling function, via its `basehaz` argument, allows the baseline hazard $h_0(t)$ to be specified using any of the following parametric formulations. Since the intercept parameter from the linear predictor (i.e. $\beta_0$) effectively forms part of the baseline hazard, we include it in the definitions of the baseline hazards below. +- **M-splines**, the default: letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$, and parameter $\lambda > 0$ denote a constant, we have + +\begin{equation} +h_0(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +\end{equation} + +\begin{equation} +\beta_0 = \log \lambda +\end{equation} + + For identifiability of the intercept $\beta_0$ in the linear predictor $\eta_i$ we constrain the M-spline coefficients to a simplex, that is, $\sum_{j=1}^J{\gamma_j} = 1$. + - **Exponential distribution**: for scale parameter $\lambda > 0$ we have \begin{equation} @@ -188,18 +200,14 @@ h_0(t) = \exp(\gamma t) \beta_0 = \log \lambda \end{equation} -- **M-splines**, the default: letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have +- **B-splines** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$, and parameter $\lambda > 0$ denote a constant, we have \begin{equation} -h_0(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +\log h_0(t) = B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) \end{equation} -For identifiability of the intercept $\beta_0$ in the linear predictor $\eta_i$ we constrain the M-spline coefficients to a simplex, that is, $\sum_{j=1}^J{\gamma_j} = 1$. - -- **B-splines** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have - \begin{equation} -\log h_0(t) = B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +\beta_0 = \log \lambda \end{equation} ## Likelihood @@ -228,7 +236,7 @@ The prior distribution for the baseline hazard parameters (i.e. $\gamma$ for Wei These choices are described in greater detail in the `stan_surv` or `priors` help file. -The prior distribution for the intercept parameter in the linear predictor, i.e. $\beta_0$, is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. The default is a normal distribution with mean zero and scale 20. Note that -- internally (but not in the reported parameter estimates) -- the prior is placed on the intercept *after* centering the predictors at their sample means and *after* applying a constant shift of $\log \left( \frac{E}{T} \right)$ where $E$ is the total number of events and $T$ is the total follow up time. For example, a prior specified by the user as `prior_intercept = normal(0,20)` is in fact not centered on an intercept of zero when all predictors are at their sample means, but rather, it is centered on the log crude event rate when all predictors are at their means. This helps with numerical stability and sampling, but does not impact on the reported estimates (i.e. the intercept is back-transformed before being returned to the user). +The prior distribution for the intercept parameter in the linear predictor, i.e. $\beta_0 = \log \lambda$, is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. The default is a normal distribution with mean zero and scale 20. Note that -- internally (but not in the reported parameter estimates) -- the prior is placed on the intercept *after* centering the predictors at their sample means and *after* applying a constant shift of $\log \left( \frac{E}{T} \right)$ where $E$ is the total number of events and $T$ is the total follow up time. For example, a prior specified by the user as `prior_intercept = normal(0,20)` is in fact not centered on an intercept of zero when all predictors are at their sample means, but rather, it is centered on the log crude event rate when all predictors are at their means. This is intended to help with numerical stability and sampling, but does not impact on the reported estimates (i.e. the intercept is back-transformed before being returned to the user). The choice of prior distribution for the time-fixed hazard ratios $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. @@ -257,7 +265,7 @@ We can easily obtain the estimated hazard ratios for the 3-catgeory group covari print(mod1, digits = 3) ``` -We see from this output we see that individuals in the groups with `Poor` or `Medium` prognosis have much higher rates of death relative to the group with `Good` prognosis (as we might expect!). The hazard of death in the `Poor` prognosis group is approximately 4.6-fold higher than the hazard of death in the `Good` prognosis group. Similarly, the hazard of death in the `Medium` prognosis group is approximately 2.1-fold higher than the hazard of death in the `Good` prognosis group. +We see from this output we see that individuals in the groups with `Poor` or `Medium` prognosis have much higher rates of death relative to the group with `Good` prognosis (as we might expect!). The hazard of death in the `Poor` prognosis group is approximately 5.0-fold higher than the hazard of death in the `Good` prognosis group. Similarly, the hazard of death in the `Medium` prognosis group is approximately 2.3-fold higher than the hazard of death in the `Good` prognosis group. It may also be of interest to compare the different types of the baseline hazard we could potentially use. Here, we will fit a series of models, each with a different baseline hazard specification @@ -310,7 +318,7 @@ compare_models(loo(mod1_exp), loo(mod1_mspline2)) ``` -where we see that models with a flexible parametric (spline-based) baseline hazard fit the data best followed by the standard parametric (Weibull, Gompertz, exponential) models. Specifically, B-splines used to approximate the log baseline hazard appear to perform best, followed by the M-spline model with a greater number of degrees of freedom for the M-splines leading to a marginally better fit. However, overall, the differences in `elpd` or `looic` between models are small relative to their standard errors. +where we see that models with a flexible parametric (spline-based) baseline hazard fit the data best followed by the standard parametric (Weibull, Gompertz, exponential) models. Roughly speaking, the B-spline and M-spline models seem to fit the data equally well since the differences in `elpd` or `looic` between the models are very small relative to their standard errors. Moreover, increasing the degrees of freedom for the M-splines from 5 to 10 doesn't seem to improve the fit (that is, the default degrees of freedom `df = 5` seems to provide sufficient flexibility to model the baseline hazard). used to approximate the log baseline hazard appear to perform best, followed by the M-spline model with a greater number of degrees of freedom for the M-splines leading to a marginally better fit. However, overall, After fitting the survival model, we often want to estimate the predicted survival function for individual's with different covariate patterns. Here, let us estimate the predicted survival function between 0 and 5 years for an individual in each of the prognostic groups. To do this, we can use the `posterior_survfit` method for `stansurv` objects, and it's associated `plot` method. First let us construct the prediction (covariate) data @@ -414,7 +422,7 @@ plot(mod2, plotfun = "tde") From the plot, we can see how the hazard ratio (i.e. the effect of treatment on the hazard of the event) changes as a function of time. The treatment appears to be protective during the first few years following baseline (i.e. HR < 1), and then the treatment appears to become harmful after about 4 years post-baseline (of course, this is the model we simulated under!). -The plot shows a large amount of uncertainty around the estimated time-dependent hazard ratio. This is to be expected, since we only simulated a dataset of 100 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-dependent hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-dependent hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-dependent hazard ratio equals 1 at around ~4 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. +The plot shows a large amount of uncertainty around the estimated time-dependent hazard ratio. This is to be expected, since we only simulated a dataset of 100 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-dependent hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-dependent hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-dependent hazard ratio equals 1 at around ~3 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. # References From 0368582cc1c5063663955068ded1d3a8d329b95d Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 23 Nov 2018 13:04:50 +1100 Subject: [PATCH 091/225] Fix type in stan_surv vignette --- vignettes/surv.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index ef230a6f4..c61035207 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -318,7 +318,7 @@ compare_models(loo(mod1_exp), loo(mod1_mspline2)) ``` -where we see that models with a flexible parametric (spline-based) baseline hazard fit the data best followed by the standard parametric (Weibull, Gompertz, exponential) models. Roughly speaking, the B-spline and M-spline models seem to fit the data equally well since the differences in `elpd` or `looic` between the models are very small relative to their standard errors. Moreover, increasing the degrees of freedom for the M-splines from 5 to 10 doesn't seem to improve the fit (that is, the default degrees of freedom `df = 5` seems to provide sufficient flexibility to model the baseline hazard). used to approximate the log baseline hazard appear to perform best, followed by the M-spline model with a greater number of degrees of freedom for the M-splines leading to a marginally better fit. However, overall, +where we see that models with a flexible parametric (spline-based) baseline hazard fit the data best followed by the standard parametric (Weibull, Gompertz, exponential) models. Roughly speaking, the B-spline and M-spline models seem to fit the data equally well since the differences in `elpd` or `looic` between the models are very small relative to their standard errors. Moreover, increasing the degrees of freedom for the M-splines from 5 to 10 doesn't seem to improve the fit (that is, the default degrees of freedom `df = 5` seems to provide sufficient flexibility to model the baseline hazard). After fitting the survival model, we often want to estimate the predicted survival function for individual's with different covariate patterns. Here, let us estimate the predicted survival function between 0 and 5 years for an individual in each of the prognostic groups. To do this, we can use the `posterior_survfit` method for `stansurv` objects, and it's associated `plot` method. First let us construct the prediction (covariate) data From 937d853e15e75529c00b41dfe3625e993b51e5be Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 23 Nov 2018 17:44:11 +1100 Subject: [PATCH 092/225] Add AFT models to stan_surv --- R/log_lik.R | 58 +++- R/misc.R | 14 +- R/plots.R | 4 +- R/print-and-summary.R | 14 +- R/stan_surv.R | 271 +++++++++--------- .../functions/hazard_functions.stan | 24 ++ src/stan_files/surv.stan | 87 +++++- 7 files changed, 313 insertions(+), 159 deletions(-) diff --git a/R/log_lik.R b/R/log_lik.R index 9d4ea9dd9..be7b7abc0 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -613,6 +613,10 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) eta <- eta + linear_predictor(draws$beta_tde, .sdata_surv(data_i)) + eta <- switch(get_basehaz_name(draws$basehaz), + "exp-aft" = sweep(eta, 1L, -1, `*`), + "weibull-aft" = sweep(eta, 1L, -as.vector(draws$aux), `*`), + eta) lhaz <- eta + do.call(evaluate_log_basehaz, args) if (status == 1) { @@ -668,7 +672,11 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { intercept = draws$alpha) eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) - + eta <- switch(get_basehaz_name(draws$basehaz), + "exp-aft" = sweep(eta, 1L, -1, `*`), + "weibull-aft" = sweep(eta, 1L, -as.vector(draws$aux), `*`), + eta) + if (status == 1) { # uncensored args$times <- data_i$t_end @@ -1095,21 +1103,29 @@ evaluate_log_survival.matrix <- function(log_haz, qnodes, qwts) { # @return A vector or matrix, depending on the input type of aux. evaluate_log_basehaz <- function(times, basehaz, aux, intercept = NULL) { switch(get_basehaz_name(basehaz), - "exp" = log_basehaz_exponential(times, log_scale = intercept), - "weibull" = log_basehaz_weibull (times, shape = aux, log_scale = intercept), - "gompertz" = log_basehaz_gompertz(times, scale = aux, log_shape = intercept), - "ms" = log_basehaz_ms(times, coefs = aux, basis = basehaz$basis), - "bs" = log_basehaz_bs(times, coefs = aux, basis = basehaz$basis), - "piecewise" = log_basehaz_pw(times, coefs = aux, knots = basehaz$knots), + "exp" = log_basehaz_exponential (times, log_scale = intercept), + "exp-aft" = log_basehaz_exponentialAFT(times, log_scale = intercept), + "weibull" = log_basehaz_weibull (times, shape = aux, log_scale = intercept), + "weibull-aft" = log_basehaz_weibullAFT(times, shape = aux, log_scale = intercept), + "gompertz" = log_basehaz_gompertz(times, scale = aux, log_shape = intercept), + "ms" = log_basehaz_ms(times, coefs = aux, basis = basehaz$basis), + "bs" = log_basehaz_bs(times, coefs = aux, basis = basehaz$basis), + "piecewise" = log_basehaz_pw(times, coefs = aux, knots = basehaz$knots), stop2("Bug found: unknown type of baseline hazard.")) } log_basehaz_exponential <- function(x, log_scale) { linear_predictor(log_scale, rep(1, length(x))) } +log_basehaz_exponentialAFT <- function(x, log_scale) { + linear_predictor(-log_scale, rep(1, length(x))) +} log_basehaz_weibull <- function(x, shape, log_scale) { as.vector(log_scale + log(shape)) + linear_predictor(shape - 1, log(x)) } +log_basehaz_weibullAFT <- function(x, shape, log_scale) { + as.vector(-log_scale * shape + log(shape)) + linear_predictor(shape - 1, log(x)) +} log_basehaz_gompertz <- function(x, scale, log_shape) { as.vector(log_shape) + linear_predictor(scale, x) } @@ -1128,6 +1144,10 @@ evaluate_log_haz <- function(times, basehaz, betas, betas_tde, aux, eta <- linear_predictor(betas, x) if ((!is.null(s)) && ncol(s)) eta <- eta + linear_predictor(betas_tde, s) + eta <- switch(get_basehaz_name(basehaz), + "exp-aft" = sweep(eta, 1L, -1, `*`), + "weibull-aft" = sweep(eta, 1L, -as.vector(aux), `*`), + eta) args <- nlist(times, basehaz, aux, intercept) do.call(evaluate_log_basehaz, args) + eta } @@ -1148,19 +1168,27 @@ evaluate_basehaz <- function(times, basehaz, aux, intercept = NULL) { # @return A vector or matrix, depending on the input type of aux. evaluate_log_basesurv <- function(times, basehaz, aux, intercept = NULL) { switch(get_basehaz_name(basehaz), - "exp" = log_basesurv_exponential(times, log_scale = intercept), - "weibull" = log_basesurv_weibull (times, shape = aux, log_scale = intercept), - "gompertz" = log_basesurv_gompertz(times, scale = aux, log_shape = intercept), - "ms" = log_basesurv_ms(times, coefs = aux, basis = basehaz$basis), + "exp" = log_basesurv_exponential (times, log_scale = intercept), + "exp-aft" = log_basesurv_exponentialAFT(times, log_scale = intercept), + "weibull" = log_basesurv_weibull (times, shape = aux, log_scale = intercept), + "weibull-aft" = log_basesurv_weibullAFT(times, shape = aux, log_scale = intercept), + "gompertz" = log_basesurv_gompertz(times, scale = aux, log_shape = intercept), + "ms" = log_basesurv_ms(times, coefs = aux, basis = basehaz$basis), stop2("Bug found: unknown type of baseline hazard.")) } log_basesurv_exponential <- function(x, log_scale) { -linear_predictor(exp(log_scale), x) } -log_basesurv_weibull <- function(x, shape, log_scale) { +log_basesurv_exponentialAFT <- function(x, log_scale) { + -linear_predictor(exp(-log_scale), x) +} +log_basesurv_weibull <- function(x, shape, log_scale) { -exp(as.vector(log_scale) + linear_predictor(shape, log(x))) } +log_basesurv_weibullAFT <- function(x, shape, log_scale) { + -exp(as.vector(-shape * log_scale) + linear_predictor(shape, log(x))) +} log_basesurv_gompertz <- function(x, scale, log_shape) { -(as.vector(exp(log_shape) / scale)) * (exp(linear_predictor(scale, x)) - 1) } @@ -1170,7 +1198,11 @@ log_basesurv_ms <- function(x, coefs, basis) { evaluate_log_surv <- function(times, basehaz, betas, aux, intercept = NULL, x, ...) { eta <- linear_predictor(betas, x) - args <- nlist(times, basehaz, aux, intercept) + eta <- switch(get_basehaz_name(basehaz), + "exp-aft" = sweep(eta, 1L, -1, `*`), + "weibull-aft" = sweep(eta, 1L, -as.vector(aux), `*`), + eta) + args <- nlist(times, basehaz, aux, intercept) do.call(evaluate_log_basesurv, args) * exp(eta) } diff --git a/R/misc.R b/R/misc.R index 76cf18fa8..1ba15b7fd 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1899,12 +1899,14 @@ get_int_name_emod <- function(x, is_jm = FALSE, ...) { # Return the names for the auxiliary parameters get_aux_name_basehaz <- function(x, ...) { switch(get_basehaz_name(x), - exp = NULL, - weibull = "weibull-shape", - gompertz = "gompertz-scale", - ms = paste0("m-splines-coef", seq(x$nvars)), - bs = paste0("b-splines-coef", seq(x$nvars)), - piecewise = paste0("piecewise-coef", seq(x$nvars)), + "exp" = NULL, + "exp-aft" = NULL, + "weibull" = "weibull-shape", + "weibull-aft" = "weibull-shape", + "gompertz" = "gompertz-scale", + "ms" = paste0("m-splines-coef", seq(x$nvars)), + "bs" = paste0("b-splines-coef", seq(x$nvars)), + "piecewise" = paste0("piecewise-coef", seq(x$nvars)), NA) } get_aux_name_ymod <- function(x, ...) { diff --git a/R/plots.R b/R/plots.R index ccc7865eb..ae9a4813a 100644 --- a/R/plots.R +++ b/R/plots.R @@ -260,7 +260,9 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, plotdat <- median_and_bounds(exp(log_hr), prob, na.rm = TRUE) plotdat <- data.frame(times, plotdat) - ylab <- "Hazard ratio" + is_aft <- get_basehaz_name(x$basehaz) %in% c("exp-aft", "weibull-aft") + + ylab <- ifelse(is_aft, "Acceleration factor", "Hazard ratio") xlab <- "Time" } diff --git a/R/print-and-summary.R b/R/print-and-summary.R index 2fb250ea6..58f9860e6 100644 --- a/R/print-and-summary.R +++ b/R/print-and-summary.R @@ -803,12 +803,14 @@ print_anova_table <- function(x, digits, ...) { basehaz_string <- function(basehaz, break_and_indent = TRUE) { nm <- get_basehaz_name(basehaz) switch(nm, - exp = "exponential", - weibull = "weibull", - gompertz = "gompertz", - ms = "M-splines on hazard scale", - bs = "B-splines on log hazard scale", - piecewise= "piecewise constant on log hazard scale", + "exp" = "exponential", + "exp-aft" = "exponential, aft parameterisation", + "weibull" = "weibull", + "weibull-aft" = "weibull, aft parameterisation", + "gompertz" = "gompertz", + "ms" = "M-splines on hazard scale", + "bs" = "B-splines on log hazard scale", + "piecewise" = "piecewise constant on log hazard scale", NULL) } diff --git a/R/stan_surv.R b/R/stan_surv.R index 8f66d8dd0..8cbd2be15 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -44,16 +44,18 @@ #' are allowed, as well as delayed entry (i.e. left truncation). See #' \code{\link[survival]{Surv}} for how to specify these outcome types. #' If you wish to include time-dependent effects (i.e. time-dependent -#' coefficients, also known as non-proportional hazards) in the model +#' coefficients, e.g. non-proportional hazards) in the model #' then any covariate(s) that you wish to estimate a time-dependent -#' coefficient for should be specified as \code{tde(varname)} where +#' coefficient for should be specified as \code{tde(varname)} where #' \code{varname} is the name of the covariate. See the \strong{Details} #' section for more information on how the time-dependent effects are #' formulated, as well as the \strong{Examples} section. #' @param data A data frame containing the variables specified in #' \code{formula}. -#' @param basehaz A character string indicating which baseline hazard to use -#' for the event submodel. Current options are: +#' @param basehaz A character string indicating which baseline hazard or +#' baseline survival distribution to use for the event submodel. +#' +#' The following are available under a proportional hazards formulation: #' \itemize{ #' \item \code{"ms"}: a flexible parametric model using cubic M-splines to #' model the baseline hazard. The default locations for the internal knots, @@ -73,10 +75,16 @@ #' the cumulative hazard at each MCMC iteration. Therefore, if your model #' does not include any time-dependent effects, then estimation using the #' \code{"ms"} baseline hazard will be faster. -#' \item \code{"exp"}: an exponential distribution for the event times. -#' (i.e. a constant baseline hazard) +#' \item \code{"exp"}: an exponential distribution for the event times +#' (i.e. a constant baseline hazard). #' \item \code{"weibull"}: a Weibull distribution for the event times. #' \item \code{"gompertz"}: a Gompertz distribution for the event times. +#' } +#' and the following are available under an accelerated failure time (AFT) +#' formulation: +#' \itemize{ +#' \item \code{"exp-aft"}: an exponential distribution for the event times. +#' \item \code{"weibull-aft"}: a Weibull distribution for the event times. #' } #' @param basehaz_ops A named list specifying options related to the baseline #' hazard. Currently this can include: \cr @@ -106,12 +114,13 @@ #' @param prior_intercept The prior distribution for the intercept. Note #' that there will only be an intercept parameter when \code{basehaz} is set #' equal to one of the standard parametric distributions, i.e. \code{"exp"}, -#' \code{"weibull"} or \code{"gompertz"}, in which case the intercept -#' corresponds to the parameter \emph{log(lambda)} as defined in the -#' \emph{stan_surv: Survival (Time-to-Event) Models} vignette. For the cubic -#' spline-based baseline hazards there is no intercept parameter since it is -#' absorbed into the spline basis and, therefore, the prior for the intercept -#' is effectively specified as part of \code{prior_aux}. +#' \code{"weibull"}, \code{"gompertz"}, \code{"exp-aft"}, or +#' \code{"weibull-aft"}. See the \emph{stan_surv: Survival (Time-to-Event) +#' Models} vignette for technical details on the model formulation. +#' +#' For the spline-based baseline hazards there is no intercept parameter since +#' it is absorbed into the spline basis and, therefore, the prior for the +#' intercept is effectively specified as part of \code{prior_aux}. #' #' Where relevant, \code{prior_intercept} can be a call to \code{normal}, #' \code{student_t} or \code{cauchy}. See the \link[=priors]{priors help page} @@ -132,10 +141,12 @@ #' \item \code{basehaz = "bs"}: the auxiliary parameters are the coefficients #' for the B-spline basis terms on the log baseline hazard. These parameters #' are unbounded. -#' \item \code{basehaz = "exp"}: there is \strong{no} auxiliary parameter, +#' \item \code{basehaz = "exp"} or \code{basehaz = "exp-aft"}: +#' there is \strong{no} auxiliary parameter, #' since the log scale parameter for the exponential distribution is #' incorporated as an intercept in the linear predictor. -#' \item \code{basehaz = "weibull"}: the auxiliary parameter is the Weibull +#' \item \code{basehaz = "weibull"} or \code{basehaz = "weibull-aft"}: +#' the auxiliary parameter is the Weibull #' shape parameter, while the log scale parameter for the Weibull #' distribution is incorporated as an intercept in the linear predictor. #' The auxiliary parameter has a lower bound at zero. @@ -168,9 +179,22 @@ #' @details #' \subsection{Time dependent effects (i.e. non-proportional hazards)}{ #' By default, any covariate effects specified in the \code{formula} are -#' included in the model under a proportional hazards assumption. To relax -#' this assumption, it is possible to estimate a time-dependent coefficient -#' for a given covariate. This can be specified in the model \code{formula} +#' included in the model under a proportional hazards assumption (or for the +#' exponential and Weibull AFT models, under the assumption of time-fixed +#' acceleration factors). To relax this assumption, it is possible to +#' estimate a time-dependent coefficient for a given covariate. +#' +#' Estimating a time-dependent coefficient under a hazards model +#' formulation (i.e. when \code{basehaz} is set equal to \code{"ms"}, +#' \code{"bs"}, \code{"exp"}, \code{"weibull"} or \code{"gompertz"}) leads +#' to the estimation of a time-dependent hazard ratio for the relevant +#' covariate (i.e. non-proportional hazards). Conversely, estimating a +#' time-dependent coefficient under an accelerated failure time model +#' formulation (i.e. when \code{basehaz} is set equal to \code{"exp-aft"}, +#' or \code{"weibull-aft"}) leads to the estimation of a time-dependent +#' acceleration factor for the relevant covariate. +#' +#' A time-dependent effect can be specified in the model \code{formula} #' by wrapping the covariate name in the \code{tde()} function (note that #' this function is not an exported function, rather it is an internal function #' that can only be evaluated within the formula of a \code{stan_surv} call). @@ -234,7 +258,7 @@ #' plot(m1c), #' plot(m1d), #' ylim = c(0, 0.8)) -#' +#' #' #---------- Left and right censored data #' #' # Mice tumor data @@ -259,12 +283,36 @@ #' data = d3, chains = 1, refresh = 0, iter = 600) #' print(m3, 4) #' plot(m3, "tde") # time-dependent hazard ratio +#' +#' #---------- Compare PH and AFT parameterisations +#' +#' m_ph <- stan_surv(Surv(recyrs, status) ~ group, +#' data = bcancer[1:100,], +#' basehaz = "weibull", +#' chains = 1, +#' refresh = 0, +#' iter = 600, +#' seed = 123) +#' m_aft <- stan_surv(Surv(recyrs, status) ~ group, +#' data = bcancer[1:100,], +#' basehaz = "weibull-aft", +#' chains = 1, +#' refresh = 0, +#' iter = 600, +#' seed = 123) +#' +#' fixef(m_ph) [c('groupMedium', 'groupPoor')] # hazard ratios +#' fixef(m_aft)[c('groupMedium', 'groupPoor')] # acceleration factors +#' +#' # same model (...slight differences due to sampling) +#' summary(m_ph, par = "log-posterior")[, 'mean'] +#' summary(m_aft, par = "log-posterior")[, 'mean'] #' } #' stan_surv <- function(formula, data, - basehaz = "ms", - basehaz_ops, + basehaz = "ms", + basehaz_ops, qnodes = 15, prior = normal(), prior_intercept = normal(), @@ -343,12 +391,16 @@ stan_surv <- function(formula, #----- baseline hazard - ok_basehaz <- c("exp", "weibull", "gompertz", "ms", "bs") - ok_basehaz_ops <- get_ok_basehaz_ops(basehaz) + ok_basehaz <- c("exp", + "exp-aft", + "weibull", + "weibull-aft", + "gompertz", + "ms", + "bs") basehaz <- handle_basehaz_surv(basehaz = basehaz, - basehaz_ops = basehaz_ops, + basehaz_ops = basehaz_ops, ok_basehaz = ok_basehaz, - ok_basehaz_ops = ok_basehaz_ops, times = t_end, status = status, min_t = min(t_beg), @@ -499,7 +551,7 @@ stan_surv <- function(formula, len_cpts, idx_cpts, type = basehaz$type, - + nevent = if (has_quadrature) 0L else nevent, nlcens = if (has_quadrature) 0L else nlcens, nrcens = if (has_quadrature) 0L else nrcens, @@ -765,9 +817,8 @@ stan_surv <- function(formula, # predictions since it contains information about the knot locations # for the baseline hazard (this is implemented via splines::predict.bs). handle_basehaz_surv <- function(basehaz, - basehaz_ops, - ok_basehaz = c("weibull", "bs", "piecewise"), - ok_basehaz_ops = c("df", "knots"), + basehaz_ops, + ok_basehaz, times, status, min_t, max_t) { @@ -775,31 +826,11 @@ handle_basehaz_surv <- function(basehaz, if (!basehaz %in% ok_basehaz) stop2("'basehaz' should be one of: ", comma(ok_basehaz)) + ok_basehaz_ops <- get_ok_basehaz_ops(basehaz) if (!all(names(basehaz_ops) %in% ok_basehaz_ops)) stop2("'basehaz_ops' can only include: ", comma(ok_basehaz_ops)) - - if (basehaz == "exp") { - - bknots <- NULL # boundary knot locations - iknots <- NULL # internal knot locations - basis <- NULL # spline basis - nvars <- 0L # number of aux parameters, none - - } else if (basehaz == "gompertz") { - - bknots <- NULL # boundary knot locations - iknots <- NULL # internal knot locations - basis <- NULL # spline basis - nvars <- 1L # number of aux parameters, Gompertz scale - - } else if (basehaz == "weibull") { - - bknots <- NULL # boundary knot locations - iknots <- NULL # internal knot locations - basis <- NULL # spline basis - nvars <- 1L # number of aux parameters, Weibull shape - - } else if (basehaz == "bs") { + + if (basehaz %in% c("ms", "bs", "piecewise")) { df <- basehaz_ops$df knots <- basehaz_ops$knots @@ -808,8 +839,7 @@ handle_basehaz_surv <- function(basehaz, stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") if (is.null(df)) - df <- 6L # default df for B-splines, assuming an intercept is included - # NB this is ignored if the user specified knots + df <- 6L # NB this is ignored if the user specified knots tt <- times[status == 1] # uncensored event times if (is.null(knots) && !length(tt)) { @@ -823,8 +853,32 @@ handle_basehaz_surv <- function(basehaz, stop2("'knots' cannot be placed before the earliest entry time.") if (any(knots > max_t)) stop2("'knots' cannot be placed beyond the latest event time.") - } - + } + } + + if (basehaz %in% c("exp", "exp-aft")) { + + bknots <- NULL # boundary knot locations + iknots <- NULL # internal knot locations + basis <- NULL # spline basis + nvars <- 0L # number of aux parameters, none + + } else if (basehaz %in% c("weibull", "weibull-aft")) { + + bknots <- NULL # boundary knot locations + iknots <- NULL # internal knot locations + basis <- NULL # spline basis + nvars <- 1L # number of aux parameters, Weibull shape + + } else if (basehaz == "gompertz") { + + bknots <- NULL # boundary knot locations + iknots <- NULL # internal knot locations + basis <- NULL # spline basis + nvars <- 1L # number of aux parameters, Gompertz scale + + } else if (basehaz == "bs") { + bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) basis <- get_basis(tt, iknots = iknots, bknots = bknots, type = "bs") @@ -832,33 +886,6 @@ handle_basehaz_surv <- function(basehaz, } else if (basehaz == "ms") { - df <- basehaz_ops$df - knots <- basehaz_ops$knots - - if (!is.null(df) && !is.null(knots)) { - stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") - } - - tt <- times[status == 1] # uncensored event times - if (is.null(df)) { - df <- 6L # default df for M-splines, assuming an intercept is included - # NB this is ignored if the user specified knots - } - - tt <- times[status == 1] # uncensored event times - if (is.null(knots) && !length(tt)) { - warning2("No observed events found in the data. Censoring times will ", - "be used to evaluate default knot locations for splines.") - tt <- times - } - - if (!is.null(knots)) { - if (any(knots < min_t)) - stop2("'knots' cannot be placed before the earliest entry time.") - if (any(knots > max_t)) - stop2("'knots' cannot be placed beyond the latest event time.") - } - bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) basis <- get_basis(tt, iknots = iknots, bknots = bknots, type = "ms") @@ -866,40 +893,15 @@ handle_basehaz_surv <- function(basehaz, } else if (basehaz == "piecewise") { - df <- basehaz_ops$df - knots <- basehaz_ops$knots - - if (!is.null(df) && !is.null(knots)) { - stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") - } - - if (is.null(df)) { - df <- 6L # default number of segments for piecewise constant - # NB this is ignored if the user specified knots - } - - if (is.null(knots) && !length(tt)) { - warning2("No observed events found in the data. Censoring times will ", - "be used to evaluate default knot locations for piecewise basehaz.") - tt <- times - } - - if (!is.null(knots)) { - if (any(knots < min_t)) - stop2("'knots' cannot be placed before the earliest entry time.") - if (any(knots > max_t)) - stop2("'knots' cannot be placed beyond the latest event time.") - } - bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) basis <- NULL # spline basis nvars <- length(iknots) + 1 # number of aux parameters, dummy indicators - } + } nlist(type_name = basehaz, - type = basehaz_for_stan(basehaz), + type = basehaz_for_stan(basehaz), nvars, iknots, bknots, @@ -917,25 +919,26 @@ handle_basehaz_surv <- function(basehaz, # @return A character vector, or NA if unmatched. get_ok_basehaz_ops <- function(basehaz_name) { switch(basehaz_name, - weibull = c(), - bs = c("df", "knots"), - piecewise = c("df", "knots"), - ms = c("df", "knots"), + "bs" = c("df", "knots"), + "piecewise" = c("df", "knots"), + "ms" = c("df", "knots"), NA) } -# Return the integer respresentation for the baseline hazard, used by Stan +# Return the integer representation for the baseline hazard, used by Stan # # @param basehaz_name A character string, the type of baseline hazard. # @return An integer, or NA if unmatched. basehaz_for_stan <- function(basehaz_name) { switch(basehaz_name, - weibull = 1L, - bs = 2L, - piecewise = 3L, - ms = 4L, - exp = 5L, - gompertz = 6L, + "weibull" = 1L, + "bs" = 2L, + "piecewise" = 3L, + "ms" = 4L, + "exp" = 5L, + "gompertz" = 6L, + "exp-aft" = 7L, + "weibull-aft" = 8L, NA) } @@ -979,7 +982,7 @@ get_iknots <- function(x, df = 6L, degree = 3L, iknots = NULL, intercept = TRUE) # @return A Logical. has_intercept <- function(basehaz) { nm <- get_basehaz_name(basehaz) - (nm %in% c("exp", "weibull", "gompertz")) + (nm %in% c("exp", "exp-aft", "weibull", "weibull-aft", "gompertz")) } # Return the name of the tde spline coefs or smoothing parameters. @@ -998,10 +1001,10 @@ get_smooth_name <- function(x, type = "smooth_coefs") { suffix <- paste0(":tde-spline-coef", indices) switch(type, - smooth_coefs = paste0(nms, suffix), - smooth_sd = paste0("smooth_sd[", unique(nms), "]"), - smooth_map = rep(seq_along(tally), tally), - smooth_vars = unique(nms), + "smooth_coefs" = paste0(nms, suffix), + "smooth_sd" = paste0("smooth_sd[", unique(nms), "]"), + "smooth_map" = rep(seq_along(tally), tally), + "smooth_vars" = unique(nms), stop2("Bug found: invalid input to 'type' argument.")) } @@ -1011,7 +1014,7 @@ get_smooth_name <- function(x, type = "smooth_coefs") { # @return A scalar. get_default_aux_scale <- function(basehaz) { nm <- get_basehaz_name(basehaz) - if (nm %in% c("weibull", "gompertz")) 2 else 20 + if (nm %in% c("weibull", "weibull-aft", "gompertz")) 2 else 20 } # Check if the type of baseline hazard has a closed form @@ -1021,7 +1024,9 @@ get_default_aux_scale <- function(basehaz) { check_for_closed_form <- function(basehaz) { nm <- get_basehaz_name(basehaz) nm %in% c("exp", + "exp-aft", "weibull", + "weibull-aft", "gompertz", "ms") } @@ -1051,12 +1056,14 @@ make_basis <- function(times, basehaz, integrate = FALSE) { return(matrix(0, 0, K)) } switch(basehaz$type_name, - "exp" = matrix(0, N, K), # dud matrix for Stan - "weibull" = matrix(0, N, K), # dud matrix for Stan - "gompertz" = matrix(0, N, K), # dud matrix for Stan - "ms" = basis_matrix(times, basis = basehaz$basis, integrate = integrate), - "bs" = basis_matrix(times, basis = basehaz$basis), - "piecewise" = dummy_matrix(times, knots = basehaz$knots), + "exp" = matrix(0, N, K), # dud matrix for Stan + "exp-aft" = matrix(0, N, K), # dud matrix for Stan + "weibull" = matrix(0, N, K), # dud matrix for Stan + "weibull-aft" = matrix(0, N, K), # dud matrix for Stan + "gompertz" = matrix(0, N, K), # dud matrix for Stan + "ms" = basis_matrix(times, basis = basehaz$basis, integrate = integrate), + "bs" = basis_matrix(times, basis = basehaz$basis), + "piecewise" = dummy_matrix(times, knots = basehaz$knots), stop2("Bug found: type of baseline hazard unknown.")) } diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan index b7a71a40a..6fd20b038 100644 --- a/src/stan_files/functions/hazard_functions.stan +++ b/src/stan_files/functions/hazard_functions.stan @@ -8,6 +8,16 @@ return eta; } + /** + * Log hazard for exponential distribution; AFT parameterisation + * + * @param eta Vector, linear predictor + * @return A vector + */ + vector exponentialAFT_log_haz(vector eta) { + return -eta; + } + /** * Log hazard for Weibull distribution * @@ -22,6 +32,20 @@ return res; } + /** + * Log hazard for Weibull distribution; AFT parameterisation + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param shape Real, Weibull shape + * @return A vector + */ + vector weibullAFT_log_haz(vector eta, vector t, real shape) { + vector[rows(eta)] res; + res = log(shape) + (shape - 1) * log(t) - (shape * eta); + return res; + } + /** * Log hazard for Gompertz distribution * diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index c11a3384b..08c853267 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -308,6 +308,35 @@ functions { return res; } + /** + * Log survival and log CDF for exponential distribution; AFT parameterisation + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @return A vector + */ + vector exponentialAFT_log_surv(vector eta, vector t) { + vector[rows(eta)] res; + res = - t .* exp(-eta); + return res; + } + + vector exponentialAFT_log_cdf(vector eta, vector t) { + vector[rows(eta)] res; + res = log(1 - exp(-t .* exp(-eta))); + return res; + } + + vector exponentialAFT_log_cdf2(vector eta, vector t_lower, vector t_upper) { + int N = rows(eta); + vector[N] exp_eta = exp(-eta); + vector[N] surv_lower = exp(-t_lower .* exp_eta); + vector[N] surv_upper = exp(-t_upper .* exp_eta); + vector[N] res; + res = log(surv_lower - surv_upper); + return res; + } + /** * Log survival and log CDF for Weibull distribution * @@ -338,6 +367,36 @@ functions { return res; } + /** + * Log survival and log CDF for Weibull distribution; AFT parameterisation + * + * @param eta Vector, linear predictor + * @param t Vector, event or censoring times + * @param shape Real, Weibull shape + * @return A vector + */ + vector weibullAFT_log_surv(vector eta, vector t, real shape) { + vector[rows(eta)] res; + res = - pow_vec(t, shape) .* exp(-shape * eta); + return res; + } + + vector weibullAFT_log_cdf(vector eta, vector t, real shape) { + vector[rows(eta)] res; + res = log(1 - exp(- pow_vec(t, shape) .* exp(-shape * eta))); + return res; + } + + vector weibullAFT_log_cdf2(vector eta, vector t_lower, vector t_upper, real shape) { + int N = rows(eta); + vector[N] exp_eta = exp(-shape * eta); + vector[N] surv_lower = exp(- pow_vec(t_lower, shape) .* exp_eta); + vector[N] surv_upper = exp(- pow_vec(t_upper, shape) .* exp_eta); + vector[N] res; + res = log(surv_lower - surv_upper); + return res; + } + /** * Log survival and log CDF for Gompertz distribution * @@ -465,7 +524,9 @@ data { // 4 = M-splines // 5 = exponential // 6 = gompertz - int type; + // 7 = exponential AFT + // 8 = weibull AFT + int type; // GK quadrature weights, with (b-a)/2 scaling already incorporated vector[qevent] qwts_event; @@ -662,6 +723,14 @@ model { if (nicens > 0) target += exponential_log_cdf2(eta_icens, t_icenl, t_icenu); if (ndelay > 0) target += -exponential_log_surv(eta_delay, t_delay); } + else if (type == 7) { // exponential AFT model + if (nevent > 0) target += exponentialAFT_log_haz (eta_event); + if (nevent > 0) target += exponentialAFT_log_surv(eta_event, t_event); + if (nlcens > 0) target += exponentialAFT_log_cdf (eta_lcens, t_lcens); + if (nrcens > 0) target += exponentialAFT_log_surv(eta_rcens, t_rcens); + if (nicens > 0) target += exponentialAFT_log_cdf2(eta_icens, t_icenl, t_icenu); + if (ndelay > 0) target += -exponentialAFT_log_surv(eta_delay, t_delay); + } else if (type == 1) { // weibull model real shape = coefs[1]; if (nevent > 0) target += weibull_log_haz (eta_event, t_event, shape); @@ -671,6 +740,15 @@ model { if (nicens > 0) target += weibull_log_cdf2(eta_icens, t_icenl, t_icenu, shape); if (ndelay > 0) target += -weibull_log_surv(eta_delay, t_delay, shape); } + else if (type == 8) { // weibull AFT model + real shape = coefs[1]; + if (nevent > 0) target += weibullAFT_log_haz (eta_event, t_event, shape); + if (nevent > 0) target += weibullAFT_log_surv(eta_event, t_event, shape); + if (nlcens > 0) target += weibullAFT_log_cdf (eta_lcens, t_lcens, shape); + if (nrcens > 0) target += weibullAFT_log_surv(eta_rcens, t_rcens, shape); + if (nicens > 0) target += weibullAFT_log_cdf2(eta_icens, t_icenl, t_icenu, shape); + if (ndelay > 0) target += -weibullAFT_log_surv(eta_delay, t_delay, shape); + } else if (type == 6) { // gompertz model real scale = coefs[1]; if (nevent > 0) target += gompertz_log_haz (eta_event, t_event, scale); @@ -730,10 +808,17 @@ model { if (type == 5) { // exponential model lhaz = exponential_log_haz(eta); } + else if (type == 7) { // exponential AFT model + lhaz = exponentialAFT_log_haz(eta); + } else if (type == 1) { // weibull model real shape = coefs[1]; lhaz = weibull_log_haz(eta, cpts, shape); } + else if (type == 8) { // weibull AFT model + real shape = coefs[1]; + lhaz = weibullAFT_log_haz(eta, cpts, shape); + } else if (type == 6) { // gompertz model real scale = coefs[1]; lhaz = gompertz_log_haz(eta, cpts, scale); From 2ee2d632dc68c2e7a981603f4273f5989bf25dd2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 26 Nov 2018 17:08:36 +1100 Subject: [PATCH 093/225] Update stan_surv documentation --- R/stan_surv.R | 51 ++++++++++++++++++++++++++++++-------------------- rstanarm.Rproj | 2 +- 2 files changed, 32 insertions(+), 21 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 8cbd2be15..4313076e0 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -20,13 +20,19 @@ #' #' \if{html}{\figure{stanlogo.png}{options: width="25px" alt="http://mc-stan.org/about/logo/"}} #' Bayesian inference for survival models (sometimes known as models for -#' time-to-event data). Currently, the command fits standard parametric -#' (exponential, Weibull and Gompertz) and flexible parametric (cubic -#' spline-based) survival models on the hazard scale, with covariates included -#' under assumptions of either proportional or non-proportional hazards. -#' Where relevant, non-proportional hazards are modelled using a flexible -#' cubic spline-based function for the time-dependent effect (i.e. the -#' time-dependent hazard ratio). +#' time-to-event data). Currently, the command fits: +#' (i) flexible parametric (cubic spline-based) survival +#' models on the hazard scale, with covariates included under assumptions of +#' either proportional or non-proportional hazards; +#' (ii) standard parametric (exponential, Weibull and Gompertz) survival +#' models on the hazard scale, with covariates included under assumptions of +#' either proportional or non-proportional hazards; and +#' (iii) standard parametric (exponential, Weibull) accelerated failure time +#' models, with covariates included under assumptions of either time-fixed or +#' time-dependent acceleration factors. +#' Where relevant, time-dependent effects (i.e. time-dependent hazard ratios +#' or time-dependent acceleration factors) are modelled using a flexible +#' cubic spline-based function for the time-dependent coefficient. #' #' @export #' @importFrom splines bs @@ -55,7 +61,7 @@ #' @param basehaz A character string indicating which baseline hazard or #' baseline survival distribution to use for the event submodel. #' -#' The following are available under a proportional hazards formulation: +#' The following are available under a hazard scale formulation: #' \itemize{ #' \item \code{"ms"}: a flexible parametric model using cubic M-splines to #' model the baseline hazard. The default locations for the internal knots, @@ -80,7 +86,8 @@ #' \item \code{"weibull"}: a Weibull distribution for the event times. #' \item \code{"gompertz"}: a Gompertz distribution for the event times. #' } -#' and the following are available under an accelerated failure time (AFT) +#' +#' The following are available under an accelerated failure time (AFT) #' formulation: #' \itemize{ #' \item \code{"exp-aft"}: an exponential distribution for the event times. @@ -177,22 +184,26 @@ #' to the appropriate length. #' #' @details -#' \subsection{Time dependent effects (i.e. non-proportional hazards)}{ +#' \subsection{Time dependent effects}{ #' By default, any covariate effects specified in the \code{formula} are -#' included in the model under a proportional hazards assumption (or for the -#' exponential and Weibull AFT models, under the assumption of time-fixed -#' acceleration factors). To relax this assumption, it is possible to -#' estimate a time-dependent coefficient for a given covariate. +#' included in the model under a proportional hazards assumption (for models +#' estimated using a hazard scale formulation) or under the assumption of +#' time-fixed acceleration factors (for models estimated using an accelerated +#' failure time formulation). To relax this assumption, it is possible to +#' estimate a time-dependent coefficient for a given covariate. Note the +#' following: #' -#' Estimating a time-dependent coefficient under a hazards model +#' \itemize{ +#' \item Estimating a time-dependent coefficient under a hazard scale model #' formulation (i.e. when \code{basehaz} is set equal to \code{"ms"}, #' \code{"bs"}, \code{"exp"}, \code{"weibull"} or \code{"gompertz"}) leads #' to the estimation of a time-dependent hazard ratio for the relevant -#' covariate (i.e. non-proportional hazards). Conversely, estimating a -#' time-dependent coefficient under an accelerated failure time model -#' formulation (i.e. when \code{basehaz} is set equal to \code{"exp-aft"}, -#' or \code{"weibull-aft"}) leads to the estimation of a time-dependent -#' acceleration factor for the relevant covariate. +#' covariate (i.e. non-proportional hazards). +#' \item Estimating a time-dependent coefficient under an accelerated failure +#' time model formulation (i.e. when \code{basehaz} is set equal to +#' \code{"exp-aft"}, or \code{"weibull-aft"}) leads to the estimation of a +#' time-dependent acceleration factor for the relevant covariate. +#' } #' #' A time-dependent effect can be specified in the model \code{formula} #' by wrapping the covariate name in the \code{tde()} function (note that diff --git a/rstanarm.Rproj b/rstanarm.Rproj index ecf48868d..e23bb38f1 100644 --- a/rstanarm.Rproj +++ b/rstanarm.Rproj @@ -13,6 +13,6 @@ RnwWeave: knitr LaTeX: pdfLaTeX BuildType: Package -PackageInstallArgs: --no-multiarch --with-keep.source +PackageInstallArgs: --no-multiarch --with-keep.source --precleanO PackageCheckArgs: --run-dontrun --run-donttest PackageRoxygenize: rd,collate,namespace From 91355595b887770f95596623c836a997f5791b40 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:14:12 +1100 Subject: [PATCH 094/225] Add AFT models to vignette --- vignettes/surv.Rmd | 670 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 639 insertions(+), 31 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 6d78168a3..e1f73b4bf 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -114,9 +114,12 @@ S_i(t) = \exp \left[ -H_i(t) \right] = \exp \left[ -\int_{s=0}^t h_i(s) ds \righ \end{split} \end{equation} -## Model formulation -We model the hazard of the event for individual $i$ using the following regression model +## Hazard scale formulations + +When `basehaz` is set equal to `"exp"`, `"weibull"`, `"gompertz"`, `"ms"` (the default), or `"bs"` then the model is defined on the hazard scale as described by the following parameterisations. + +We model the hazard of the event for individual $i$ at time $t$ using the regression model: \ \begin{equation} \begin{split} @@ -124,71 +127,155 @@ h_i(t) = h_0(t) \exp \left[ \eta_i(t) \right] \end{split} \end{equation} \ -where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the (possibly time-dependent) linear predictor evaluated for individual $i$ at time $t$. +where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-dependent; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying hazard ratio). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity and the definition of the hazard function reduces to: +\ +\begin{equation} +\begin{split} +h_i(t) = h_0(t) \exp \left[ \eta_i \right] +\end{split} +\end{equation} -We further define the baseline hazard and linear predictor in the next sections. +### Linear predictor + +Our linear predictor is defined as: +\ +\begin{equation} +\begin{split} +\eta_i(t) = \beta_0 + \sum_{p=1}^P \beta_p(t) x_{ip}(t) +\end{split} +\end{equation} +\ +where $\beta_0$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p(t)$ denotes a coefficient defined as: +\ +\begin{align} +\beta_p(t) = + \begin{cases} + \theta_{p,0} + & \text{for proportional hazards} \\ + \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) + & \text{for non-proportional hazards} + \end{cases} +\end{align} +\ +such that $\theta_{p,0}$ is a time-fixed log hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent hazard ratio as a smooth function of time. -### Baseline hazard +**Note:** in these expressions, the quantity $\exp \left( \beta_p(t) \right)$ is referred to as a "hazard ratio". The *hazard ratio (HR)* quantifies the relative increase in the hazard that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a hazard ratio of 2 means that a unit-increase in the covariate leads to a doubling in the hazard (i.e. the instantaneous rate) of the event. -The `stan_surv` modelling function, via its `basehaz` argument, allows the baseline hazard $h_0(t)$ to be specified using any of the following parametric formulations. +**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent hazard ratio for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. -- **Exponential distribution**: for scale parameter $\lambda > 0$ we have +### Distributions +- **Exponential model** (`basehaz = "exp"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ we have +\ \begin{equation} -h_0(t) = \lambda +h_i(t) = \lambda_i(t) \end{equation} -- **Weibull distribution**: for scale parameter $\lambda > 0$ and shape parameter $\gamma > 0$ we have - +- **Weibull model** (`basehaz = "weibull"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and shape parameter $\gamma > 0$ we have +\ \begin{equation} -h_0(t) = \gamma t^{\gamma-1} \lambda +h_0(t) = \gamma t^{\gamma-1} \lambda_i(t) \end{equation} -- **Gompertz distribution**: for shape parameter $\lambda > 0$ and scale parameter $\gamma > 0$ we have - +- **Gompertz model** (`basehaz = "gompertz"`): for shape parameter $\lambda = \exp ( \eta_i(t) )$ and scale parameter $\gamma > 0$ we have +\ \begin{equation} -h_0(t) = \exp(\gamma t) \lambda +h_0(t) = \exp(\gamma t) \lambda_i(t) \end{equation} -- **M-splines**, the default: letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have +- **M-splines model** (`basehaz = "ms"`, the default): letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have +\ +\begin{equation} +h_0(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) \exp ( \eta_i(t) ) +\end{equation} +- **B-splines model** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have +\ \begin{equation} -h_0(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +h_0(t) = \exp ( B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) + \eta_i(t) ) \end{equation} -- **B-splines** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have +**Note:** for the M-spline and B-spline models, the linear predictor does not include an intercept $\beta_0$; instead the intercept parameter is absorbed into the spline basis. + +**Note:** when the linear predictor *is not* time-dependent (i.e. under proportional hazards), there is a closed form expression for the survival probability; details shown in the appendix. However, when the linear predictor *is* time-dependent (i.e. under non-proportional hazards) there is no closed form expression for the survival probability; instead, quadrature is used to evaluate the survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. + + +## Accelerated failure time formulations +When `basehaz` is set equal to `"exp-aft"`, or `"weibull-aft"` then the model is defined on the accelerated failure time scale as described by the following parameterisations. + +Following Hougaard (1999), we model the survival probability for individual $i$ at time $t$ using the regression model: +\ \begin{equation} -\log h_0(t) = B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) +\begin{split} +S_i(t) = S_0 \left( \int_0^t \exp \left[ - \eta_i(u) \right] du \right) +\end{split} +\end{equation} +\ +where $S_0(t)$ is the baseline survival probability at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-dependent; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying acceleration factor). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity (i.e. $\eta_i(t) = \eta_i$) and the definition of the survival probability reduces to: +\ +\begin{equation} +\begin{split} +S_i(t) = S_0 \left( t \exp \left[ - \eta_i \right] \right) +\end{split} \end{equation} - -Note that for the exponential, Weibull, and Gompertz baseline hazards, $\log \lambda$ is absorbed as an intercept term in the linear predictor $\eta_i(t)$. It is therefore shown as such in the output for `stan_surv`. ### Linear predictor -The effects of covariates are introduced through the linear predictor under proportional or non-proportional hazards assumptions. That is, we define our linear predictor as +Our linear predictor is defined as: \ \begin{equation} \begin{split} -\eta_i(t) = \boldsymbol{X_i^T(t)} \boldsymbol{\beta(t)} +\eta_i(t) = \beta_0^* + \sum_{p=1}^P \beta_p^*(t) x_{ip}(t) \end{split} \end{equation} \ -where $\boldsymbol{X_i^T(t)}$ is a vector of covariates (possibly time-varying) for individual $i$, and $\boldsymbol{\beta(t)} = \{ \beta_p(t); p = 1,...,P \}$ is a vector of parameters with each element defined as +where $\beta_0^*$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p^*(t)$ denotes a coefficient defined as: \ \begin{align} -\beta_p(t) = +\beta_p^*(t) = \begin{cases} \theta_{p,0} - & \text{for proportional hazards} \\ + & \text{for time-fixed acceleration} \\ \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) - & \text{for non-proportional hazards} + & \text{for time-dependent acceleration} \end{cases} \end{align} \ -such that $\theta_{p,0}$ is a time-fixed hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent hazard ratio as a smooth function of time. +such that $\theta_{p,0}$ is a time-fixed log survival time ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent acceleration factor as a smooth function of time. + +**Note:** in these expressions, the quantity $\exp \left( - \beta_p^*(t) \right)$ is referred to as an "acceleration factor" and the quantity $\exp \left( \beta_p^*(t) \right)$ is referred to as a "survival time ratio". The *acceleration factor (AF)* quantifies the acceleration (or deceleration) of the event process that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. an acceleration factor of 0.5 means that a unit-increase in the covariate leads to an individual approaching the event at half the speed. If you find that somewhat confusing, then it may be easier to think about the *survival time ratio (STR)* . The *survival time ratio* is the inverse of the acceleration factor (i.e. $STR = 1/AF$). The *survival time ratio* is interpreted as the increase (or decrease) in the expected survival time that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a survival time ratio of 2 (which is equivalent to an acceleration factor of 0.5) means that a unit-increase in the covariate leads to an doubling in the expected survival time. + +**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent acceleration factor for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. + +### Distributions + +- **Exponential model** (`basehaz = "exp-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\eta_i(t) )$ we have +\ +\begin{equation} +S_i(t) = \exp \left( - t \lambda_i \right) +\end{equation} +\ +or in the case with time-dependent effects +\ +\begin{equation} +S_i(t) = \exp \left( - \int_0^t \exp ( -\eta_i(u) ) du \right) +\end{equation} + +- **Weibull model** (`basehaz = "weibull-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\gamma \eta_i(t) )$ and shape parameter $\gamma > 0$ we have +\ +\begin{equation} +S_i(t) = \exp \left( - t^{\gamma} \lambda_i \right) +\end{equation} +\ +or in the case with time-dependent effects +\ +\begin{equation} +S_i(t) = \exp \left( - \left[ \int_0^t \exp ( -\eta_i(u) ) du \right]^{\gamma} \right) +\end{equation} + +**Note:** when the linear predictor *is not* time-dependent (i.e. under time-fixed acceleration), there is a closed form expression for both the hazard function and survival function; details shown in the appendix. However, when the linear predictor *is* time-dependent (i.e. under time-dependent acceleration) there is no closed form expression for the hazard function or survival probability; instead, quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate the hazard function and survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. -In the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent hazard ratio for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. ## Likelihood @@ -207,11 +294,11 @@ p(\mathcal{D}_i | \boldsymbol{\gamma}, \boldsymbol{\beta}) = ## Priors -The prior distribution for the baseline hazard parameters (i.e. $\gamma$ for Weibull or Gompertz baseline hazards, or $\boldsymbol{\gamma}$ for the M-spline or B-spline baseline hazards) is specified via the `prior_aux` argument to `stan_surv`. Choices of prior distribution include half-normal, half-t or half-Cauchy for the Weibull, Gompertz and M-spline baseline hazards, or normal, t, or Cauchy for the B-splines log baseline hazard. These choices are described in greater detail in the `stan_surv` help file. +The prior distribution for the so-called "auxiliary" parameters (i.e. $\gamma$ for the Weibull and Gompertz models, or $\boldsymbol{\gamma}$ for the M-spline and B-spline models) is specified via the `prior_aux` argument to `stan_surv`. Choices of prior distribution for the auxiliary parameters include half-normal, half-t or half-Cauchy for the Weibull, Gompertz and M-spline models, or normal, t, or Cauchy for the B-splines model. These choices are described in greater detail in the `stan_surv` help file. -For the exponential, Weibull, or Gompertz baseline hazards the prior distribution for the intercept parameter in the linear predictor, that is $\log \lambda$, is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. +For the exponential, Weibull, or Gompertz models the prior distribution for the intercept parameter in the linear predictor is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. -The choice of prior distribution for the time-fixed hazard ratios $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. +The choice of prior distribution for the time-fixed coefficients $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. The B-spline coefficients related to each time-dependent effect, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. @@ -401,3 +488,524 @@ The plot shows a large amount of uncertainty around the estimated time-dependent # References Brilleman, S. (2018) *simsurv: Simulate Survival Data.* R package version 0.2.2. \url{https://CRAN.R-project.org/package=simsurv} + +Hougaard P. Fundamentals of Survival Data. *Biometrics* 1999;55:13--22. + + +# Appendix A: Parameterisations on the hazard scale + +When `basehaz` is set equal to `"exp"`, `"weibull"`, `"gompertz"`, `"ms"` (the default), or `"bs"` then the model is defined on the hazard scale using the following parameterisations. + + +### Exponential model + +The exponential model is parameterised with scale parameter $\lambda_i = \exp(\eta_i)$ where $\eta_i = \beta_0 + \sum_{p=1}^P \beta_p x_{ip}$ denotes our linear predictor. + +For individual $i$ we have: + +\begin{align} +\begin{split} + h_i(T_i) + & = \lambda_i \\ + & = \exp(\eta_i) \\ + H_i(T_i) + & = T_i \lambda_i \\ + & = T_i \exp(\eta_i) \\ + S_i(T_i) + & = \exp \left( - T_i \lambda_i \right) \\ + & = \exp \left( - T_i \exp(\eta_i) \right) \\ + F_i(T_i) + & = 1 - \exp \left( - T_i \lambda_i \right) \\ + & = 1 - \exp \left( - T_i \exp(\eta_i) \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( - T_i \lambda_i \right) - \exp \left( - T_i^U \lambda_i \right) \\ + & = \exp \left( - T_i \exp(\eta_i) \right) - \exp \left( - T_i^U \exp(\eta_i) \right) +\end{split} +\end{align} + +or on the log scale: + +\begin{align} +\begin{split} + \log h_i(T_i) + & = \log \lambda_i \\ + & = \eta_i \\ + \log H_i(T_i) + & = \log(T_i) + \log \lambda_i \\ + & = \log(T_i) + \eta_i \\ + \log S_i(T_i) + & = - T_i \lambda_i \\ + & = - T_i \exp(\eta_i) \\ + \log F_i(T_i) + & = \log \left( 1 - \exp \left( - T_i \lambda_i \right) \right) \\ + & = \log \left( 1 - \exp \left( - T_i \exp(\eta_i) \right) \right) \\ + \log (S_i(T_i) - S_i(T_i^U)) + & = \log \left[ \exp \left( - T_i \lambda_i \right) - \exp \left( - T_i^U \lambda_i \right) \right] \\ + & = \log \left[ \exp \left( - T_i \exp(\eta_i) \right) - \exp \left( - T_i^U \exp(\eta_i) \right) \right] +\end{split} +\end{align} + +The definition of $\lambda$ for the baseline is: + +\begin{align} +\begin{split} + \lambda_0 = \exp(\beta_0) \Longleftrightarrow \beta_0 = \log(\lambda_0) +\end{split} +\end{align} + + +### Weibull model + +The Weibull model is parameterised with scale parameter $\lambda_i = \exp(\eta_i)$ and shape parameter $\gamma > 0$ where $\eta_i = \beta_0 + \sum_{p=1}^P \beta_p x_{ip}$ denotes our linear predictor. + +For individual $i$ we have: + +\begin{align} +\begin{split} + h_i(T_i) + & = \gamma t^{\gamma-1} \lambda_i \\ + & = \gamma t^{\gamma-1} \exp(\eta_i) \\ + H_i(T_i) + & = T_i^{\gamma} \lambda_i \\ + & = T_i^{\gamma} \exp(\eta_i) \\ + S_i(T_i) + & = \exp \left( - T_i^{\gamma} \lambda_i \right) \\ + & = \exp \left( - T_i^{\gamma} \exp(\eta_i) \right) \\ + F_i(T_i) + & = 1 - \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) \\ + & = 1 - \exp \left( - {(T_i)}^{\gamma} \exp(\eta_i) \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) - \exp \left( - {(T_i^U)}^{\gamma} \lambda_i \right) \\ + & = \exp \left( - {(T_i)}^{\gamma} \exp(\eta_i) \right) - \exp \left( - {(T_i^U)}^{\gamma} \exp(\eta_i) \right) +\end{split} +\end{align} + +or on the log scale: + +\begin{align} +\begin{split} + \log h_i(T_i) + & = \log(\gamma) + (\gamma-1) \log(t) + \log \lambda_i \\ + & = \log(\gamma) + (\gamma-1) \log(t) + \eta_i \\ + \log H_i(T_i) + & = \gamma \log(T_i) + \log \lambda_i \\ + & = \gamma \log(T_i) + \eta_i \\ + \log S_i(T_i) + & = - T_i^{\gamma} \lambda_i \\ + & = - T_i^{\gamma} \exp(\eta_i) \\ + \log F_i(T_i) + & = \log \left( 1 - \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) \right) \\ + & = \log \left( 1 - \exp \left( - {(T_i)}^{\gamma} \exp(\eta_i) \right) \right) \\ + \log (S_i(T_i) - S_i(T_i^U)) + & = \log \left[ \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) - \exp \left( - {(T_i^U)}^{\gamma} \lambda_i \right) \right] \\ + & = \log \left[ \exp \left( - {(T_i)}^{\gamma} \exp(\eta_i) \right) - \exp \left( - {(T_i^U)}^{\gamma} \exp(\eta_i) \right) \right] +\end{split} +\end{align} + +The definition of $\lambda$ for the baseline is: + +\begin{align} +\begin{split} + \lambda_0 = \exp(\beta_0) \Longleftrightarrow \beta_0 = \log(\lambda_0) +\end{split} +\end{align} + + +### Gompertz model + +The Gompertz model is parameterised with shape parameter $\lambda_i = \exp(\eta_i)$ and scale parameter $\gamma > 0$ where $\eta_i = \beta_0 + \sum_{p=1}^P \beta_p x_{ip}$ denotes our linear predictor. + +For individual $i$ we have: + +\begin{align} +\begin{split} + h_i(T_i) + & = \exp(\gamma T_i) \lambda_i \\ + & = \exp(\gamma T_i) \exp(\eta_i) \\ + H_i(T_i) + & = \frac{\exp(\gamma T_i) - 1}{\gamma} \lambda_i \\ + & = \frac{\exp(\gamma T_i) - 1}{\gamma} \exp(\eta_i) \\ + S_i(T_i) + & = \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \lambda_i \right) \\ + & = \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \exp(\eta_i) \right) \\ + F_i(T_i) + & = 1 - \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \lambda_i \right) \\ + & = 1 - \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \exp(\eta_i) \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \lambda_i \right) - \exp \left( \frac{-(\exp(\gamma T_i^U) - 1)}{\gamma} \lambda_i \right) \\ + & = \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \exp(\eta_i) \right) - \exp \left( \frac{-(\exp(\gamma T_i^U) - 1)}{\gamma} \exp(\eta_i) \right) +\end{split} +\end{align} + +or on the log scale: + +\begin{align} +\begin{split} + \log h_i(T_i) + & = \gamma T_i + \log \lambda_i \\ + & = \gamma T_i + \eta_i \\ + \log H_i(T_i) + & = \log(\exp(\gamma T_i) - 1) - \log(\gamma) + \log \lambda_i \\ + & = \log(\exp(\gamma T_i) - 1) - \log(\gamma) + \eta_i \\ + \log S_i(T_i) + & = \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \lambda_i \\ + & = \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \exp(\eta_i) \\ + \log F_i(T_i) + & = \log \left( 1 - \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \lambda_i \right) \right) \\ + & = \log \left( 1 - \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \exp(\eta_i) \right) \right) \\ + \log (S_i(T_i) - S_i(T_i^U)) + & = \log \left[ \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \lambda_i \right) - \exp \left( \frac{-(\exp(\gamma T_i^U) - 1)}{\gamma} \lambda_i \right) \right] \\ + & = \log \left[ \exp \left( \frac{-(\exp(\gamma T_i) - 1)}{\gamma} \exp(\eta_i) \right) - \exp \left( \frac{-(\exp(\gamma T_i^U) - 1)}{\gamma} \exp(\eta_i) \right) \right] +\end{split} +\end{align} + +The definition of $\lambda$ for the baseline is: + +\begin{align} +\begin{split} + \lambda_0 = \exp(\beta_0) \Longleftrightarrow \beta_0 = \log(\lambda_0) +\end{split} +\end{align} + + +### M-spline model + +The M-spline model is parameterised with vector of regression coefficients $\boldsymbol{\theta} > 0$ for the baseline hazard and with covariate effects introduced through a linear predictor $\eta_i = \sum_{p=1}^P \beta_p x_{ip}$. Note that there is no intercept in the linear predictor since it is absorbed into the baseline hazard spline function. + +For individual $i$ we have: + +\begin{align} +\begin{split} + h_i(T_i) + & = M(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \\ + H_i(T_i) + & = I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \\ + S_i(T_i) + & = \exp \left( - I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \right) \\ + F_i(T_i) + & = 1 - \exp \left( - I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( - I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \right) - \exp \left( - I(T_i^U; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \right) +\end{split} +\end{align} + +or on the log scale: + +\begin{align} +\begin{split} + \log h_i(T_i) + & = \log(M(T_i; \boldsymbol{\theta}, \boldsymbol{k_0})) + \eta_i \\ + \log H_i(T_i) + & = \log(I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0})) + \eta_i \\ + \log S_i(T_i) + & = - I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \\ + \log F_i(T_i) + & = \log \left[ 1 - \exp \left( - I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \right) \right] \\ + \log (S_i(T_i) - S_i(T_i^U)) + & = \log \left[ \exp \left( - I(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \right) - \exp \left( - I(T_i^U; \boldsymbol{\theta}, \boldsymbol{k_0}) \exp(\eta_i) \right) \right] +\end{split} +\end{align} + +where $M(t; \boldsymbol{\theta}, \boldsymbol{k_0})$ denotes a cubic M-spline function evaluated at time $t$ with regression coefficients $\boldsymbol{\theta}$ and basis evaluated using the vector of knot locations $\boldsymbol{k_0})$. Similarly, $I(t; \boldsymbol{\theta}, \boldsymbol{k_0})$ denotes a cubic I-spline function (i.e. integral of an M-spline) evaluated at time $t$ with regression coefficients $\boldsymbol{\theta}$ and basis evaluated using the vector of knot locations $\boldsymbol{k_0}$. + + +### B-spline model + +The B-spline model is parameterised with vector of regression coefficients $\boldsymbol{\theta}$ and linear predictor where $\eta_i = \sum_{p=1}^P \beta_p x_{ip}$ denotes our linear predictor. Note that there is no intercept in the linear predictor since it is absorbed into the spline function. + + +For individual $i$ we have: + +\begin{align} +\begin{split} + h_i(T_i) + & = \exp \left( B(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) + \eta_i \right) +\end{split} +\end{align} + +or on the log scale: + +\begin{align} +\begin{split} + \log h_i(T_i) + & = B(T_i; \boldsymbol{\theta}, \boldsymbol{k_0}) + \eta_i +\end{split} +\end{align} + +The cumulative hazard, survival function, and CDF for the B-spline model cannot be calculated analytically. Instead, the model is only defined analytically on the hazard scale and quadrature is used to evaluate the following: + +\begin{align} +\begin{split} + H_i(T_i) + & = \int_0^{T_i} h_i(u) du \\ + S_i(T_i) + & = \exp \left( - \int_0^{T_i} h_i(u) du \right) \\ + F_i(T_i) + & = 1 - \exp \left( - \int_0^{T_i} h_i(u) du \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( -\int_0^{T_i} h_i(u) du \right) - \exp \left( - \int_0^{T_i^U} h_i(u) du \right) +\end{split} +\end{align} + + +### Extension to time-dependent coefficients (i.e. non-proportional hazards) + +We can extend the previous model formulations to allow for time-dependent coefficients (i.e. non-proportional hazards). The time-dependent linear predictor is introduced on the hazard scale. That is, $\eta_i$ in our previous model definitions is instead replaced by $\eta_i(t)$. This leads to an analytical form for the hazard and log hazard. However, in general, there is no longer a closed form expression for the cumulative hazard, survival function, or CDF. Therefore, when the linear predictor includes time-dependent coefficients, quadrature is used to evaluate the following: + +\begin{align} +\begin{split} + H_i(T_i) + & = \int_0^{T_i} h_i(u) du \\ + S_i(T_i) + & = \exp \left( - \int_0^{T_i} h_i(u) du \right) \\ + F_i(T_i) + & = 1 - \exp \left( - \int_0^{T_i} h_i(u) du \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( -\int_0^{T_i} h_i(u) du \right) - \exp \left( - \int_0^{T_i^U} h_i(u) du \right) +\end{split} +\end{align} + + +# Appendix B: Parameterisations under accelerated failure times + +When `basehaz` is set equal to `"exp-aft"`, or `"weibull-aft"` then the model is defined on the accelerated failure time scale using the following parameterisations. + + +### Exponential model + +The exponential model is parameterised with scale parameter $\lambda_i = \exp(-\eta_i)$ where $\eta_i = \beta_0^* + \sum_{p=1}^P \beta_p^* x_{ip}$ denotes our linear predictor. + +For individual $i$ we have: + +\begin{align} +\begin{split} + h_i(T_i) + & = \lambda_i \\ + & = \exp(-\eta_i) \\ + H_i(T_i) + & = T_i \lambda_i \\ + & = T_i \exp(-\eta_i) \\ + S_i(T_i) + & = \exp \left( - T_i \lambda_i \right) \\ + & = \exp \left( - T_i \exp(-\eta_i) \right) \\ + F_i(T_i) + & = 1 - \exp \left( - T_i \lambda_i \right) \\ + & = 1 - \exp \left( - T_i \exp(-\eta_i) \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( - T_i \lambda_i \right) - \exp \left( - T_i^U \lambda_i \right) \\ + & = \exp \left( - T_i \exp(-\eta_i) \right) - \exp \left( - T_i^U \exp(-\eta_i) \right) +\end{split} +\end{align} + +or on the log scale: + +\begin{align} +\begin{split} + \log h_i(T_i) + & = \log \lambda_i \\ + & = -\eta_i \\ + \log H_i(T_i) + & = \log(T_i) + \log \lambda_i \\ + & = \log(T_i) - \eta_i \\ + \log S_i(T_i) + & = - T_i \lambda_i \\ + & = - T_i \exp(-\eta_i) \\ + \log F_i(T_i) + & = \log \left( 1 - \exp \left( - T_i \lambda_i \right) \right) \\ + & = \log \left( 1 - \exp \left( - T_i \exp(-\eta_i) \right) \right) \\ + \log (S_i(T_i) - S_i(T_i^U)) + & = \log \left[ \exp \left( - T_i \lambda_i) \right) - \exp \left( - T_i^U \lambda_i \right) \right] \\ + & = \log \left[ \exp \left( - T_i \exp(-\eta_i) \right) - \exp \left( - T_i^U \exp(-\eta_i) \right) \right] +\end{split} +\end{align} + +The definition of $\lambda$ for the baseline is: + +\begin{align} +\begin{split} + \lambda_0 = \exp(-\beta_0^*) \Longleftrightarrow \beta_0^* = -\log(\lambda_0) +\end{split} +\end{align} + +The relationship between coefficients under the PH (unstarred) and AFT (starred) parameterisations are as follows: + +\begin{align} +\begin{split} + \beta_0 & = -\beta_0^* \\ + \beta_p & = -\beta_p^* +\end{split} +\end{align} + +Lastly, the general form for the hazard function and survival function under an AFT model with acceleration factor $\exp(-\eta_i)$ can be used to derive the exponential AFT model defined here by setting $h_0(t) = 1$, $S_0(t) = \exp(-T_i)$, and $\lambda_i = \exp(-\eta_i)$: + +\begin{align} +\begin{split} + h_i(T_i) + & = \exp(-\eta_i) h_0(t \exp(-\eta_i)) \\ + & = \exp(-\eta_i) \\ + & = \lambda_i +\end{split} +\end{align} + +\begin{align} +\begin{split} + S_i(T_i) + & = S_0(t \exp(-\eta_i)) \\ + & = \exp(-T_i \exp(-\eta_i)) \\ + & = \exp(-T_i \lambda_i) +\end{split} +\end{align} + + +### Weibull model + +The Weibull model is parameterised with scale parameter $\lambda_i = \exp(-\gamma \eta_i)$ and shape parameter $\gamma > 0$ where $\eta_i = \beta_0^* + \sum_{p=1}^P \beta_p^* x_{ip}$ denotes our linear predictor. + +For individual $i$ we have: + +\begin{align} +\begin{split} + h_i(T_i) + & = \gamma t^{\gamma-1} \lambda_i \\ + & = \gamma t^{\gamma-1} \exp(-\gamma \eta_i) \\ + H_i(T_i) + & = T_i^{\gamma} \lambda_i \\ + & = T_i^{\gamma} \exp(-\gamma \eta_i) \\ + S_i(T_i) + & = \exp \left( - T_i^{\gamma} \lambda_i \right) \\ + & = \exp \left( - T_i^{\gamma} \exp(-\gamma \eta_i) \right) \\ + F_i(T_i) + & = 1 - \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) \\ + & = 1 - \exp \left( - {(T_i)}^{\gamma} \exp(-\gamma \eta_i) \right) \\ + S_i(T_i) - S_i(T_i^U) + & = \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) - \exp \left( - {(T_i^U)}^{\gamma} \lambda_i \right) \\ + & = \exp \left( - {(T_i)}^{\gamma} \exp(-\gamma \eta_i) \right) - \exp \left( - {(T_i^U)}^{\gamma} \exp(-\gamma \eta_i) \right) +\end{split} +\end{align} + +or on the log scale: + +\begin{align} +\begin{split} + \log h_i(T_i) + & = \log(\gamma) + (\gamma-1) \log(t) + \log \lambda_i \\ + & = \log(\gamma) + (\gamma-1) \log(t) - \gamma \eta_i \\ + \log H_i(T_i) + & = \gamma \log(T_i) + \log \lambda_i \\ + & = \gamma \log(T_i) - \gamma \eta_i \\ + \log S_i(T_i) + & = - T_i^{\gamma} \lambda_i \\ + & = - T_i^{\gamma} \exp(-\gamma \eta_i) \\ + \log F_i(T_i) + & = \log \left( 1 - \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) \right) \\ + & = \log \left( 1 - \exp \left( - {(T_i)}^{\gamma} \exp(-\gamma \eta_i) \right) \right) \\ + \log (S_i(T_i) - S_i(T_i^U)) + & = \log \left[ \exp \left( - {(T_i)}^{\gamma} \lambda_i \right) - \exp \left( - {(T_i^U)}^{\gamma} \lambda_i \right) \right] \\ + & = \log \left[ \exp \left( - {(T_i)}^{\gamma} \exp(-\gamma \eta_i) \right) - \exp \left( - {(T_i^U)}^{\gamma} \exp(-\gamma \eta_i) \right) \right] +\end{split} +\end{align} + +The definition of $\lambda$ for the baseline is: + +\begin{align} +\begin{split} + \lambda_0 = \exp(-\gamma \beta_0^*) \Longleftrightarrow \beta_0^* = \frac{-\log(\lambda_0)}{\gamma} +\end{split} +\end{align} + +The relationship between coefficients under the PH (unstarred) and AFT (starred) parameterisations are as follows: + +\begin{align} +\begin{split} + \beta_0 & = -\gamma \beta_0^* \\ + \beta_p & = -\gamma \beta_p^* +\end{split} +\end{align} + +Lastly, the general form for the hazard function and survival function under an AFT model with acceleration factor $\exp(-\eta_i)$ can be used to derive the Weibull AFT model defined here by setting $h_0(t) = \gamma t^{\gamma - 1}$, $S_0(t) = \exp(-T_i^{\gamma})$, and $\lambda_i = \exp(-\gamma \eta_i)$: + +\begin{align} +\begin{split} + h_i(T_i) + & = \exp(-\eta_i) h_0(t \exp(-\eta_i)) \\ + & = \exp(-\eta_i) \gamma {(t \exp(-\eta_i))}^{\gamma - 1} \\ + & = \exp(-\gamma \eta_i) \gamma t^{\gamma - 1} \\ + & = \lambda_i \gamma t^{\gamma - 1} +\end{split} +\end{align} + +\begin{align} +\begin{split} + S_i(T_i) + & = S_0(t \exp(-\eta_i)) \\ + & = \exp(-(T_i \exp(-\eta_i))^{\gamma}) \\ + & = \exp(-T_i^{\gamma} [\exp(-\eta_i)]^{\gamma}) \\ + & = \exp(-T_i^{\gamma} \exp(-\gamma \eta_i)) \\ + & = \exp(-T_i \lambda_i) +\end{split} +\end{align} + + +### Extension to time-dependent coefficients (i.e. time-dependent acceleration factors) + +We can extend the previous model formulations to allow for time-dependent coefficients (i.e. time-dependent acceleration factors). + +The so-called "unmoderated" survival probability for an individual at time $t$ is defined as the baseline survival probability at time $t$, i.e. $S_i(t) = S_0(t)$. With a time-fixed acceleration factor, the survival probability for a so-called "moderated" individual is defined as the baseline survival probability but evaluated at "time $t$ multiplied by the acceleration factor $\exp(-\eta_i)$". That is, the survival probability for the moderated individual is $S_i(t) = S_0(t \exp(-\eta_i))$. + +However, with time-dependent acceleration we cannot simply multiply time by a fixed (acceleration) constant. Instead, we must integrate the function for the time-dependent acceleration factor over the interval $0$ to $t$. In other words, we must evaluate: +\ +\begin{align} +\begin{split} + S_i(t) = S_0 \left( \int_0^t \exp(-\eta_i(u)) du \right) +\end{split} +\end{align} +\ +as described by Hougaard (1999). + +Hougaard also gives a general expression for the hazard function under time-dependent acceleration, as follows: +\ +\begin{align} +\begin{split} + h_i(t) = \exp \left(-\eta_i(t) \right) h_0 \left( \int_0^t \exp(-\eta_i(u)) du \right) +\end{split} +\end{align} + +**Note:** It is interesting to note here that the *hazard* at time $t$ is in fact a function of the full history of covariates and parameters (i.e. the linear predictor) from time $0$ up until time $t$. This is different to the hazard scale formulation of time-dependent effects (i.e. non-proportional hazards). Under the hazard scale formulation with time-dependent effects, the *survival* probability is a function of the full history between times $0$ and $t$, but the *hazard* is **not**; instead, the hazard is only a function of covariates and parameters as defined at the current time. This is particularly important to consider when fitting accelerated failure time models with time-dependent effects in the presence of delayed entry (i.e. left truncation). + +For the exponential distribution, this leads to: + +\begin{align} +\begin{split} + S_i(T_i) + & = S_0 \left( \int_0^{T_i} \exp(-\eta_i(u)) du \right) \\ + & = \exp \left(- \int_0^{T_i} \exp(-\eta_i(u)) du \right) +\end{split} +\end{align} + +\begin{align} +\begin{split} + h_i(T_i) + & = \exp \left(-\eta_i(T_i) \right) h_0 \left( \int_0^{T_i} \exp(-\eta_i(u)) du \right) \\ + & = \exp \left(-\eta_i(T_i) \right) \exp \left(- \int_0^{T_i} \exp(-\eta_i(u)) du \right) +\end{split} +\end{align} + +and for the Weibull distribution, this leads to: + +\begin{align} +\begin{split} + S_i(T_i) + & = S_0 \left( \int_0^{T_i} \exp(-\eta_i(u)) du \right) \\ + & = \exp \left(- \left[\int_0^{T_i} \exp (-\eta_i(u)) du \right]^{\gamma} \right) +\end{split} +\end{align} + +\begin{align} +\begin{split} + h_i(T_i) + & = \exp \left(-\eta_i(T_i) \right) h_0 \left( \int_0^{T_i} \exp(-\eta_i(u)) du \right) \\ + & = \exp \left(-\eta_i(T_i) \right) \exp \left(- \left[\int_0^{T_i} \exp (-\eta_i(u)) du \right]^{\gamma} \right) +\end{split} +\end{align} + +The general expressions for the hazard and survival function under an AFT model with a time-dependent linear predictor are used to evaluate the likelihood for the accelerated failure time model in `stan_surv` when time-dependent effects are specified in the model formula. Specifically, quadrature is used to evaluate the cumulative acceleration factor $\int_0^t \exp(-\eta_i(u)) du$ and this is then substituted into the relevant expressions for the hazard and survival. From 2e8b22aacdd2bcdf18aa2981795b7ae6206cc496 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:14:23 +1100 Subject: [PATCH 095/225] Add tests for AFT models --- tests/testthat/helpers/get_tols_surv.R | 6 +- tests/testthat/helpers/recover_pars_surv.R | 1 + tests/testthat/test_stan_surv.R | 91 +++++++++++++++++++--- 3 files changed, 83 insertions(+), 15 deletions(-) diff --git a/tests/testthat/helpers/get_tols_surv.R b/tests/testthat/helpers/get_tols_surv.R index c3e9da262..da1b2bbde 100644 --- a/tests/testthat/helpers/get_tols_surv.R +++ b/tests/testthat/helpers/get_tols_surv.R @@ -14,12 +14,12 @@ get_tols <- function(mod, tolscales) { cl <- class(mod)[1L] - if (cl == "coxph") { - fixef_ses <- sqrt(diag(mod$var)) + if (cl %in% c("coxph", "survreg")) { + fixef_ses <- sqrt(diag(mod$var))[1:length(mod$coefficients)] fixef_tols <- tolscales$hr_fixef * fixef_ses names(fixef_tols) <- names(mod$coefficients) } - + if ("(Intercept)" %in% names(fixef_tols)) fixef_tols[["(Intercept)"]] <- 2 * fixef_tols[["(Intercept)"]] diff --git a/tests/testthat/helpers/recover_pars_surv.R b/tests/testthat/helpers/recover_pars_surv.R index 673709bc3..fd28e9c7f 100644 --- a/tests/testthat/helpers/recover_pars_surv.R +++ b/tests/testthat/helpers/recover_pars_surv.R @@ -10,6 +10,7 @@ recover_pars <- function(mod) { fixef_pars <- switch(cl, coxph = mod$coefficients, + survreg = mod$coefficients, stansurv = fixef(mod), NULL) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 0e9ea6c50..8ad313e73 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -115,7 +115,9 @@ test_that("basehaz argument works", { es(up(testmod, basehaz = "gompertz")) es(up(testmod, basehaz = "ms")) es(up(testmod, basehaz = "bs")) - + es(up(testmod, basehaz = "exp-aft")) + es(up(testmod, basehaz = "weibull-aft")) + dfl <- list(df = 5) knl <- list(knots = c(1,3,5)) es(up(testmod, basehaz = "ms", basehaz_ops = dfl)) @@ -182,7 +184,7 @@ test_that("prior arguments work", { info = basehaz) } - #---- weibull data + #---- exponential data set.seed(543634) covs <- data.frame(id = 1:300, @@ -230,6 +232,63 @@ test_that("prior arguments work", { compare_surv(data = dat, basehaz = "gompertz") +#---- Compare parameter estimates: stan_surv vs survreg + + compare_surv <- function(data, basehaz = "weibull-aft", ...) { + require(survival) + fm <- Surv(eventtime, status) ~ X1 + X2 + dist <- ifelse(basehaz == "weibull-aft", "weibull", "exponential") + surv1 <- survreg(fm, data, dist = dist) + stan1 <- stan_surv(formula = fm, + data = data, + basehaz = basehaz, + iter = ITER, + refresh = REFRESH, + chains = CHAINS, + seed = SEED, ...) + tols <- get_tols(surv1, tolscales = TOLSCALES) + pars_surv <- recover_pars(surv1) + pars_stan <- recover_pars(stan1) + for (i in names(tols$fixef)) + expect_equal(pars_surv$fixef[[i]], + pars_stan$fixef[[i]], + tol = tols$fixef[[i]], + info = basehaz) + } + + #---- exponential data + + set.seed(543634) + covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) + dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) + dat <- merge(dat, covs) + + compare_surv(data = dat, basehaz = "exp-aft") + + #---- weibull data + + set.seed(543634) + covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) + dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1.3, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) + dat <- merge(dat, covs) + + compare_surv(data = dat, basehaz = "weibull-aft") + + +# COMMENTED OUT TO AVOID ADDING PACKAGES TO SUGGESTS +# # #---- Compare parameter estimates: stan_surv vs icenReg (interval censored) # # #---- simulated interval censored weibull data @@ -349,28 +408,36 @@ test_that("prior arguments work", { o<-SW(f3 <- update(f1, basehaz = "exp")) o<-SW(f4 <- update(f1, basehaz = "weibull")) o<-SW(f5 <- update(f1, basehaz = "gompertz")) + o<-SW(f6 <- update(f1, basehaz = "exp-aft")) + o<-SW(f7 <- update(f1, basehaz = "weibull-aft")) # time-dependent effects - o<-SW(f6 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f7 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f8 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f9 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f10 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f8 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f9 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f10 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f11 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f12 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f13 <- update(f6, Surv(futimeYears, death) ~ sex + tde(trt))) + o<-SW(f14 <- update(f7, Surv(futimeYears, death) ~ sex + tde(trt))) # start-stop notation (incl. delayed entry) - o<-SW(f11 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) - o<-SW(f12 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) + o<-SW(f15 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) + o<-SW(f16 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) + o<-SW(f17 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) + o<-SW(f18 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) # left and interval censoring - o<-SW(f13 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) - o<-SW(f14 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) + o<-SW(f19 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) + o<-SW(f20 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) + o<-SW(f21 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) + o<-SW(f22 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models - for (j in c(1:14)) { + for (j in c(1:22)) { mod <- try(get(paste0("f", j)), silent = TRUE) From 0f9517569b8464cc7aca5917474a5bfb7ee3f4df Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:14:50 +1100 Subject: [PATCH 096/225] Add AFT models to surv.stan --- src/stan_files/surv.stan | 352 ++++++++++++++++++++++++--------------- 1 file changed, 219 insertions(+), 133 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 08c853267..343537ff8 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -311,27 +311,25 @@ functions { /** * Log survival and log CDF for exponential distribution; AFT parameterisation * - * @param eta Vector, linear predictor - * @param t Vector, event or censoring times + * @param caf Vector, cumulative acceleration factor * @return A vector */ - vector exponentialAFT_log_surv(vector eta, vector t) { - vector[rows(eta)] res; - res = - t .* exp(-eta); + vector exponentialAFT_log_surv(vector caf) { + vector[rows(caf)] res; + res = - caf; return res; } - vector exponentialAFT_log_cdf(vector eta, vector t) { - vector[rows(eta)] res; - res = log(1 - exp(-t .* exp(-eta))); + vector exponentialAFT_log_cdf(vector caf) { + vector[rows(caf)] res; + res = log(1 - exp(-caf)); return res; } - vector exponentialAFT_log_cdf2(vector eta, vector t_lower, vector t_upper) { - int N = rows(eta); - vector[N] exp_eta = exp(-eta); - vector[N] surv_lower = exp(-t_lower .* exp_eta); - vector[N] surv_upper = exp(-t_upper .* exp_eta); + vector exponentialAFT_log_cdf2(vector caf_lower, vector caf_upper) { + int N = rows(caf_lower); + vector[N] surv_lower = exp(-caf_lower); + vector[N] surv_upper = exp(-caf_upper); vector[N] res; res = log(surv_lower - surv_upper); return res; @@ -370,28 +368,26 @@ functions { /** * Log survival and log CDF for Weibull distribution; AFT parameterisation * - * @param eta Vector, linear predictor - * @param t Vector, event or censoring times + * @param caf Vector, cumulative acceleration factor * @param shape Real, Weibull shape * @return A vector */ - vector weibullAFT_log_surv(vector eta, vector t, real shape) { - vector[rows(eta)] res; - res = - pow_vec(t, shape) .* exp(-shape * eta); + vector weibullAFT_log_surv(vector caf, real shape) { + vector[rows(caf)] res; + res = - pow_vec(caf, shape); return res; } - vector weibullAFT_log_cdf(vector eta, vector t, real shape) { - vector[rows(eta)] res; - res = log(1 - exp(- pow_vec(t, shape) .* exp(-shape * eta))); + vector weibullAFT_log_cdf(vector caf, real shape) { + vector[rows(caf)] res; + res = log(1 - exp(- pow_vec(caf, shape))); return res; } - vector weibullAFT_log_cdf2(vector eta, vector t_lower, vector t_upper, real shape) { - int N = rows(eta); - vector[N] exp_eta = exp(-shape * eta); - vector[N] surv_lower = exp(- pow_vec(t_lower, shape) .* exp_eta); - vector[N] surv_upper = exp(- pow_vec(t_upper, shape) .* exp_eta); + vector weibullAFT_log_cdf2(vector caf_lower, vector caf_upper, real shape) { + int N = rows(caf_lower); + vector[N] surv_lower = exp(- pow_vec(caf_lower, shape)); + vector[N] surv_upper = exp(- pow_vec(caf_upper, shape)); vector[N] res; res = log(surv_lower - surv_upper); return res; @@ -470,10 +466,12 @@ data { int nrcens; // num. rows w/ right censoring int nicens; // num. rows w/ interval censoring int ndelay; // num. rows w/ delayed entry - int qnodes; // num. nodes for GK quadrature int Nevent; // num. rows w/ an event; used only w/ quadrature int Nlcens; // num. rows w/ left cens; used only w/ quadrature + int Nrcens; // num. rows w/ right cens; used only w/ quadrature int Nicens; // num. rows w/ interval cens; used only w/ quadrature + int Ndelay; // num. rows w/ delayed entry; used only w/ quadrature + int qnodes; // num. nodes for GK quadrature int qevent; // num. quadrature points for rows w/ an event int qlcens; // num. quadrature points for rows w/ left censoring int qrcens; // num. quadrature points for rows w/ right censoring @@ -714,60 +712,82 @@ model { if (ndelay > 0) eta_delay += gamma[1]; } - // evaluate log hazard and log survival - if (type == 5) { // exponential model - if (nevent > 0) target += exponential_log_haz (eta_event); - if (nevent > 0) target += exponential_log_surv(eta_event, t_event); - if (nlcens > 0) target += exponential_log_cdf (eta_lcens, t_lcens); - if (nrcens > 0) target += exponential_log_surv(eta_rcens, t_rcens); - if (nicens > 0) target += exponential_log_cdf2(eta_icens, t_icenl, t_icenu); - if (ndelay > 0) target += -exponential_log_surv(eta_delay, t_delay); - } - else if (type == 7) { // exponential AFT model - if (nevent > 0) target += exponentialAFT_log_haz (eta_event); - if (nevent > 0) target += exponentialAFT_log_surv(eta_event, t_event); - if (nlcens > 0) target += exponentialAFT_log_cdf (eta_lcens, t_lcens); - if (nrcens > 0) target += exponentialAFT_log_surv(eta_rcens, t_rcens); - if (nicens > 0) target += exponentialAFT_log_cdf2(eta_icens, t_icenl, t_icenu); - if (ndelay > 0) target += -exponentialAFT_log_surv(eta_delay, t_delay); - } - else if (type == 1) { // weibull model - real shape = coefs[1]; - if (nevent > 0) target += weibull_log_haz (eta_event, t_event, shape); - if (nevent > 0) target += weibull_log_surv(eta_event, t_event, shape); - if (nlcens > 0) target += weibull_log_cdf (eta_lcens, t_lcens, shape); - if (nrcens > 0) target += weibull_log_surv(eta_rcens, t_rcens, shape); - if (nicens > 0) target += weibull_log_cdf2(eta_icens, t_icenl, t_icenu, shape); - if (ndelay > 0) target += -weibull_log_surv(eta_delay, t_delay, shape); - } - else if (type == 8) { // weibull AFT model - real shape = coefs[1]; - if (nevent > 0) target += weibullAFT_log_haz (eta_event, t_event, shape); - if (nevent > 0) target += weibullAFT_log_surv(eta_event, t_event, shape); - if (nlcens > 0) target += weibullAFT_log_cdf (eta_lcens, t_lcens, shape); - if (nrcens > 0) target += weibullAFT_log_surv(eta_rcens, t_rcens, shape); - if (nicens > 0) target += weibullAFT_log_cdf2(eta_icens, t_icenl, t_icenu, shape); - if (ndelay > 0) target += -weibullAFT_log_surv(eta_delay, t_delay, shape); - } - else if (type == 6) { // gompertz model - real scale = coefs[1]; - if (nevent > 0) target += gompertz_log_haz (eta_event, t_event, scale); - if (nevent > 0) target += gompertz_log_surv(eta_event, t_event, scale); - if (nlcens > 0) target += gompertz_log_cdf (eta_lcens, t_lcens, scale); - if (nrcens > 0) target += gompertz_log_surv(eta_rcens, t_rcens, scale); - if (nicens > 0) target += gompertz_log_cdf2(eta_icens, t_icenl, t_icenu, scale); - if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); - } - else if (type == 4) { // M-splines, on haz scale - if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs); - if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs); - if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs); - if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs); - if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs); - if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs); + // aft models + if (type == 7 || type == 8) { + + // acceleration factor at event times + vector[nevent] af_event = exp(-eta_event); + + // cumulative acceleration factors + vector[nevent] caf_event = t_event .* exp(-eta_event); + vector[nlcens] caf_lcens = t_lcens .* exp(-eta_lcens); + vector[nrcens] caf_rcens = t_rcens .* exp(-eta_rcens); + vector[nicens] caf_icenl = t_icenl .* exp(-eta_icens); + vector[nicens] caf_icenu = t_icenu .* exp(-eta_icens); + vector[ndelay] caf_delay = t_delay .* exp(-eta_delay); + + // increment target with log-lik contributions + if (type == 7) { // exponential AFT model + if (nevent > 0) target += exponentialAFT_log_haz (af_event); + if (nevent > 0) target += exponentialAFT_log_surv(caf_event); + if (nlcens > 0) target += exponentialAFT_log_cdf (caf_lcens); + if (nrcens > 0) target += exponentialAFT_log_surv(caf_rcens); + if (nicens > 0) target += exponentialAFT_log_cdf2(caf_icenl, caf_icenu); + if (ndelay > 0) target += -exponentialAFT_log_surv(caf_delay); + } else if (type == 8) { // weibull AFT model + real shape = coefs[1]; + if (nevent > 0) target += weibullAFT_log_haz (af_event, caf_event, shape); + if (nevent > 0) target += weibullAFT_log_surv(caf_event, shape); + if (nlcens > 0) target += weibullAFT_log_cdf (caf_lcens, shape); + if (nrcens > 0) target += weibullAFT_log_surv(caf_rcens, shape); + if (nicens > 0) target += weibullAFT_log_cdf2(caf_icenl, caf_icenu, shape); + if (ndelay > 0) target += -weibullAFT_log_surv(caf_delay, shape); + } + } + + // hazard models else { - reject("Bug found: invalid baseline hazard (without quadrature)."); + + // evaluate log hazard and log survival + if (type == 5) { // exponential model + if (nevent > 0) target += exponential_log_haz (eta_event); + if (nevent > 0) target += exponential_log_surv(eta_event, t_event); + if (nlcens > 0) target += exponential_log_cdf (eta_lcens, t_lcens); + if (nrcens > 0) target += exponential_log_surv(eta_rcens, t_rcens); + if (nicens > 0) target += exponential_log_cdf2(eta_icens, t_icenl, t_icenu); + if (ndelay > 0) target += -exponential_log_surv(eta_delay, t_delay); + } + else if (type == 1) { // weibull model + real shape = coefs[1]; + if (nevent > 0) target += weibull_log_haz (eta_event, t_event, shape); + if (nevent > 0) target += weibull_log_surv(eta_event, t_event, shape); + if (nlcens > 0) target += weibull_log_cdf (eta_lcens, t_lcens, shape); + if (nrcens > 0) target += weibull_log_surv(eta_rcens, t_rcens, shape); + if (nicens > 0) target += weibull_log_cdf2(eta_icens, t_icenl, t_icenu, shape); + if (ndelay > 0) target += -weibull_log_surv(eta_delay, t_delay, shape); + } + else if (type == 6) { // gompertz model + real scale = coefs[1]; + if (nevent > 0) target += gompertz_log_haz (eta_event, t_event, scale); + if (nevent > 0) target += gompertz_log_surv(eta_event, t_event, scale); + if (nlcens > 0) target += gompertz_log_cdf (eta_lcens, t_lcens, scale); + if (nrcens > 0) target += gompertz_log_surv(eta_rcens, t_rcens, scale); + if (nicens > 0) target += gompertz_log_cdf2(eta_icens, t_icenl, t_icenu, scale); + if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); + } + else if (type == 4) { // M-splines, on haz scale + if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs); + if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs); + if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs); + if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs); + if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs); + if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs); + } + else { + reject("Bug found: invalid baseline hazard (without quadrature)."); + } + } } @@ -776,15 +796,6 @@ model { else { vector[len_cpts] eta; // linear predictor at event and quadrature times - vector[len_cpts] lhaz; // log hazard at event and quadrature times - - vector[Nevent] lhaz_epts_event; - vector[qevent] lhaz_qpts_event; - vector[qlcens] lhaz_qpts_lcens; - vector[qrcens] lhaz_qpts_rcens; - vector[qicens] lhaz_qpts_icenl; - vector[qicens] lhaz_qpts_icenu; - vector[qdelay] lhaz_qpts_delay; // linear predictor (time-fixed part) if (K > 0) { @@ -804,54 +815,129 @@ model { eta += gamma[1]; } - // evaluate log hazard - if (type == 5) { // exponential model - lhaz = exponential_log_haz(eta); - } - else if (type == 7) { // exponential AFT model - lhaz = exponentialAFT_log_haz(eta); - } - else if (type == 1) { // weibull model - real shape = coefs[1]; - lhaz = weibull_log_haz(eta, cpts, shape); - } - else if (type == 8) { // weibull AFT model - real shape = coefs[1]; - lhaz = weibullAFT_log_haz(eta, cpts, shape); - } - else if (type == 6) { // gompertz model - real scale = coefs[1]; - lhaz = gompertz_log_haz(eta, cpts, scale); - } - else if (type == 4) { // M-splines, on haz scale - lhaz = mspline_log_haz(eta, basis_cpts, coefs); - } - else if (type == 2) { // B-splines, on log haz scale - lhaz = bspline_log_haz(eta, basis_cpts, coefs); + // aft models + if (type == 7 || type == 8) { + + vector[Nevent] eta_epts_event; + vector[qevent] eta_qpts_event; + vector[qlcens] eta_qpts_lcens; + vector[qrcens] eta_qpts_rcens; + vector[qicens] eta_qpts_icenl; + vector[qicens] eta_qpts_icenu; + vector[qdelay] eta_qpts_delay; + + vector[Nevent] af_event; + + vector[Nevent] caf_event; + vector[Nlcens] caf_lcens; + vector[Nrcens] caf_rcens; + vector[Nicens] caf_icenl; + vector[Nicens] caf_icenu; + vector[Ndelay] caf_delay; + + // split linear predictor based on event types + if (Nevent > 0) eta_epts_event = eta[idx_cpts[1,1]:idx_cpts[1,2]]; + if (qevent > 0) eta_qpts_event = eta[idx_cpts[2,1]:idx_cpts[2,2]]; + if (qlcens > 0) eta_qpts_lcens = eta[idx_cpts[3,1]:idx_cpts[3,2]]; + if (qrcens > 0) eta_qpts_rcens = eta[idx_cpts[4,1]:idx_cpts[4,2]]; + if (qicens > 0) eta_qpts_icenl = eta[idx_cpts[5,1]:idx_cpts[5,2]]; + if (qicens > 0) eta_qpts_icenu = eta[idx_cpts[6,1]:idx_cpts[6,2]]; + if (qdelay > 0) eta_qpts_delay = eta[idx_cpts[7,1]:idx_cpts[7,2]]; + + // acceleration factor at event time + if (Nevent > 0) af_event = exp(-eta_epts_event); + + // evaluate cumulative acceleration factors + if (qevent > 0) caf_event = quadrature_aft(qwts_event, eta_qpts_event, qnodes, Nevent); + if (qlcens > 0) caf_lcens = quadrature_aft(qwts_lcens, eta_qpts_lcens, qnodes, Nlcens); + if (qrcens > 0) caf_rcens = quadrature_aft(qwts_rcens, eta_qpts_rcens, qnodes, Nrcens); + if (qicens > 0) caf_icenl = quadrature_aft(qwts_icenl, eta_qpts_icenl, qnodes, Nicens); + if (qicens > 0) caf_icenu = quadrature_aft(qwts_icenu, eta_qpts_icenu, qnodes, Nicens); + if (qdelay > 0) caf_delay = quadrature_aft(qwts_delay, eta_qpts_delay, qnodes, Ndelay); + + // increment target with log-lik contributions + if (type == 7) { // exponential AFT model + if (nevent > 0) target += exponentialAFT_log_haz (af_event); + if (nevent > 0) target += exponentialAFT_log_surv(caf_event); + if (nlcens > 0) target += exponentialAFT_log_cdf (caf_lcens); + if (nrcens > 0) target += exponentialAFT_log_surv(caf_rcens); + if (nicens > 0) target += exponentialAFT_log_cdf2(caf_icenl, caf_icenu); + if (ndelay > 0) target += -exponentialAFT_log_surv(caf_delay); + } else if (type == 8) { // weibull AFT model + real shape = coefs[1]; + if (nevent > 0) target += weibullAFT_log_haz (af_event, caf_event, shape); + if (nevent > 0) target += weibullAFT_log_surv(caf_event, shape); + if (nlcens > 0) target += weibullAFT_log_cdf (caf_lcens, shape); + if (nrcens > 0) target += weibullAFT_log_surv(caf_rcens, shape); + if (nicens > 0) target += weibullAFT_log_cdf2(caf_icenl, caf_icenu, shape); + if (ndelay > 0) target += -weibullAFT_log_surv(caf_delay, shape); + } + } + + // hazard models else { - reject("Bug found: invalid baseline hazard (with quadrature)."); - } - // split log hazard vector based on event types - if (Nevent > 0) lhaz_epts_event = lhaz[idx_cpts[1,1]:idx_cpts[1,2]]; - if (qevent > 0) lhaz_qpts_event = lhaz[idx_cpts[2,1]:idx_cpts[2,2]]; - if (qlcens > 0) lhaz_qpts_lcens = lhaz[idx_cpts[3,1]:idx_cpts[3,2]]; - if (qrcens > 0) lhaz_qpts_rcens = lhaz[idx_cpts[4,1]:idx_cpts[4,2]]; - if (qicens > 0) lhaz_qpts_icenl = lhaz[idx_cpts[5,1]:idx_cpts[5,2]]; - if (qicens > 0) lhaz_qpts_icenu = lhaz[idx_cpts[6,1]:idx_cpts[6,2]]; - if (qdelay > 0) lhaz_qpts_delay = lhaz[idx_cpts[7,1]:idx_cpts[7,2]]; - - // increment target with log-lik contributions for event submodel - if (Nevent > 0) target += lhaz_epts_event; - if (qevent > 0) target += quadrature_log_surv(qwts_event, lhaz_qpts_event); - if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, - qnodes, Nlcens); - if (qrcens > 0) target += quadrature_log_surv(qwts_rcens, lhaz_qpts_rcens); - if (qicens > 0) target += quadrature_log_cdf2(qwts_icenl, lhaz_qpts_icenl, - qwts_icenu, lhaz_qpts_icenu, - qnodes, Nicens); - if (qdelay > 0) target += -quadrature_log_surv(qwts_delay, lhaz_qpts_delay); + vector[len_cpts] lhaz; // log hazard at event and quadrature times + + vector[Nevent] lhaz_epts_event; + vector[qevent] lhaz_qpts_event; + vector[qlcens] lhaz_qpts_lcens; + vector[qrcens] lhaz_qpts_rcens; + vector[qicens] lhaz_qpts_icenl; + vector[qicens] lhaz_qpts_icenu; + vector[qdelay] lhaz_qpts_delay; + + // evaluate log hazard + if (type == 5) { // exponential model + lhaz = exponential_log_haz(eta); + } + else if (type == 7) { // exponential AFT model + lhaz = exponentialAFT_log_haz(eta); + } + else if (type == 1) { // weibull model + real shape = coefs[1]; + lhaz = weibull_log_haz(eta, cpts, shape); + } + else if (type == 8) { // weibull AFT model + real shape = coefs[1]; + lhaz = weibullAFT_log_haz(eta, cpts, shape); + } + else if (type == 6) { // gompertz model + real scale = coefs[1]; + lhaz = gompertz_log_haz(eta, cpts, scale); + } + else if (type == 4) { // M-splines, on haz scale + lhaz = mspline_log_haz(eta, basis_cpts, coefs); + } + else if (type == 2) { // B-splines, on log haz scale + lhaz = bspline_log_haz(eta, basis_cpts, coefs); + } + else { + reject("Bug found: invalid baseline hazard (with quadrature)."); + } + + // split log hazard vector based on event types + if (Nevent > 0) lhaz_epts_event = lhaz[idx_cpts[1,1]:idx_cpts[1,2]]; + if (qevent > 0) lhaz_qpts_event = lhaz[idx_cpts[2,1]:idx_cpts[2,2]]; + if (qlcens > 0) lhaz_qpts_lcens = lhaz[idx_cpts[3,1]:idx_cpts[3,2]]; + if (qrcens > 0) lhaz_qpts_rcens = lhaz[idx_cpts[4,1]:idx_cpts[4,2]]; + if (qicens > 0) lhaz_qpts_icenl = lhaz[idx_cpts[5,1]:idx_cpts[5,2]]; + if (qicens > 0) lhaz_qpts_icenu = lhaz[idx_cpts[6,1]:idx_cpts[6,2]]; + if (qdelay > 0) lhaz_qpts_delay = lhaz[idx_cpts[7,1]:idx_cpts[7,2]]; + + // increment target with log-lik contributions for event submodel + if (Nevent > 0) target += lhaz_epts_event; + if (qevent > 0) target += quadrature_log_surv(qwts_event, lhaz_qpts_event); + if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, + qnodes, Nlcens); + if (qrcens > 0) target += quadrature_log_surv(qwts_rcens, lhaz_qpts_rcens); + if (qicens > 0) target += quadrature_log_cdf2(qwts_icenl, lhaz_qpts_icenl, + qwts_icenu, lhaz_qpts_icenu, + qnodes, Nicens); + if (qdelay > 0) target += -quadrature_log_surv(qwts_delay, lhaz_qpts_delay); + + } } From 514fee14d9b4807de3aff3b7f5ddbf03f39e4337 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:15:10 +1100 Subject: [PATCH 097/225] Add AFT models to hazard_functions.stan --- .../functions/hazard_functions.stan | 36 ++++++++++++++----- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan index 6fd20b038..226dc3be0 100644 --- a/src/stan_files/functions/hazard_functions.stan +++ b/src/stan_files/functions/hazard_functions.stan @@ -11,11 +11,11 @@ /** * Log hazard for exponential distribution; AFT parameterisation * - * @param eta Vector, linear predictor + * @param af Vector, acceleration factor at time t * @return A vector */ - vector exponentialAFT_log_haz(vector eta) { - return -eta; + vector exponentialAFT_log_haz(vector af) { + return log(af); } /** @@ -35,14 +35,14 @@ /** * Log hazard for Weibull distribution; AFT parameterisation * - * @param eta Vector, linear predictor - * @param t Vector, event or censoring times + * @param af Vector, acceleration factor at time t + * @param caf Vector, cumulative acceleration factor at time t * @param shape Real, Weibull shape * @return A vector */ - vector weibullAFT_log_haz(vector eta, vector t, real shape) { - vector[rows(eta)] res; - res = log(shape) + (shape - 1) * log(t) - (shape * eta); + vector weibullAFT_log_haz(vector af, vector caf, real shape) { + vector[rows(af)] res; + res = log(shape) + (shape - 1) * log(caf) + log(af); return res; } @@ -133,3 +133,23 @@ res = log(surv_lower - surv_upper); return res; } + + + /** + * Evaluate cumulative acceleration factor from the linear predictor evaluated + * at quadrature points and a corresponding vector of quadrature weights + * + * @param qwts Vector, the quadrature weights + * @param eta Vector, linear predictor at the quadrature points + * @param qnodes Integer, the number of quadrature points for each individual + * @param N Integer, the number of individuals (ie. rows(eta) / qnodes) + * @return A vector + */ + vector quadrature_aft(vector qwts, vector eta, int qnodes, int N) { + int M = rows(eta); + vector[M] af = exp(-eta); // time-dependent acceleration factor + matrix[N,qnodes] qwts_mat = to_matrix(qwts, N, qnodes); + matrix[N,qnodes] af_mat = to_matrix(af, N, qnodes); + vector[N] caf = rows_dot_product(qwts_mat, af_mat); + return caf; // cumulative acceleration factor + } From b23d56c590010e34480ac37df47e90506dcf1c29 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:15:55 +1100 Subject: [PATCH 098/225] Add AFT models to stan_surv documentation, and add a few standata items --- R/stan_surv.R | 78 +++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 70 insertions(+), 8 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 4313076e0..1c01ec551 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -184,7 +184,63 @@ #' to the appropriate length. #' #' @details -#' \subsection{Time dependent effects}{ +#' \subsection{Model formulations}{ +#' Let \eqn{h_i(t)} denote the hazard for individual \eqn{i} at time +#' \eqn{t}, \eqn{h_0(t)} the baseline hazard at time \eqn{t}, \eqn{X_i} +#' a vector of covariates for individual \eqn{i}, \eqn{\beta} a vector of +#' coefficients, \eqn{S_i(t)} the survival probability for individual +#' \eqn{i} at time \eqn{t}, and \eqn{S_0(t)} the baseline survival +#' probability at time \eqn{t}. Without time-dependent effects in the +#' model formula our linear predictor is \eqn{\eta_i = X_i \beta}, whereas +#' with time-dependent effects in the model formula our linear predictor +#' is \eqn{\eta_i(t) = X_i(t) \beta(t)}. Then the following definitions of +#' the hazard function and survival function apply: +#' +#' \tabular{llll}{ +#' \strong{Scale } \tab +#' \strong{TDE } \tab +#' \strong{Hazard } \tab +#' \strong{Survival } \cr +#' \emph{Hazard} \tab +#' \emph{No} \tab +#' \eqn{h_i(t) = h_0(t) \exp(\eta_i)} \tab +#' \eqn{S_i(t) = [S_0(t)]^{\exp(\eta_i)}} \cr +#' \emph{Hazard} \tab +#' \emph{Yes} \tab +#' \eqn{h_i(t) = h_0(t) \exp(\eta_i(t))} \tab +#' \eqn{S_i(t) = \exp(- \int_0^t h_i(u) du )} \cr +#' \emph{AFT} \tab +#' \emph{No} \tab +#' \eqn{h_i(t) = \exp(-\eta_i) h_0 (t \exp(-\eta_i))} \tab +#' \eqn{S_i(t) = S_0 ( t \exp(-\eta_i) )} \cr +#' \emph{AFT} \tab +#' \emph{Yes} \tab +#' \eqn{h_i(t) = \exp(-\eta_i(t)) h_0(\int_0^t \exp(-\eta_i(u)) du)} \tab +#' \eqn{S_i(t) = S_0 (\int_0^t \exp(-\eta_i(u)) du)} \cr +#' } +#' +#' where \emph{AFT} stands for an accelerated failure time formulation, +#' and \emph{TDE} stands for time dependent effects in the model formula. +#' +#' For models without time-dependent effects, the value of \eqn{S_i(t)} can +#' be calculated analytically (with the one exception being when B-splines +#' are used to model the log baseline hazard, i.e. \code{basehaz = "bs"}). +#' +#' For models with time-dependent effects \eqn{S_i(t)} cannot be calculated +#' analytically and so Gauss-Kronrod quadrature is used to approximate the +#' relevant integral. The number of nodes used in the quadrature can be +#' controlled via the \code{nodes} argument. +#' +#' For models estimated on the hazard scale, a hazard ratio can be calculated +#' as \eqn{\exp(\beta)}. For models estimated on the AFT scale, a survival +#' time ratio can be calculated as \eqn{\exp(\beta)} and an acceleration +#' factor can be calculated as \eqn{\exp(-\beta)}. +#' +#' Note that the \emph{stan_surv: Survival (Time-to-Event) Models} vignette +#' provides more extensive details on the model formulations, including the +#' parameterisations for each of the parametric distributions. +#' } +#' \subsection{More details on time dependent effects}{ #' By default, any covariate effects specified in the \code{formula} are #' included in the model under a proportional hazards assumption (for models #' estimated using a hazard scale formulation) or under the assumption of @@ -202,7 +258,8 @@ #' \item Estimating a time-dependent coefficient under an accelerated failure #' time model formulation (i.e. when \code{basehaz} is set equal to #' \code{"exp-aft"}, or \code{"weibull-aft"}) leads to the estimation of a -#' time-dependent acceleration factor for the relevant covariate. +#' time-dependent acceleration factor -- or equivalently, a +#' time-dependent survival time ratio -- for the relevant covariate. #' } #' #' A time-dependent effect can be specified in the model \code{formula} @@ -297,23 +354,26 @@ #' #' #---------- Compare PH and AFT parameterisations #' +#' # Breast cancer data +#' sel <- sample(1:nrow(bcancer), 100) +#' #' m_ph <- stan_surv(Surv(recyrs, status) ~ group, -#' data = bcancer[1:100,], +#' data = bcancer[sel,], #' basehaz = "weibull", #' chains = 1, #' refresh = 0, #' iter = 600, #' seed = 123) #' m_aft <- stan_surv(Surv(recyrs, status) ~ group, -#' data = bcancer[1:100,], +#' data = bcancer[sel,], #' basehaz = "weibull-aft", #' chains = 1, #' refresh = 0, #' iter = 600, #' seed = 123) #' -#' fixef(m_ph) [c('groupMedium', 'groupPoor')] # hazard ratios -#' fixef(m_aft)[c('groupMedium', 'groupPoor')] # acceleration factors +#' exp(fixef(m_ph)) [c('groupMedium', 'groupPoor')] # hazard ratios +#' exp(fixef(m_aft))[c('groupMedium', 'groupPoor')] # survival time ratios #' #' # same model (...slight differences due to sampling) #' summary(m_ph, par = "log-posterior")[, 'mean'] @@ -593,13 +653,15 @@ stan_surv <- function(formula, qnodes = if (!has_quadrature) 0L else qnodes, Nevent = if (!has_quadrature) 0L else nevent, + Nlcens = if (!has_quadrature) 0L else nlcens, + Nrcens = if (!has_quadrature) 0L else nrcens, + Nicens = if (!has_quadrature) 0L else nicens, + Ndelay = if (!has_quadrature) 0L else ndelay, qevent = if (!has_quadrature) 0L else qevent, qlcens = if (!has_quadrature) 0L else qlcens, qrcens = if (!has_quadrature) 0L else qrcens, qicens = if (!has_quadrature) 0L else qicens, qdelay = if (!has_quadrature) 0L else qdelay, - Nlcens = if (!has_quadrature) 0L else nlcens, - Nicens = if (!has_quadrature) 0L else nicens, x_cpts = if (!has_quadrature) matrix(0,0,K) else x_cpts, s_cpts = if (!has_quadrature) matrix(0,0,S) else s_cpts, From e6a744d55e818924123990d95cc3ab90142a14ad Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:16:31 +1100 Subject: [PATCH 099/225] Add plots of time-varying acceleration factor to plot.stansurv --- R/plots.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/plots.R b/R/plots.R index ae9a4813a..5db88ad26 100644 --- a/R/plots.R +++ b/R/plots.R @@ -256,15 +256,15 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, times__ <- times basis <- eval(parse(text = x$formula$td_basis[sel1])) basis <- add_intercept(basis) - log_hr <- linear_predictor(betas, basis) - plotdat <- median_and_bounds(exp(log_hr), prob, na.rm = TRUE) - plotdat <- data.frame(times, plotdat) - + coef <- linear_predictor(betas, basis) + is_aft <- get_basehaz_name(x$basehaz) %in% c("exp-aft", "weibull-aft") - ylab <- ifelse(is_aft, "Acceleration factor", "Hazard ratio") - xlab <- "Time" + plotdat <- median_and_bounds(exp(coef), prob, na.rm = TRUE) + plotdat <- data.frame(times, plotdat) + xlab <- "Time" + ylab <- ifelse(is_aft, "Survival time ratio", "Hazard ratio") } geom_defs <- list(color = "black") # default plot args From 43370aaf4679a96cf9fe36a83d0830597716e208 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:39:07 +1100 Subject: [PATCH 100/225] Add AFT models to doc on rstanarm modelling functions --- R/doc-modeling-functions.R | 17 +++++++++-------- R/stan_surv.R | 3 ++- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/R/doc-modeling-functions.R b/R/doc-modeling-functions.R index 841d8878c..502d7ef79 100644 --- a/R/doc-modeling-functions.R +++ b/R/doc-modeling-functions.R @@ -76,16 +76,17 @@ #' group-specific terms as in \code{\link{stan_glmer}}. #' } #' \item{\code{\link{stan_surv}}}{ -#' Fits models to survival (i.e. time-to-event) data on the hazard scale. -#' The user can choose between a variety of standard parametric distributions -#' for the baseline hazard, or a flexible parametric model (using either -#' M-splines for modelling the baseline hazard, or B-splines for modelling -#' the log baseline hazard). Covariate effects can be accommodated under -#' proportional hazards or non-proportional hazards (i.e. time-dependent -#' effects). +#' Fits models to survival (i.e. time-to-event) data using either a hazard +#' scale or accelerated failure time (AFT) formulation. The user can choose +#' between either a flexible spline-based approximation for the baseline +#' hazard or a standard parametric distributional assumption for the baseline +#' hazard. Covariate effects can then be accommodated under proportional or +#' non-proportional hazards assumptions (for models on the hazard scale) or +#' using time-fixed or time-varying acceleration factors (for models on the +#' AFT scale). #' } #' \item{\code{\link{stan_jm}}}{ -#' Estimates shared parameter joint models for longitudinal and survival (i.e. +#' Fits shared parameter joint models for longitudinal and survival (i.e. #' time-to-event) data. The joint model can be univariate (i.e. one longitudinal #' outcome) or multivariate (i.e. more than one longitudinal outcome). A variety #' of parameterisations are available for linking the longitudinal and event diff --git a/R/stan_surv.R b/R/stan_surv.R index 1c01ec551..932133dd6 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -32,7 +32,8 @@ #' time-dependent acceleration factors. #' Where relevant, time-dependent effects (i.e. time-dependent hazard ratios #' or time-dependent acceleration factors) are modelled using a flexible -#' cubic spline-based function for the time-dependent coefficient. +#' cubic spline-based function for the time-dependent coefficient in the +#' linear predictor. #' #' @export #' @importFrom splines bs From df34a6ba8468e1f9af11cdf528932fcc0c4e8810 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 29 Nov 2018 17:42:22 +1100 Subject: [PATCH 101/225] Add Eren Elci as contributor in DESCRIPTION --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index c0e226f57..0405165bf 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -9,6 +9,7 @@ Authors@R: c(person("Jonah", "Gabry", email = "jsg2201@columbia.edu", role = "au person(given = "Jacqueline Buros", family = "Novik", role = "ctb", comment = "R/stan_jm.R"), person("AstraZeneca", role = "ctb", comment = "R/stan_jm.R"), + person("Eren", "Elci", role = "ctb", comment = "R/stan_surv.R"), person("Trustees of", "Columbia University", role = "cph"), person("Simon", "Wood", role = "cph", comment = "R/stan_gamm4.R"), person("R Core", "Deveopment Team", role = "cph", From 0b39f0046c413f3cd744f449bfa35778fcc8d8fe Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 4 Dec 2018 14:36:22 +1100 Subject: [PATCH 102/225] surv.stan: remove use of cpts --- src/stan_files/surv.stan | 213 +++++++++++++++++++++++---------------- 1 file changed, 126 insertions(+), 87 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 343537ff8..a54e61d2b 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -480,8 +480,6 @@ data { int nvars; // num. aux parameters for baseline hazard int smooth_map[S]; // indexing of smooth sds for tde spline coefs int smooth_idx[S > 0 ? max(smooth_map) : 0, 2]; - int idx_cpts[7,2]; // index for breaking cpts into epts,qpts_event,etc - int len_cpts; // response and time variables vector[nevent] t_event; // time of events @@ -490,24 +488,33 @@ data { vector[nicens] t_icenl; // time of lower limit for interval censoring vector[nicens] t_icenu; // time of upper limit for interval censoring vector[ndelay] t_delay; // time of entry for delayed entry - vector[len_cpts] cpts; // time at events and all quadrature points - // predictor matrices (time-fixed) + // predictor matrices (time-fixed), without quadrature matrix[nevent,K] x_event; // for rows with events matrix[nlcens,K] x_lcens; // for rows with left censoring matrix[nrcens,K] x_rcens; // for rows with right censoring matrix[nicens,K] x_icens; // for rows with interval censoring matrix[ndelay,K] x_delay; // for rows with delayed entry - matrix[len_cpts,K] x_cpts; // for rows at events and all quadrature points - // predictor matrices (time-varying) - matrix[len_cpts,S] s_cpts; // for rows at events and all quadrature points + // predictor matrices (time-fixed), with quadrature + matrix[Nevent,K] x_epts_event; // for rows with events + matrix[qevent,K] x_qpts_event; // for rows with events + matrix[qlcens,K] x_qpts_lcens; // for rows with left censoring + matrix[qrcens,K] x_qpts_rcens; // for rows with right censoring + matrix[qicens,K] x_qpts_icens; // for rows with interval censoring + matrix[qdelay,K] x_qpts_delay; // for rows with delayed entry - // basis matrices for M-splines + // predictor matrices (time-varying) + matrix[Nevent,S] s_epts_event; // for rows with events + matrix[qevent,S] s_qpts_event; // for rows with events + matrix[qlcens,S] s_qpts_lcens; // for rows with left censoring + matrix[qrcens,S] s_qpts_rcens; // for rows with right censoring + matrix[qicens,S] s_qpts_icenl; // for rows with interval censoring + matrix[qicens,S] s_qpts_icenu; // for rows with interval censoring + matrix[qdelay,S] s_qpts_delay; // for rows with delayed entry + + // basis matrices for M-splines / I-splines, without quadrature matrix[nevent,nvars] basis_event; // at event time - matrix[len_cpts,nvars] basis_cpts; // at event times and all quadrature points - - // basis matrices for I-splines matrix[nevent,nvars] ibasis_event; // at event time matrix[nlcens,nvars] ibasis_lcens; // at left censoring time matrix[nrcens,nvars] ibasis_rcens; // at right censoring time @@ -515,6 +522,15 @@ data { matrix[nicens,nvars] ibasis_icenu; // at upper limit of interval censoring matrix[ndelay,nvars] ibasis_delay; // at delayed entry time + // basis matrices for M-splines, with quadrature + matrix[Nevent,nvars] basis_epts_event; // at event time + matrix[qevent,nvars] basis_qpts_event; // at qpts for event time + matrix[qlcens,nvars] basis_qpts_lcens; // at qpts for left censoring time + matrix[qrcens,nvars] basis_qpts_rcens; // at qpts for right censoring time + matrix[qicens,nvars] basis_qpts_icenl; // at qpts for lower limit of icens time + matrix[qicens,nvars] basis_qpts_icenu; // at qpts for upper limit of icens time + matrix[qdelay,nvars] basis_qpts_delay; // at qpts for delayed entry time + // baseline hazard type: // 1 = weibull // 2 = B-splines @@ -644,10 +660,10 @@ transformed parameters { // define log hazard ratios if (K > 0) { - beta = make_beta(z_beta, prior_dist, prior_mean, - prior_scale, prior_df, global_prior_scale, - global, local, ool, mix, rep_array(1.0, 0), 0, - slab_scale, caux); + beta = make_beta(z_beta, + prior_dist, prior_mean, prior_scale, prior_df, + global_prior_scale, global, local, ool, mix, + rep_array(1.0, 0), 0, slab_scale, caux); } // define basehaz parameters @@ -681,11 +697,11 @@ model { if (has_quadrature == 0) { - vector[nevent] eta_event; // linear predictor for events - vector[nlcens] eta_lcens; // linear predictor for left censored - vector[nrcens] eta_rcens; // linear predictor for right censored - vector[nicens] eta_icens; // linear predictor for interval censored - vector[ndelay] eta_delay; // linear predictor for delayed entry + vector[nevent] eta_event; // for events + vector[nlcens] eta_lcens; // for left censored + vector[nrcens] eta_rcens; // for right censored + vector[nicens] eta_icens; // for interval censored + vector[ndelay] eta_delay; // for delayed entry // linear predictor if (K > 0) { @@ -795,37 +811,59 @@ model { else { - vector[len_cpts] eta; // linear predictor at event and quadrature times + vector[Nevent] eta_epts_event; // for event times + vector[qlcens] eta_qpts_event; // for qpts for event time + vector[qlcens] eta_qpts_lcens; // for qpts for left censoring time + vector[qrcens] eta_qpts_rcens; // for qpts for right censoring time + vector[qicens] eta_qpts_icenl; // for qpts for lower limit of icens time + vector[qicens] eta_qpts_icenu; // for qpts for upper limit of icens time + vector[qdelay] eta_qpts_delay; // for qpts for delayed entry time // linear predictor (time-fixed part) if (K > 0) { - eta = x_cpts * beta; + if (Nevent > 0) eta_epts_event = x_epts_event * beta; + if (qevent > 0) eta_qpts_event = x_qpts_event * beta; + if (qlcens > 0) eta_qpts_lcens = x_qpts_lcens * beta; + if (qrcens > 0) eta_qpts_rcens = x_qpts_rcens * beta; + if (qicens > 0) eta_qpts_icenl = x_qpts_icens * beta; + if (qicens > 0) eta_qpts_icenu = x_qpts_icens * beta; + if (qdelay > 0) eta_qpts_delay = x_qpts_delay * beta; } else { - eta = rep_vector(0.0, len_cpts); + if (Nevent > 0) eta_epts_event = rep_vector(0.0, Nevent); + if (qevent > 0) eta_qpts_event = rep_vector(0.0, qevent); + if (qlcens > 0) eta_qpts_lcens = rep_vector(0.0, qlcens); + if (qrcens > 0) eta_qpts_rcens = rep_vector(0.0, qrcens); + if (qicens > 0) eta_qpts_icenl = rep_vector(0.0, qicens); + if (qicens > 0) eta_qpts_icenu = rep_vector(0.0, qicens); + if (qdelay > 0) eta_qpts_delay = rep_vector(0.0, qdelay); } // add on time-varying part to linear predictor if (S > 0) { - eta += s_cpts * beta_tde; + if (Nevent > 0) eta_epts_event += s_epts_event * beta_tde; + if (qevent > 0) eta_qpts_event += s_qpts_event * beta_tde; + if (qlcens > 0) eta_qpts_lcens += s_qpts_lcens * beta_tde; + if (qrcens > 0) eta_qpts_rcens += s_qpts_rcens * beta_tde; + if (qicens > 0) eta_qpts_icenl += s_qpts_icenl * beta_tde; + if (qicens > 0) eta_qpts_icenu += s_qpts_icenu * beta_tde; + if (qdelay > 0) eta_qpts_delay += s_qpts_delay * beta_tde; } // add on intercept to linear predictor if (has_intercept == 1) { - eta += gamma[1]; + if (Nevent > 0) eta_epts_event += gamma[1]; + if (qevent > 0) eta_qpts_event += gamma[1]; + if (qlcens > 0) eta_qpts_lcens += gamma[1]; + if (qrcens > 0) eta_qpts_rcens += gamma[1]; + if (qicens > 0) eta_qpts_icenl += gamma[1]; + if (qicens > 0) eta_qpts_icenu += gamma[1]; + if (qdelay > 0) eta_qpts_delay += gamma[1]; } // aft models if (type == 7 || type == 8) { - vector[Nevent] eta_epts_event; - vector[qevent] eta_qpts_event; - vector[qlcens] eta_qpts_lcens; - vector[qrcens] eta_qpts_rcens; - vector[qicens] eta_qpts_icenl; - vector[qicens] eta_qpts_icenu; - vector[qdelay] eta_qpts_delay; - vector[Nevent] af_event; vector[Nevent] caf_event; @@ -835,42 +873,33 @@ model { vector[Nicens] caf_icenu; vector[Ndelay] caf_delay; - // split linear predictor based on event types - if (Nevent > 0) eta_epts_event = eta[idx_cpts[1,1]:idx_cpts[1,2]]; - if (qevent > 0) eta_qpts_event = eta[idx_cpts[2,1]:idx_cpts[2,2]]; - if (qlcens > 0) eta_qpts_lcens = eta[idx_cpts[3,1]:idx_cpts[3,2]]; - if (qrcens > 0) eta_qpts_rcens = eta[idx_cpts[4,1]:idx_cpts[4,2]]; - if (qicens > 0) eta_qpts_icenl = eta[idx_cpts[5,1]:idx_cpts[5,2]]; - if (qicens > 0) eta_qpts_icenu = eta[idx_cpts[6,1]:idx_cpts[6,2]]; - if (qdelay > 0) eta_qpts_delay = eta[idx_cpts[7,1]:idx_cpts[7,2]]; - // acceleration factor at event time if (Nevent > 0) af_event = exp(-eta_epts_event); // evaluate cumulative acceleration factors - if (qevent > 0) caf_event = quadrature_aft(qwts_event, eta_qpts_event, qnodes, Nevent); - if (qlcens > 0) caf_lcens = quadrature_aft(qwts_lcens, eta_qpts_lcens, qnodes, Nlcens); - if (qrcens > 0) caf_rcens = quadrature_aft(qwts_rcens, eta_qpts_rcens, qnodes, Nrcens); - if (qicens > 0) caf_icenl = quadrature_aft(qwts_icenl, eta_qpts_icenl, qnodes, Nicens); - if (qicens > 0) caf_icenu = quadrature_aft(qwts_icenu, eta_qpts_icenu, qnodes, Nicens); - if (qdelay > 0) caf_delay = quadrature_aft(qwts_delay, eta_qpts_delay, qnodes, Ndelay); + if (Nevent > 0) caf_event = quadrature_aft(qwts_event, eta_qpts_event, qnodes, Nevent); + if (Nlcens > 0) caf_lcens = quadrature_aft(qwts_lcens, eta_qpts_lcens, qnodes, Nlcens); + if (Nrcens > 0) caf_rcens = quadrature_aft(qwts_rcens, eta_qpts_rcens, qnodes, Nrcens); + if (Nicens > 0) caf_icenl = quadrature_aft(qwts_icenl, eta_qpts_icenl, qnodes, Nicens); + if (Nicens > 0) caf_icenu = quadrature_aft(qwts_icenu, eta_qpts_icenu, qnodes, Nicens); + if (Ndelay > 0) caf_delay = quadrature_aft(qwts_delay, eta_qpts_delay, qnodes, Ndelay); // increment target with log-lik contributions if (type == 7) { // exponential AFT model - if (nevent > 0) target += exponentialAFT_log_haz (af_event); - if (nevent > 0) target += exponentialAFT_log_surv(caf_event); - if (nlcens > 0) target += exponentialAFT_log_cdf (caf_lcens); - if (nrcens > 0) target += exponentialAFT_log_surv(caf_rcens); - if (nicens > 0) target += exponentialAFT_log_cdf2(caf_icenl, caf_icenu); - if (ndelay > 0) target += -exponentialAFT_log_surv(caf_delay); + if (Nevent > 0) target += exponentialAFT_log_haz (af_event); + if (Nevent > 0) target += exponentialAFT_log_surv(caf_event); + if (Nlcens > 0) target += exponentialAFT_log_cdf (caf_lcens); + if (Nrcens > 0) target += exponentialAFT_log_surv(caf_rcens); + if (Nicens > 0) target += exponentialAFT_log_cdf2(caf_icenl, caf_icenu); + if (Ndelay > 0) target += -exponentialAFT_log_surv(caf_delay); } else if (type == 8) { // weibull AFT model real shape = coefs[1]; - if (nevent > 0) target += weibullAFT_log_haz (af_event, caf_event, shape); - if (nevent > 0) target += weibullAFT_log_surv(caf_event, shape); - if (nlcens > 0) target += weibullAFT_log_cdf (caf_lcens, shape); - if (nrcens > 0) target += weibullAFT_log_surv(caf_rcens, shape); - if (nicens > 0) target += weibullAFT_log_cdf2(caf_icenl, caf_icenu, shape); - if (ndelay > 0) target += -weibullAFT_log_surv(caf_delay, shape); + if (Nevent > 0) target += weibullAFT_log_haz (af_event, caf_event, shape); + if (Nevent > 0) target += weibullAFT_log_surv(caf_event, shape); + if (Nlcens > 0) target += weibullAFT_log_cdf (caf_lcens, shape); + if (Nrcens > 0) target += weibullAFT_log_surv(caf_rcens, shape); + if (Nicens > 0) target += weibullAFT_log_cdf2(caf_icenl, caf_icenu, shape); + if (Ndelay > 0) target += -weibullAFT_log_surv(caf_delay, shape); } } @@ -878,8 +907,6 @@ model { // hazard models else { - vector[len_cpts] lhaz; // log hazard at event and quadrature times - vector[Nevent] lhaz_epts_event; vector[qevent] lhaz_qpts_event; vector[qlcens] lhaz_qpts_lcens; @@ -890,51 +917,63 @@ model { // evaluate log hazard if (type == 5) { // exponential model - lhaz = exponential_log_haz(eta); - } - else if (type == 7) { // exponential AFT model - lhaz = exponentialAFT_log_haz(eta); + if (Nevent > 0) lhaz_epts_event = exponential_log_haz(eta_epts_event); + if (qevent > 0) lhaz_qpts_event = exponential_log_haz(eta_qpts_event); + if (qlcens > 0) lhaz_qpts_lcens = exponential_log_haz(eta_qpts_lcens); + if (qrcens > 0) lhaz_qpts_rcens = exponential_log_haz(eta_qpts_rcens); + if (qicens > 0) lhaz_qpts_icenl = exponential_log_haz(eta_qpts_icenl); + if (qicens > 0) lhaz_qpts_icenu = exponential_log_haz(eta_qpts_icenu); + if (qdelay > 0) lhaz_qpts_delay = exponential_log_haz(eta_qpts_delay); } else if (type == 1) { // weibull model real shape = coefs[1]; - lhaz = weibull_log_haz(eta, cpts, shape); - } - else if (type == 8) { // weibull AFT model - real shape = coefs[1]; - lhaz = weibullAFT_log_haz(eta, cpts, shape); + if (Nevent > 0) lhaz_epts_event = weibull_log_haz(eta_epts_event, t_event, shape); + if (qevent > 0) lhaz_qpts_event = weibull_log_haz(eta_qpts_event, qpts_event, shape); + if (qlcens > 0) lhaz_qpts_lcens = weibull_log_haz(eta_qpts_lcens, qpts_lcens, shape); + if (qrcens > 0) lhaz_qpts_rcens = weibull_log_haz(eta_qpts_rcens, qpts_rcens, shape); + if (qicens > 0) lhaz_qpts_icenl = weibull_log_haz(eta_qpts_icenl, qpts_icenl, shape); + if (qicens > 0) lhaz_qpts_icenu = weibull_log_haz(eta_qpts_icenu, qpts_icenu, shape); + if (qdelay > 0) lhaz_qpts_delay = weibull_log_haz(eta_qpts_delay, qpts_delay, shape); } else if (type == 6) { // gompertz model real scale = coefs[1]; - lhaz = gompertz_log_haz(eta, cpts, scale); + if (Nevent > 0) lhaz_epts_event = gompertz_log_haz(eta_epts_event, t_event, scale); + if (qevent > 0) lhaz_qpts_event = gompertz_log_haz(eta_qpts_event, qpts_event, scale); + if (qlcens > 0) lhaz_qpts_lcens = gompertz_log_haz(eta_qpts_lcens, qpts_lcens, scale); + if (qrcens > 0) lhaz_qpts_rcens = gompertz_log_haz(eta_qpts_rcens, qpts_rcens, scale); + if (qicens > 0) lhaz_qpts_icenl = gompertz_log_haz(eta_qpts_icenl, qpts_icenl, scale); + if (qicens > 0) lhaz_qpts_icenu = gompertz_log_haz(eta_qpts_icenu, qpts_icenu, scale); + if (qdelay > 0) lhaz_qpts_delay = gompertz_log_haz(eta_qpts_delay, qpts_delay, scale); } else if (type == 4) { // M-splines, on haz scale - lhaz = mspline_log_haz(eta, basis_cpts, coefs); + if (Nevent > 0) lhaz_epts_event = mspline_log_haz(eta_epts_event, basis_epts_event, coefs); + if (qevent > 0) lhaz_qpts_event = mspline_log_haz(eta_qpts_event, basis_qpts_event, coefs); + if (qlcens > 0) lhaz_qpts_lcens = mspline_log_haz(eta_qpts_lcens, basis_qpts_lcens, coefs); + if (qrcens > 0) lhaz_qpts_rcens = mspline_log_haz(eta_qpts_rcens, basis_qpts_rcens, coefs); + if (qicens > 0) lhaz_qpts_icenl = mspline_log_haz(eta_qpts_icenl, basis_qpts_icenl, coefs); + if (qicens > 0) lhaz_qpts_icenu = mspline_log_haz(eta_qpts_icenu, basis_qpts_icenu, coefs); + if (qdelay > 0) lhaz_qpts_delay = mspline_log_haz(eta_qpts_delay, basis_qpts_delay, coefs); } else if (type == 2) { // B-splines, on log haz scale - lhaz = bspline_log_haz(eta, basis_cpts, coefs); + if (Nevent > 0) lhaz_epts_event = bspline_log_haz(eta_epts_event, basis_epts_event, coefs); + if (qevent > 0) lhaz_qpts_event = bspline_log_haz(eta_qpts_event, basis_qpts_event, coefs); + if (qlcens > 0) lhaz_qpts_lcens = bspline_log_haz(eta_qpts_lcens, basis_qpts_lcens, coefs); + if (qrcens > 0) lhaz_qpts_rcens = bspline_log_haz(eta_qpts_rcens, basis_qpts_rcens, coefs); + if (qicens > 0) lhaz_qpts_icenl = bspline_log_haz(eta_qpts_icenl, basis_qpts_icenl, coefs); + if (qicens > 0) lhaz_qpts_icenu = bspline_log_haz(eta_qpts_icenu, basis_qpts_icenu, coefs); + if (qdelay > 0) lhaz_qpts_delay = bspline_log_haz(eta_qpts_delay, basis_qpts_delay, coefs); } else { reject("Bug found: invalid baseline hazard (with quadrature)."); } - // split log hazard vector based on event types - if (Nevent > 0) lhaz_epts_event = lhaz[idx_cpts[1,1]:idx_cpts[1,2]]; - if (qevent > 0) lhaz_qpts_event = lhaz[idx_cpts[2,1]:idx_cpts[2,2]]; - if (qlcens > 0) lhaz_qpts_lcens = lhaz[idx_cpts[3,1]:idx_cpts[3,2]]; - if (qrcens > 0) lhaz_qpts_rcens = lhaz[idx_cpts[4,1]:idx_cpts[4,2]]; - if (qicens > 0) lhaz_qpts_icenl = lhaz[idx_cpts[5,1]:idx_cpts[5,2]]; - if (qicens > 0) lhaz_qpts_icenu = lhaz[idx_cpts[6,1]:idx_cpts[6,2]]; - if (qdelay > 0) lhaz_qpts_delay = lhaz[idx_cpts[7,1]:idx_cpts[7,2]]; - // increment target with log-lik contributions for event submodel if (Nevent > 0) target += lhaz_epts_event; if (qevent > 0) target += quadrature_log_surv(qwts_event, lhaz_qpts_event); - if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, - qnodes, Nlcens); + if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, qnodes, Nlcens); if (qrcens > 0) target += quadrature_log_surv(qwts_rcens, lhaz_qpts_rcens); if (qicens > 0) target += quadrature_log_cdf2(qwts_icenl, lhaz_qpts_icenl, - qwts_icenu, lhaz_qpts_icenu, - qnodes, Nicens); + qwts_icenu, lhaz_qpts_icenu, qnodes, Nicens); if (qdelay > 0) target += -quadrature_log_surv(qwts_delay, lhaz_qpts_delay); } From 44699cf3dc207e5e76159ddd7177a8ff453e412c Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 4 Dec 2018 15:05:40 +1100 Subject: [PATCH 103/225] stan_surv: remove remaining cpts code --- R/stan_surv.R | 319 ++++++++++++++++++++++++++------------- src/stan_files/surv.stan | 13 +- 2 files changed, 224 insertions(+), 108 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 932133dd6..b0e4c6d4e 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -410,7 +410,7 @@ stan_surv <- function(formula, algorithm <- match.arg(algorithm) formula <- parse_formula(formula, data) - data <- make_model_data(formula$tf_form, data) # row subsetting etc. + data <- make_model_data(formula$allvars_form, data) # row subsetting etc. #---------------- # Construct data @@ -495,19 +495,20 @@ stan_surv <- function(formula, if (has_quadrature) { # model uses quadrature - # standardised weights and nodes for quadrature + # standardised nodes and weights for quadrature qq <- get_quadpoints(nodes = qnodes) qp <- qq$points qw <- qq$weights - # quadrature points & weights, evaluated for each row of data + # quadrature points, evaluated for each row of data qpts_event <- uapply(qp, unstandardise_qpts, 0, t_event) qpts_lcens <- uapply(qp, unstandardise_qpts, 0, t_lcens) qpts_rcens <- uapply(qp, unstandardise_qpts, 0, t_rcens) qpts_icenl <- uapply(qp, unstandardise_qpts, 0, t_icenl) qpts_icenu <- uapply(qp, unstandardise_qpts, 0, t_icenu) qpts_delay <- uapply(qp, unstandardise_qpts, 0, t_delay) - + + # quadrature weights, evaluated for each row of data qwts_event <- uapply(qw, unstandardise_qwts, 0, t_event) qwts_lcens <- uapply(qw, unstandardise_qwts, 0, t_lcens) qwts_rcens <- uapply(qw, unstandardise_qwts, 0, t_rcens) @@ -515,18 +516,6 @@ stan_surv <- function(formula, qwts_icenu <- uapply(qw, unstandardise_qwts, 0, t_icenu) qwts_delay <- uapply(qw, unstandardise_qwts, 0, t_delay) - # times at events and all quadrature points - cpts_list <- list(t_event, - qpts_event, - qpts_lcens, - qpts_rcens, - qpts_icenl, - qpts_icenu, - qpts_delay) - idx_cpts <- get_idx_array(sapply(cpts_list, length)) - cpts <- unlist(cpts_list) # as vector for stan - len_cpts <- length(cpts) - # number of quadrature points qevent <- length(qwts_event) qlcens <- length(qwts_lcens) @@ -536,78 +525,143 @@ stan_surv <- function(formula, } else { - cpts <- rep(0,0) - len_cpts <- 0L - idx_cpts <- matrix(0,7,2) - if (!qnodes == 15) # warn user if qnodes is not equal to the default warning2("There is no quadrature required so 'qnodes' is being ignored.") + } #----- basis terms for baseline hazard - if (has_quadrature) { - - basis_cpts <- make_basis(cpts, basehaz) - - } else { + if (!has_quadrature) { basis_event <- make_basis(t_event, basehaz) - ibasis_event <- make_basis(t_event, basehaz, integrate = TRUE) ibasis_lcens <- make_basis(t_lcens, basehaz, integrate = TRUE) ibasis_rcens <- make_basis(t_rcens, basehaz, integrate = TRUE) ibasis_icenl <- make_basis(t_icenl, basehaz, integrate = TRUE) ibasis_icenu <- make_basis(t_icenu, basehaz, integrate = TRUE) ibasis_delay <- make_basis(t_delay, basehaz, integrate = TRUE) + + } else { + + basis_epts_event <- make_basis(t_event, basehaz) + basis_qpts_event <- make_basis(qpts_event, basehaz) + basis_qpts_lcens <- make_basis(qpts_lcens, basehaz) + basis_qpts_rcens <- make_basis(qpts_rcens, basehaz) + basis_qpts_icenl <- make_basis(qpts_icenl, basehaz) + basis_qpts_icenu <- make_basis(qpts_icenu, basehaz) + basis_qpts_delay <- make_basis(qpts_delay, basehaz) + + } + + #----- model frames for generating predictor matrices + if (!has_quadrature) { + + # model frames without quadrature + mf_event <- keep_rows(mf, status == 1) + mf_lcens <- keep_rows(mf, status == 2) + mf_rcens <- keep_rows(mf, status == 0) + mf_icens <- keep_rows(mf, status == 3) + mf_delay <- keep_rows(mf, delayed) + + } else { + + # model frames with quadrature + mf_epts_event <- keep_rows(mf, status == 1) + mf_qpts_event <- rep_rows(keep_rows(mf, status == 1), times = qnodes) + mf_qpts_lcens <- rep_rows(keep_rows(mf, status == 2), times = qnodes) + mf_qpts_rcens <- rep_rows(keep_rows(mf, status == 0), times = qnodes) + mf_qpts_icenl <- rep_rows(keep_rows(mf, status == 3), times = qnodes) + mf_qpts_icenu <- rep_rows(keep_rows(mf, status == 3), times = qnodes) + mf_qpts_delay <- rep_rows(keep_rows(mf, delayed), times = qnodes) + } + + if (has_tde) { + + bsf <- formula$bs_form + + # generate a model frame with time transformations for tde effects + tms_epts_event <- model.frame(bsf, data.frame(times__ = t_event)) + tms_qpts_event <- model.frame(bsf, data.frame(times__ = qpts_event)) + tms_qpts_lcens <- model.frame(bsf, data.frame(times__ = qpts_lcens)) + tms_qpts_rcens <- model.frame(bsf, data.frame(times__ = qpts_rcens)) + tms_qpts_icenl <- model.frame(bsf, data.frame(times__ = qpts_icenl)) + tms_qpts_icenu <- model.frame(bsf, data.frame(times__ = qpts_icenu)) + tms_qpts_delay <- model.frame(bsf, data.frame(times__ = qpts_delay)) + + # NB the method for adding columns here avoids dropping terms attribute + mf_epts_event[, colnames(tms_epts_event)] <- tms_epts_event + mf_qpts_event[, colnames(tms_qpts_event)] <- tms_qpts_event + mf_qpts_lcens[, colnames(tms_qpts_lcens)] <- tms_qpts_lcens + mf_qpts_rcens[, colnames(tms_qpts_rcens)] <- tms_qpts_rcens + mf_qpts_icenl[, colnames(tms_qpts_icenl)] <- tms_qpts_icenl + mf_qpts_icenu[, colnames(tms_qpts_icenu)] <- tms_qpts_icenu + mf_qpts_delay[, colnames(tms_qpts_delay)] <- tms_qpts_delay + + } + + #----- time-fixed predictor matrices + + tf <- formula$tf_form + + if (!has_quadrature) { + + x_event <- make_x(tf, mf_event, xlevs = xlevs)$x + x_lcens <- make_x(tf, mf_lcens, xlevs = xlevs)$x + x_rcens <- make_x(tf, mf_rcens, xlevs = xlevs)$x + x_icens <- make_x(tf, mf_icens, xlevs = xlevs)$x + x_delay <- make_x(tf, mf_delay, xlevs = xlevs)$x + + K <- ncol(x_events) + + } else { + + x_epts_event <- make_x(tf, mf_epts_event, xlevs = xlevs)$x + x_qpts_event <- make_x(tf, mf_qpts_event, xlevs = xlevs)$x + x_qpts_lcens <- make_x(tf, mf_qpts_lcens, xlevs = xlevs)$x + x_qpts_rcens <- make_x(tf, mf_qpts_rcens, xlevs = xlevs)$x + x_qpts_icenl <- make_x(tf, mf_qpts_icenl, xlevs = xlevs)$x + x_qpts_icenu <- make_x(tf, mf_qpts_icenu, xlevs = xlevs)$x + x_qpts_delay <- make_x(tf, mf_qpts_delay, xlevs = xlevs)$x + + K <- ncol(x_epts_event) - #----- predictor matrices - - # time-fixed predictor matrix - x <- make_x(formula$tf_form, mf)$x - x_event <- keep_rows(x, status == 1) - x_lcens <- keep_rows(x, status == 2) - x_rcens <- keep_rows(x, status == 0) - x_icens <- keep_rows(x, status == 3) - x_delay <- keep_rows(x, delayed) - K <- ncol(x) - if (has_quadrature) { - x_cpts <- rbind(x_event, - rep_rows(x_event, times = qnodes), - rep_rows(x_lcens, times = qnodes), - rep_rows(x_rcens, times = qnodes), - rep_rows(x_icens, times = qnodes), - rep_rows(x_icens, times = qnodes), - rep_rows(x_delay, times = qnodes)) } - # time-varying predictor matrix - if (has_tde) { - tdfm <- formula$td_form - xlevs <- .getXlevels(mt, mf) - data_event <- keep_rows(data, status == 1) - data_lcens <- keep_rows(data, status == 2) - data_rcens <- keep_rows(data, status == 0) - data_icens <- keep_rows(data, status == 3) - data_delay <- keep_rows(data, delayed) - data_cpts <- rbind(data_event, - rep_rows(data_event, times = qnodes), - rep_rows(data_lcens, times = qnodes), - rep_rows(data_rcens, times = qnodes), - rep_rows(data_icens, times = qnodes), - rep_rows(data_icens, times = qnodes), - rep_rows(data_delay, times = qnodes)) - s_cpts <- make_s(tdfm, data_cpts, times = cpts, xlevs = xlevs) - smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") + #----- time-varying predictor matrices + + td <- formula$td_form + + if (has_tde) { + + s_epts_event <- make_x(td, mf_epts_event, xlevs = xlevs)$x + s_qpts_event <- make_x(td, mf_qpts_event, xlevs = xlevs)$x + s_qpts_lcens <- make_x(td, mf_qpts_lcens, xlevs = xlevs)$x + s_qpts_rcens <- make_x(td, mf_qpts_rcens, xlevs = xlevs)$x + s_qpts_icenl <- make_x(td, mf_qpts_icenl, xlevs = xlevs)$x + s_qpts_icenu <- make_x(td, mf_qpts_icenu, xlevs = xlevs)$x + s_qpts_delay <- make_x(td, mf_qpts_delay, xlevs = xlevs)$x + + smooth_map <- get_smooth_name(s_epts_event, type = "smooth_map") smooth_idx <- get_idx_array(table(smooth_map)) - S <- ncol(s_cpts) # num. of tde spline coefficients - } else { # model does not have tde - s_cpts <- matrix(0,len_cpts,0) + S <- ncol(s_epts_event) # number of tde spline coefficients + + } else { + + s_epts_event <- matrix(0,length(t_event), 0) + s_qpts_event <- matrix(0,length(qpts_event),0) + s_qpts_lcens <- matrix(0,length(qpts_lcens),0) + s_qpts_rcens <- matrix(0,length(qpts_rcens),0) + s_qpts_icenl <- matrix(0,length(qpts_icenl),0) + s_qpts_icenu <- matrix(0,length(qpts_icenu),0) + s_qpts_delay <- matrix(0,length(qpts_delay),0) + smooth_idx <- matrix(0,0,2) smooth_map <- integer(0) S <- 0L + } #----- stan data @@ -619,9 +673,6 @@ stan_surv <- function(formula, has_quadrature, smooth_map, smooth_idx, - cpts, - len_cpts, - idx_cpts, type = basehaz$type, nevent = if (has_quadrature) 0L else nevent, @@ -650,24 +701,45 @@ stan_surv <- function(formula, ibasis_icenl = if (has_quadrature) matrix(0,0,nvars) else ibasis_icenl, ibasis_icenu = if (has_quadrature) matrix(0,0,nvars) else ibasis_icenu, ibasis_delay = if (has_quadrature) matrix(0,0,nvars) else ibasis_delay, - + qnodes = if (!has_quadrature) 0L else qnodes, Nevent = if (!has_quadrature) 0L else nevent, Nlcens = if (!has_quadrature) 0L else nlcens, Nrcens = if (!has_quadrature) 0L else nrcens, Nicens = if (!has_quadrature) 0L else nicens, - Ndelay = if (!has_quadrature) 0L else ndelay, + Ndelay = if (!has_quadrature) 0L else ndelay, + qevent = if (!has_quadrature) 0L else qevent, qlcens = if (!has_quadrature) 0L else qlcens, qrcens = if (!has_quadrature) 0L else qrcens, qicens = if (!has_quadrature) 0L else qicens, qdelay = if (!has_quadrature) 0L else qdelay, - x_cpts = if (!has_quadrature) matrix(0,0,K) else x_cpts, - s_cpts = if (!has_quadrature) matrix(0,0,S) else s_cpts, - basis_cpts = if (!has_quadrature) matrix(0,0,nvars) else basis_cpts, + x_epts_event = if (!has_quadrature) matrix(0,0,K) else x_epts_event, + x_qpts_event = if (!has_quadrature) matrix(0,0,K) else x_qpts_event, + x_qpts_lcens = if (!has_quadrature) matrix(0,0,K) else x_qpts_lcens, + x_qpts_rcens = if (!has_quadrature) matrix(0,0,K) else x_qpts_rcens, + x_qpts_icenl = if (!has_quadrature) matrix(0,0,K) else x_qpts_icenl, + x_qpts_icenu = if (!has_quadrature) matrix(0,0,K) else x_qpts_icenu, + x_qpts_delay = if (!has_quadrature) matrix(0,0,K) else x_qpts_delay, + + s_epts_event = if (!has_quadrature) matrix(0,0,S) else s_epts_event, + s_qpts_event = if (!has_quadrature) matrix(0,0,S) else s_qpts_event, + s_qpts_lcens = if (!has_quadrature) matrix(0,0,S) else s_qpts_lcens, + s_qpts_rcens = if (!has_quadrature) matrix(0,0,S) else s_qpts_rcens, + s_qpts_icenl = if (!has_quadrature) matrix(0,0,S) else s_qpts_icenl, + s_qpts_icenu = if (!has_quadrature) matrix(0,0,S) else s_qpts_icenu, + s_qpts_delay = if (!has_quadrature) matrix(0,0,S) else s_qpts_delay, + basis_epts_event = if (!has_quadrature) matrix(0,0,nvars) else basis_epts_event, + basis_qpts_event = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_event, + basis_qpts_lcens = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_lcens, + basis_qpts_rcens = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_rcens, + basis_qpts_icenl = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_icenl, + basis_qpts_icenu = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_icenu, + basis_qpts_delay = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_delay, + qwts_event = if (!has_quadrature) rep(0,0) else qwts_event, qwts_lcens = if (!has_quadrature) rep(0,0) else qwts_lcens, qwts_rcens = if (!has_quadrature) rep(0,0) else qwts_rcens, @@ -818,8 +890,8 @@ stan_surv <- function(formula, # define new parameter names nms_beta <- colnames(x) # may be NULL - nms_tde <- get_smooth_name(s_cpts, type = "smooth_coefs") # may be NULL - nms_smooth <- get_smooth_name(s_cpts, type = "smooth_sd") # may be NULL + nms_tde <- get_smooth_name(s_epts_event, type = "smooth_coefs") # may be NULL + nms_smooth <- get_smooth_name(s_epts_event, type = "smooth_sd") # may be NULL nms_int <- get_int_name_basehaz(basehaz) nms_aux <- get_aux_name_basehaz(basehaz) nms_all <- c(nms_int, @@ -842,7 +914,7 @@ stan_surv <- function(formula, terms = mt, xlevels = .getXlevels(mt, mf), x, - s_cpts = if (has_tde) s_cpts else NULL, + s_epts_event = if (has_tde) s_epts_event else NULL, t_beg, t_end, status, @@ -1165,13 +1237,21 @@ parse_formula <- function(formula, data) { formula <- validate_formula(formula, needs_response = TRUE) - lhs <- lhs(formula) # full LHS of formula - lhs_form <- reformulate_lhs(lhs) + lhs <- lhs(formula) # LHS as expression + lhs_form <- reformulate_lhs(lhs) # LHS as formula + + rhs <- rhs(formula) # RHS as expression + rhs_form <- reformulate_rhs(rhs) # RHS as formula - rhs <- rhs(formula) # RHS as expression - rhs_form <- reformulate_rhs(rhs) # RHS as formula - rhs_terms <- terms(rhs_form, specials = "tde") - rhs_vars <- rownames(attr(rhs_terms, "factors")) + fe_form <- lme4::nobars(rhs_form) + fe_terms <- terms(fe_form, specials = "tde") + fe_vars <- rownames(attr(fe_terms, "factors")) + + bars <- lme4::findbars(rhs_form) + re_parts <- lapply(bars, split_at_bars) + re_forms <- fetch(re_parts, "re_form") + if (length(bars) > 2L) + stop2("A maximum of 2 grouping factors are allowed.") allvars <- all.vars(formula) allvars_form <- reformulate(allvars) @@ -1206,34 +1286,36 @@ parse_formula <- function(formula, data) { max_t <- max(surv[, c("time1", "time2")]) } - sel <- attr(rhs_terms, "specials")$tde - + sel <- attr(fe_terms, "specials")$tde + if (!is.null(sel)) { # model has tde # replace 'tde(x, ...)' in formula with 'x' - tde_oldvars <- rhs_vars + tde_oldvars <- fe_vars tde_newvars <- sapply(tde_oldvars, function(oldvar) { - if (oldvar %in% rhs_vars[sel]) { + if (oldvar %in% fe_vars[sel]) { tde <- function(newvar, ...) { # define tde function locally safe_deparse(substitute(newvar)) } eval(parse(text = oldvar)) } else oldvar }, USE.NAMES = FALSE) - term_labels <- attr(rhs_terms, "term.labels") + tf_term_labels <- attr(fe_terms, "term.labels") + td_term_labels <- c() + k <- 0 # initialise td_term_labels indexing (for creating a new formula) for (i in sel) { - sel_terms <- which(attr(rhs_terms, "factors")[i, ] > 0) + sel_terms <- which(attr(fe_terms, "factors")[i, ] > 0) for (j in sel_terms) { - term_labels[j] <- gsub(tde_oldvars[i], - tde_newvars[i], - term_labels[j], - fixed = TRUE) + k <- k + 1 + tf_term_labels[j] <- td_term_labels[k] <- gsub(tde_oldvars[i], + tde_newvars[i], + tf_term_labels[j], + fixed = TRUE) } } - tf_form <- reformulate(term_labels, response = lhs) # extract 'tde(x, ...)' from formula and construct 'bs(times, ...)' - tde_terms <- lapply(rhs_vars[sel], function(x) { + tde_terms <- lapply(fe_vars[sel], function(x) { tde <- function(vn, ...) { # define tde function locally dots <- list(...) ok_args <- c("df") @@ -1252,32 +1334,56 @@ parse_formula <- function(formula, data) { sub("^list\\(", "bs\\(times__, ", safe_deparse(dots)) } tde_calls <- eval(parse(text = x)) - sel_terms <- which(attr(rhs_terms, "factors")[x, ] > 0) + sel_terms <- which(attr(fe_terms, "factors")[x, ] > 0) new_calls <- sapply(seq_along(sel_terms), function(j) { - paste0(term_labels[sel_terms[j]], ":", tde_calls) + paste0(tf_term_labels[sel_terms[j]], ":", tde_calls) }) nlist(tde_calls, new_calls) }) - td_basis <- fetch(tde_terms, "tde_calls") - new_calls <- fetch_(tde_terms, "new_calls") - td_form <- reformulate(new_calls, response = NULL, intercept = FALSE) + + # formula with all variables but no 'tde(x, ...)' wrappers + tf_form <- reformulate(tf_term_labels, response = lhs) + + # formula with only tde variables but no 'tde(x, ...)' wrappers + td_form <- reformulate(td_term_labels, response = lhs) + + # formula with 'bs(times__, ...)' terms based on 'tde(x, ...)' calls + tt_basis <- fetch(tde_terms, "tde_calls") + bs_form <- reformulate(unique(unlist(tt_basis)), + response = NULL, + intercept = FALSE) + # formula with 'x:bs(times__, ...)' terms based on 'tde(x, ...)' calls + tt_calls <- fetch_(tde_terms, "new_calls") + tt_form <- reformulate(tt_calls, + response = NULL, + intercept = FALSE) + } else { # model doesn't have tde - tf_form <- formula + + tf_form <- fe_form td_form <- NULL - td_basis <- NULL + bs_form <- NULL + tt_form <- NULL + tt_basis <- NULL + tt_calls <- NULL + } nlist(formula, lhs, - rhs, lhs_form, + rhs, rhs_form, tf_form, td_form, - td_basis, - fe_form = rhs_form, # no re terms accommodated yet - re_form = NULL, # no re terms accommodated yet + bs_form, + tt_form, + tt_basis, + tt_calls, + fe_form, + re_forms, + re_parts, allvars, allvars_form, tvar_beg, @@ -1286,6 +1392,7 @@ parse_formula <- function(formula, data) { surv_type = attr(surv, "type")) } + # Check formula object # # @param formula The user input to the formula argument. @@ -1453,7 +1560,7 @@ make_model_data <- function(formula, data) { make_model_frame <- function(formula, data, check_constant = TRUE) { # construct terms object from formula - Terms <- terms(formula) + Terms <- terms(lme4::subbars(formula)) # construct model frame mf <- model.frame(Terms, data) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index a54e61d2b..4cac6d49e 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -489,6 +489,15 @@ data { vector[nicens] t_icenu; // time of upper limit for interval censoring vector[ndelay] t_delay; // time of entry for delayed entry + vector[Nevent] epts_event; // time of events + vector[qevent] qpts_event; // qpts for time of events + vector[qlcens] qpts_lcens; // qpts for time of left censoring + vector[qrcens] qpts_rcens; // qpts for time of right censoring + vector[qicens] qpts_icenl; // qpts for time of lower limit for interval censoring + vector[qicens] qpts_icenu; // qpts for time of upper limit for interval censoring + vector[qdelay] qpts_delay; // qpts for time of entry for delayed entry + + // predictor matrices (time-fixed), without quadrature matrix[nevent,K] x_event; // for rows with events matrix[nlcens,K] x_lcens; // for rows with left censoring @@ -927,7 +936,7 @@ model { } else if (type == 1) { // weibull model real shape = coefs[1]; - if (Nevent > 0) lhaz_epts_event = weibull_log_haz(eta_epts_event, t_event, shape); + if (Nevent > 0) lhaz_epts_event = weibull_log_haz(eta_epts_event, epts_event, shape); if (qevent > 0) lhaz_qpts_event = weibull_log_haz(eta_qpts_event, qpts_event, shape); if (qlcens > 0) lhaz_qpts_lcens = weibull_log_haz(eta_qpts_lcens, qpts_lcens, shape); if (qrcens > 0) lhaz_qpts_rcens = weibull_log_haz(eta_qpts_rcens, qpts_rcens, shape); @@ -937,7 +946,7 @@ model { } else if (type == 6) { // gompertz model real scale = coefs[1]; - if (Nevent > 0) lhaz_epts_event = gompertz_log_haz(eta_epts_event, t_event, scale); + if (Nevent > 0) lhaz_epts_event = gompertz_log_haz(eta_epts_event, epts_event, scale); if (qevent > 0) lhaz_qpts_event = gompertz_log_haz(eta_qpts_event, qpts_event, scale); if (qlcens > 0) lhaz_qpts_lcens = gompertz_log_haz(eta_qpts_lcens, qpts_lcens, scale); if (qrcens > 0) lhaz_qpts_rcens = gompertz_log_haz(eta_qpts_rcens, qpts_rcens, scale); From c6d60919097ecf1dc1fadb665db33405e417c5b3 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 5 Dec 2018 15:01:04 +1100 Subject: [PATCH 104/225] surv.stan: fix small typo --- src/stan_files/surv.stan | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 4cac6d49e..7ecaa45e4 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -821,7 +821,7 @@ model { else { vector[Nevent] eta_epts_event; // for event times - vector[qlcens] eta_qpts_event; // for qpts for event time + vector[qevent] eta_qpts_event; // for qpts for event time vector[qlcens] eta_qpts_lcens; // for qpts for left censoring time vector[qrcens] eta_qpts_rcens; // for qpts for right censoring time vector[qicens] eta_qpts_icenl; // for qpts for lower limit of icens time From fb02cd4dc434c2d2df0eeff5c0d9cfcec358b402 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Dec 2018 11:23:27 +1100 Subject: [PATCH 105/225] stan_surv.R: tidy up use of cpts --- R/stan_surv.R | 220 +++++++++++++++++++++++++++++--------------------- 1 file changed, 128 insertions(+), 92 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index b0e4c6d4e..0211dd707 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -516,6 +516,17 @@ stan_surv <- function(formula, qwts_icenu <- uapply(qw, unstandardise_qwts, 0, t_icenu) qwts_delay <- uapply(qw, unstandardise_qwts, 0, t_delay) + # times at events and all quadrature points + cpts_list <- list(t_event, + qpts_event, + qpts_lcens, + qpts_rcens, + qpts_icenl, + qpts_icenu, + qpts_delay) + idx_cpts <- get_idx_array(sapply(cpts_list, length)) + cpts <- unlist(cpts_list) # as vector + # number of quadrature points qevent <- length(qwts_event) qlcens <- length(qwts_lcens) @@ -525,6 +536,24 @@ stan_surv <- function(formula, } else { + # times at all different event types + cpts_list <- list(t_event, + t_lcens, + t_rcens, + t_icenl, + t_icenu, + t_delay) + idx_cpts <- get_idx_array(sapply(cpts_list, length)) + cpts <- unlist(cpts_list) # as vector + + # dud entries for stan + qpts_event <- rep(0,0) + qpts_lcens <- rep(0,0) + qpts_rcens <- rep(0,0) + qpts_icenl <- rep(0,0) + qpts_icenu <- rep(0,0) + qpts_delay <- rep(0,0) + if (!qnodes == 15) # warn user if qnodes is not equal to the default warning2("There is no quadrature required so 'qnodes' is being ignored.") @@ -555,50 +584,46 @@ stan_surv <- function(formula, } #----- model frames for generating predictor matrices - + + mf_event <- keep_rows(mf, status == 1) + mf_lcens <- keep_rows(mf, status == 2) + mf_rcens <- keep_rows(mf, status == 0) + mf_icens <- keep_rows(mf, status == 3) + mf_delay <- keep_rows(mf, delayed) + if (!has_quadrature) { - # model frames without quadrature - mf_event <- keep_rows(mf, status == 1) - mf_lcens <- keep_rows(mf, status == 2) - mf_rcens <- keep_rows(mf, status == 0) - mf_icens <- keep_rows(mf, status == 3) - mf_delay <- keep_rows(mf, delayed) + # combined model frame, without quadrature + mf_cpts <- rbind(mf_event, + mf_lcens, + mf_rcens, + mf_icens, + mf_icens, + mf_delay) } else { - # model frames with quadrature - mf_epts_event <- keep_rows(mf, status == 1) - mf_qpts_event <- rep_rows(keep_rows(mf, status == 1), times = qnodes) - mf_qpts_lcens <- rep_rows(keep_rows(mf, status == 2), times = qnodes) - mf_qpts_rcens <- rep_rows(keep_rows(mf, status == 0), times = qnodes) - mf_qpts_icenl <- rep_rows(keep_rows(mf, status == 3), times = qnodes) - mf_qpts_icenu <- rep_rows(keep_rows(mf, status == 3), times = qnodes) - mf_qpts_delay <- rep_rows(keep_rows(mf, delayed), times = qnodes) + # combined model frame, with quadrature + mf_cpts <- rbind(mf_event, + rep_rows(mf_event, times = qnodes), + rep_rows(mf_lcens, times = qnodes), + rep_rows(mf_rcens, times = qnodes), + rep_rows(mf_icens, times = qnodes), + rep_rows(mf_icens, times = qnodes), + rep_rows(mf_delay, times = qnodes)) } if (has_tde) { + # formula for generating spline basis for tde effects bsf <- formula$bs_form # generate a model frame with time transformations for tde effects - tms_epts_event <- model.frame(bsf, data.frame(times__ = t_event)) - tms_qpts_event <- model.frame(bsf, data.frame(times__ = qpts_event)) - tms_qpts_lcens <- model.frame(bsf, data.frame(times__ = qpts_lcens)) - tms_qpts_rcens <- model.frame(bsf, data.frame(times__ = qpts_rcens)) - tms_qpts_icenl <- model.frame(bsf, data.frame(times__ = qpts_icenl)) - tms_qpts_icenu <- model.frame(bsf, data.frame(times__ = qpts_icenu)) - tms_qpts_delay <- model.frame(bsf, data.frame(times__ = qpts_delay)) + mf_tde_times <- make_model_frame(bsf, data.frame(times__ = cpts))$mf - # NB the method for adding columns here avoids dropping terms attribute - mf_epts_event[, colnames(tms_epts_event)] <- tms_epts_event - mf_qpts_event[, colnames(tms_qpts_event)] <- tms_qpts_event - mf_qpts_lcens[, colnames(tms_qpts_lcens)] <- tms_qpts_lcens - mf_qpts_rcens[, colnames(tms_qpts_rcens)] <- tms_qpts_rcens - mf_qpts_icenl[, colnames(tms_qpts_icenl)] <- tms_qpts_icenl - mf_qpts_icenu[, colnames(tms_qpts_icenu)] <- tms_qpts_icenu - mf_qpts_delay[, colnames(tms_qpts_delay)] <- tms_qpts_delay + # NB next line avoids dropping terms attribute from 'mf_cpts' + mf_cpts[, colnames(mf_tde_times)] <- mf_tde_times } @@ -606,63 +631,63 @@ stan_surv <- function(formula, tf <- formula$tf_form - if (!has_quadrature) { - - x_event <- make_x(tf, mf_event, xlevs = xlevs)$x - x_lcens <- make_x(tf, mf_lcens, xlevs = xlevs)$x - x_rcens <- make_x(tf, mf_rcens, xlevs = xlevs)$x - x_icens <- make_x(tf, mf_icens, xlevs = xlevs)$x - x_delay <- make_x(tf, mf_delay, xlevs = xlevs)$x - - K <- ncol(x_events) - - } else { - - x_epts_event <- make_x(tf, mf_epts_event, xlevs = xlevs)$x - x_qpts_event <- make_x(tf, mf_qpts_event, xlevs = xlevs)$x - x_qpts_lcens <- make_x(tf, mf_qpts_lcens, xlevs = xlevs)$x - x_qpts_rcens <- make_x(tf, mf_qpts_rcens, xlevs = xlevs)$x - x_qpts_icenl <- make_x(tf, mf_qpts_icenl, xlevs = xlevs)$x - x_qpts_icenu <- make_x(tf, mf_qpts_icenu, xlevs = xlevs)$x - x_qpts_delay <- make_x(tf, mf_qpts_delay, xlevs = xlevs)$x - - K <- ncol(x_epts_event) - - } + x <- make_x(tf, mf, xlevs = xlevs)$x # only used for scaling priors + x_cpts <- make_x(tf, mf_cpts, xlevs = xlevs)$x + K <- ncol(x) #----- time-varying predictor matrices - td <- formula$td_form - if (has_tde) { - s_epts_event <- make_x(td, mf_epts_event, xlevs = xlevs)$x - s_qpts_event <- make_x(td, mf_qpts_event, xlevs = xlevs)$x - s_qpts_lcens <- make_x(td, mf_qpts_lcens, xlevs = xlevs)$x - s_qpts_rcens <- make_x(td, mf_qpts_rcens, xlevs = xlevs)$x - s_qpts_icenl <- make_x(td, mf_qpts_icenl, xlevs = xlevs)$x - s_qpts_icenu <- make_x(td, mf_qpts_icenu, xlevs = xlevs)$x - s_qpts_delay <- make_x(td, mf_qpts_delay, xlevs = xlevs)$x - - smooth_map <- get_smooth_name(s_epts_event, type = "smooth_map") + s_cpts <- make_x(formula$tt_form, mf_cpts, xlevs = xlevs)$x + smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") smooth_idx <- get_idx_array(table(smooth_map)) - S <- ncol(s_epts_event) # number of tde spline coefficients + S <- ncol(s_cpts) # number of tde spline coefficients } else { - s_epts_event <- matrix(0,length(t_event), 0) - s_qpts_event <- matrix(0,length(qpts_event),0) - s_qpts_lcens <- matrix(0,length(qpts_lcens),0) - s_qpts_rcens <- matrix(0,length(qpts_rcens),0) - s_qpts_icenl <- matrix(0,length(qpts_icenl),0) - s_qpts_icenu <- matrix(0,length(qpts_icenu),0) - s_qpts_delay <- matrix(0,length(qpts_delay),0) - + s_cpts <- matrix(0,length(cpts),0) smooth_idx <- matrix(0,0,2) smooth_map <- integer(0) - S <- 0L - + S <- 0L + } + + #----- unstack predictor matrices + + if (!has_quadrature) { + + # time-fixed predictor matrices, without quadrature + # NB skip index 5 on purpose, since time fixed predictor matrix is + # identical for lower and upper limits of interval censoring time + x_event <- x_cpts[idx_cpts[1,1]:idx_cpts[1,2], , drop = FALSE] + x_lcens <- x_cpts[idx_cpts[2,1]:idx_cpts[2,2], , drop = FALSE] + x_rcens <- x_cpts[idx_cpts[3,1]:idx_cpts[3,2], , drop = FALSE] + x_icens <- x_cpts[idx_cpts[4,1]:idx_cpts[4,2], , drop = FALSE] + x_delay <- x_cpts[idx_cpts[6,1]:idx_cpts[6,2], , drop = FALSE] + + } else { + + # time-fixed predictor matrices, with quadrature + # NB skip index 6 on purpose, since time fixed predictor matrix is + # identical for lower and upper limits of interval censoring time + x_epts_event <- x_cpts[idx_cpts[1,1]:idx_cpts[1,2], , drop = FALSE] + x_qpts_event <- x_cpts[idx_cpts[2,1]:idx_cpts[2,2], , drop = FALSE] + x_qpts_lcens <- x_cpts[idx_cpts[3,1]:idx_cpts[3,2], , drop = FALSE] + x_qpts_rcens <- x_cpts[idx_cpts[4,1]:idx_cpts[4,2], , drop = FALSE] + x_qpts_icens <- x_cpts[idx_cpts[5,1]:idx_cpts[5,2], , drop = FALSE] + x_qpts_delay <- x_cpts[idx_cpts[7,1]:idx_cpts[7,2], , drop = FALSE] + + # time-varying predictor matrices + s_epts_event <- s_cpts[idx_cpts[1,1]:idx_cpts[1,2], , drop = FALSE] + s_qpts_event <- s_cpts[idx_cpts[2,1]:idx_cpts[2,2], , drop = FALSE] + s_qpts_lcens <- s_cpts[idx_cpts[3,1]:idx_cpts[3,2], , drop = FALSE] + s_qpts_rcens <- s_cpts[idx_cpts[4,1]:idx_cpts[4,2], , drop = FALSE] + s_qpts_icenl <- s_cpts[idx_cpts[5,1]:idx_cpts[5,2], , drop = FALSE] + s_qpts_icenu <- s_cpts[idx_cpts[6,1]:idx_cpts[6,2], , drop = FALSE] + s_qpts_delay <- s_cpts[idx_cpts[7,1]:idx_cpts[7,2], , drop = FALSE] + + } #----- stan data @@ -715,13 +740,27 @@ stan_surv <- function(formula, qrcens = if (!has_quadrature) 0L else qrcens, qicens = if (!has_quadrature) 0L else qicens, qdelay = if (!has_quadrature) 0L else qdelay, - + + epts_event = if (!has_quadrature) rep(0,0) else t_event, + qpts_event = if (!has_quadrature) rep(0,0) else qpts_event, + qpts_lcens = if (!has_quadrature) rep(0,0) else qpts_lcens, + qpts_rcens = if (!has_quadrature) rep(0,0) else qpts_rcens, + qpts_icenl = if (!has_quadrature) rep(0,0) else qpts_icenl, + qpts_icenu = if (!has_quadrature) rep(0,0) else qpts_icenu, + qpts_delay = if (!has_quadrature) rep(0,0) else qpts_delay, + + qwts_event = if (!has_quadrature) rep(0,0) else qwts_event, + qwts_lcens = if (!has_quadrature) rep(0,0) else qwts_lcens, + qwts_rcens = if (!has_quadrature) rep(0,0) else qwts_rcens, + qwts_icenl = if (!has_quadrature) rep(0,0) else qwts_icenl, + qwts_icenu = if (!has_quadrature) rep(0,0) else qwts_icenu, + qwts_delay = if (!has_quadrature) rep(0,0) else qwts_delay, + x_epts_event = if (!has_quadrature) matrix(0,0,K) else x_epts_event, x_qpts_event = if (!has_quadrature) matrix(0,0,K) else x_qpts_event, x_qpts_lcens = if (!has_quadrature) matrix(0,0,K) else x_qpts_lcens, x_qpts_rcens = if (!has_quadrature) matrix(0,0,K) else x_qpts_rcens, - x_qpts_icenl = if (!has_quadrature) matrix(0,0,K) else x_qpts_icenl, - x_qpts_icenu = if (!has_quadrature) matrix(0,0,K) else x_qpts_icenu, + x_qpts_icens = if (!has_quadrature) matrix(0,0,K) else x_qpts_icens, x_qpts_delay = if (!has_quadrature) matrix(0,0,K) else x_qpts_delay, s_epts_event = if (!has_quadrature) matrix(0,0,S) else s_epts_event, @@ -738,14 +777,7 @@ stan_surv <- function(formula, basis_qpts_rcens = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_rcens, basis_qpts_icenl = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_icenl, basis_qpts_icenu = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_icenu, - basis_qpts_delay = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_delay, - - qwts_event = if (!has_quadrature) rep(0,0) else qwts_event, - qwts_lcens = if (!has_quadrature) rep(0,0) else qwts_lcens, - qwts_rcens = if (!has_quadrature) rep(0,0) else qwts_rcens, - qwts_icenl = if (!has_quadrature) rep(0,0) else qwts_icenl, - qwts_icenu = if (!has_quadrature) rep(0,0) else qwts_icenu, - qwts_delay = if (!has_quadrature) rep(0,0) else qwts_delay + basis_qpts_delay = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_delay ) #----- priors and hyperparameters @@ -890,8 +922,8 @@ stan_surv <- function(formula, # define new parameter names nms_beta <- colnames(x) # may be NULL - nms_tde <- get_smooth_name(s_epts_event, type = "smooth_coefs") # may be NULL - nms_smooth <- get_smooth_name(s_epts_event, type = "smooth_sd") # may be NULL + nms_tde <- get_smooth_name(s_cpts, type = "smooth_coefs") # may be NULL + nms_smooth <- get_smooth_name(s_cpts, type = "smooth_sd") # may be NULL nms_int <- get_int_name_basehaz(basehaz) nms_aux <- get_aux_name_basehaz(basehaz) nms_all <- c(nms_int, @@ -914,7 +946,8 @@ stan_surv <- function(formula, terms = mt, xlevels = .getXlevels(mt, mf), x, - s_epts_event = if (has_tde) s_epts_event else NULL, + x_cpts = if (has_tde) x_cpts else NULL, + s_cpts = if (has_tde) s_cpts else NULL, t_beg, t_end, status, @@ -1243,7 +1276,7 @@ parse_formula <- function(formula, data) { rhs <- rhs(formula) # RHS as expression rhs_form <- reformulate_rhs(rhs) # RHS as formula - fe_form <- lme4::nobars(rhs_form) + fe_form <- lme4::nobars(rhs_form) fe_terms <- terms(fe_form, specials = "tde") fe_vars <- rownames(attr(fe_terms, "factors")) @@ -1255,6 +1288,8 @@ parse_formula <- function(formula, data) { allvars <- all.vars(formula) allvars_form <- reformulate(allvars) + + nobars_form <- lme4::nobars(formula) surv <- eval(lhs, envir = data) # Surv object surv <- validate_surv(surv) @@ -1361,7 +1396,7 @@ parse_formula <- function(formula, data) { } else { # model doesn't have tde - tf_form <- fe_form + tf_form <- formula td_form <- NULL bs_form <- NULL tt_form <- NULL @@ -1386,6 +1421,7 @@ parse_formula <- function(formula, data) { re_parts, allvars, allvars_form, + nobars_form, tvar_beg, tvar_end, dvar, @@ -1586,7 +1622,7 @@ make_model_frame <- function(formula, data, check_constant = TRUE) { # xbar: the column means of the model matrix. # N,K: number of rows (observations) and columns (predictors) in the # fixed effects model matrix -make_x <- function(formula, model_frame, xlevs = NULL, check_constant = TRUE) { +make_x <- function(formula, model_frame, xlevs = NULL, check_constant = FALSE) { # uncentred predictor matrix, without intercept x <- model.matrix(formula, model_frame, xlevs = xlevs) From 0b5d601235d2cd6f24c8253f2a2004d2a1e7cda4 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Dec 2018 11:24:17 +1100 Subject: [PATCH 106/225] plots for stan_surv: fix extraction of tde basis --- R/plots.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plots.R b/R/plots.R index 5db88ad26..a0a967c14 100644 --- a/R/plots.R +++ b/R/plots.R @@ -254,7 +254,7 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, betas <- cbind(betas_tf, betas_td) times__ <- times - basis <- eval(parse(text = x$formula$td_basis[sel1])) + basis <- eval(parse(text = x$formula$tt_basis[sel1])) basis <- add_intercept(basis) coef <- linear_predictor(betas, basis) From f096bc5f4ce51444ef0555dfa1abc5f4a66a5b2f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Dec 2018 12:18:05 +1100 Subject: [PATCH 107/225] Clean up some of stan_surv helper functions --- R/stan_surv.R | 255 +++++++------------------------------------------- 1 file changed, 32 insertions(+), 223 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 0211dd707..75256b893 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1461,11 +1461,10 @@ validate_surv <- function(x, ok_types = c("right", "counting", x } - # Extract LHS of a formula # -# @param x A formula object -# @param as_formula Logical. If TRUE then the result is reformulated. +# @param x A formula object. +# @return An expression. lhs <- function(x, as_formula = FALSE) { len <- length(x) if (len == 3L) { @@ -1478,8 +1477,8 @@ lhs <- function(x, as_formula = FALSE) { # Extract RHS of a formula # -# @param x A formula object -# @param as_formula Logical. If TRUE then the result is reformulated. +# @param x A formula object. +# @return An expression. rhs <- function(x, as_formula = FALSE) { len <- length(x) if (len == 3L) { @@ -1492,26 +1491,23 @@ rhs <- function(x, as_formula = FALSE) { # Reformulate as LHS of a formula # -# @param x A character string or expression object -# @param as_formula Logical. If TRUE then the result is reformulated. +# @param x A character string or expression. +# @return A formula. reformulate_lhs <- function(x) { - #x <- deparse(x, 500L) x <- formula(substitute(LHS ~ 1, list(LHS = x))) x } # Reformulate as RHS of a formula # -# @param x A formula object -# @param as_formula Logical. If TRUE then the result is reformulated. +# @param x A character string or expression. +# @return A formula. reformulate_rhs <- function(x) { - #x <- deparse(x, 500L) x <- formula(substitute(~ RHS, list(RHS = x))) x } - -# Return the response vector (time) for estimation +# Return the response vector (time) # # @param model_frame The model frame. # @param type The type of time variable to return: @@ -1559,7 +1555,6 @@ make_t <- function(model_frame, type = c("beg", "end", "gap", "upp")) { stop("Bug found: cannot handle specified 'type'.")) } - # Return the response vector (status indicator) # # @param model_frame The model frame. @@ -1582,7 +1577,9 @@ make_d <- function(model_frame) { # Return a data frame with NAs excluded # # @param formula The parsed model formula. -# @param data The user specified data frame. +# @param data The (user-specified) data frame. +# @return A data frame, with only complete cases for the variables that +# appear in the model formula. make_model_data <- function(formula, data) { mf <- model.frame(formula, data, na.action = na.pass) include <- apply(mf, 1L, function(row) !any(is.na(row))) @@ -1593,13 +1590,20 @@ make_model_data <- function(formula, data) { # # @param formula The parsed model formula. # @param data The model data frame. -make_model_frame <- function(formula, data, check_constant = TRUE) { +# @param xlev Passed to xlev argument of model.frame. +# @param check_constant If TRUE then an error is thrown is the returned +# model frame contains any constant variables. +# @return A list with the following elements: +# mf: the model frame based on the formula. +# mt: the model terms associated with the returned model frame. +make_model_frame <- function(formula, data, xlevs = NULL, + check_constant = FALSE) { # construct terms object from formula Terms <- terms(lme4::subbars(formula)) # construct model frame - mf <- model.frame(Terms, data) + mf <- model.frame(Terms, data, xlev = xlevs) # check no constant vars if (check_constant) @@ -1613,19 +1617,23 @@ make_model_frame <- function(formula, data, check_constant = TRUE) { nlist(mf, mt) } -# Return the fe predictor matrix for estimation +# Return the predictor matrix # # @param formula The parsed model formula. # @param model_frame The model frame. +# @param xlev Passed to xlev argument of model.frame. +# @param check_constant If TRUE then an error is thrown is the returned +# predictor matrix contains any constant columns. # @return A named list with the following elements: -# x: the fe model matrix, not centred and without intercept. +# x: the model matrix, not centred and without an intercept. # xbar: the column means of the model matrix. -# N,K: number of rows (observations) and columns (predictors) in the -# fixed effects model matrix -make_x <- function(formula, model_frame, xlevs = NULL, check_constant = FALSE) { - +# N: number of rows (observations) in the model matrix. +# K: number of cols (predictors) in the model matrix. +make_x <- function(formula, model_frame, xlevs = NULL, + check_constant = FALSE) { + # uncentred predictor matrix, without intercept - x <- model.matrix(formula, model_frame, xlevs = xlevs) + x <- model.matrix(formula, model_frame, xlev = xlevs) x <- drop_intercept(x) # column means of predictor matrix @@ -1640,202 +1648,3 @@ make_x <- function(formula, model_frame, xlevs = NULL, check_constant = FALSE) { nlist(x, xbar, N = NROW(x), K = NCOL(x)) } - -# Return a predictor for the tde spline terms -# -# @param formula The formula for the time-dependent effects part of the model. -# @param data A data frame. -# @param times The vector of times at which the predictor matrix should be -# evaluated. -# @param xlevs The factor levels to use for the predictor matrix. -# @return A matrix. -make_s <- function(formula, data, times, xlevs = NULL) { - - # add times (as a new variable) to the model data - if (!length(times) == nrow(data)) - stop("Bug found: 'times' is the incorrect length.") - data <- data.frame(data, times__ = times) - - # make model frame and predictor matrix - mf <- make_model_frame(formula, data, check_constant = FALSE)$mf - x <- make_x(formula, mf, xlevs = xlevs, check_constant = FALSE)$x - return(x) -} - -# Return the fe predictor matrix for prediction -# -# @param object A stansurv object. -# @param model_frame The model frame. -# @return A named list with the following elements: -# x: the fe model matrix, not centred and may have intercept depending on -# the requirement of the baseline hazard. -# N,K: number of rows (observations) and columns (predictors) in the -# fixed effects model matrix -make_pp_x <- function(object, model_frame) { - - # formula for fe predictor matrix - tt <- delete.response(terms(object)) - - # check data classes in the model frame match those used in model fitting - if (!is.null(cl <- attr(tt, "dataClasses"))) - .checkMFClasses(cl, model_frame) - - # uncentered predictor matrix - x <- model.matrix(tt, model_frame, contrasts.arg = object$contrasts) - - # drop intercept if baseline hazard doesn't require one - if (!has_intercept(object$basehaz)) - x <- drop_intercept(x) - - nlist(x, N = NROW(x), K = NCOL(x)) -} - -# apply b-spline time-dependent effect -apply_tde_fun <- function(model_terms, model_frame, times, bknots = NULL) { - - tde_stuff <- survival::untangle.specials(model_terms, "tde") - - if (!length(tde_stuff$terms)) - return(model_frame) # no time-dependent effects - - if (!nrow(model_frame)) - return(model_frame) # no rows in model frame (e.g. no delayed entry) - - vars <- attr(model_terms, 'variables') - pvars <- attr(model_terms, 'predvars') - - # loop over time-dependent terms in formula - K <- length(tde_stuff$terms) - for (i in 1:K) { - indx_i <- tde_stuff$terms[i] + 2 # index in call; +2 for 'list' & 'Surv()' - var_i <- vars [[indx_i]] # var in formula - pvar_i <- pvars[[indx_i]] # predvar in formula - var_i <- safe_deparse(var_i) # treat call as a string - pvar_i <- safe_deparse(pvar_i) # treat call as a string - # get the possible prefixes for the predvar (i.e. 'tde(x' or 'bs(x') - prefix <- "^bs\\([^,]+,[[:blank:]]*|^tde\\([^,]+,[[:blank:]]*" - # returns dots from 'tde(x, ...)' as a list - chck <- grepl(prefix, pvar_i) - if (chck) { - args_i <- eval_string(sub(prefix, "list\\(", pvar_i)) - } else { - args_i <- list() - } - # combine the dots with the times at which to evaluate the b-spline basis - args_i$intercept <- TRUE - if (!is.null(bknots)) - args_i$Boundary.knots <- bknots - args_i <- c(list(x = times), args_i) - # extract the variable from the model frame - oldx_i <- model_frame[[var_i]] - # apply interaction with the b-spline basis evaluated at specified times - newx_i <- oldx_i * do.call(splines::bs, args_i) - # substitute back into the model frame - model_frame[[var_i]] <- newx_i - } - - return(model_frame) -} - -update_tde_terms <- function(model_terms, model_frame) { - tde_terms <- survival::untangle.specials(model_terms, "tde")$terms - if (!length(tde_terms)) - return(model_frame) # no time-dependent effects - vars <- attr(model_terms, 'variables') - pvars <- attr(model_terms, 'predvars') - dclss <- attr(model_terms, "dataClasses") - K <- length(tde_terms) - for (i in 1:K) { - indx_i <- tde_terms[i] + 2 # index in call; +2 for 'list' & 'Surv()' - var_i <- vars [[indx_i]] # var in formula - pvar_i <- pvars[[indx_i]] # predvar in formula - var_i <- safe_deparse(var_i) # treat call as a string - pvar_i <- safe_deparse(pvar_i) # treat call as a string - oldx_i <- model_frame[[var_i]] # extract transformed variable from model frame - dummy <- as.call(list(as.name(class(oldx_i)[[1L]]), vars[[indx_i]][[2]])) - ptemp <- makepredictcall(oldx_i, dummy) # predvars call - pvars[[indx_i]] <- ptemp - dclss[[var_i]] <- class(oldx_i)[[1L]] - } - attr(model_terms, "predvars") <- pvars - #attr(model_terms, "dataClasses") <- dclss - return(model_terms) -} - - -#--------- not used; based on tt approach instead of tde approach - -# # Validate the user input to the 'tt' argument. This draws on the -# # code for the coxph modelling function in the survival package. -# # -# # Copyright (C) 2018 Sam Brilleman -# # Copyright (C) 2018 Terry Therneau, Thomas Lumley -# # -# # @param tt The user input to the 'tt' argument. -# # @param validate_length Integer specifying the required length of the -# # returned list. -# # @return A list of functions. -# validate_tt_fun <- function(tt, validate_length) { -# -# if (is.null(tt)) -# stop2("'tt' must be specified.") -# -# if (is.function(tt)) -# tt <- list(tt) # convert since function to a one element list -# -# if (!is.list(tt)) -# stop2("The 'tt' argument must contain a function or list of functions.") -# -# if (!all(sapply(tt, is.function))) -# stop2("The 'tt' argument must contain function or list of functions.") -# -# if (!length(tt) %in% c(1, validate_length)) -# stop2("The 'tt' argument contains a list of the incorrect length.") -# -# if (length(tt) == 1) -# tt <- rep(tt, validate_length) -# -# return(tt) -# } -# -# # apply time transform to the model frame; method based on survival package -# apply_tt_fun <- function(model_frame, tt_funs, tt_vars, tt_terms, times) { -# if (!length(tt_terms)) -# return(model_frame) -# -# for (i in 1:length(tt_terms)) { # loop over time transform terms -# -# # extract quantities used in time transform -# varnm_i <- tt_vars[[i]] # varname in model frame -# ttfun_i <- tt_funs[[i]] # user defined tt function -# -# # time transform at event times -# oldx_i <- model_frame[[varnm_i]] # extract var from model frame -# newx_i <- (ttfun_i)(oldx_i, times) # evaluate tt function at times -# model_frame[[varnm_i]] <- newx_i # substitute back into model frame -# } -# -# return(model_frame) -# } -# -# # update the predvars attribute for time transformed terms -# update_predvars <- function(model_terms, model_frame, tt_vars, tt_terms) { -# tcall <- attr(model_terms, 'variables')[tt_terms + 2] -# pvars <- attr(model_terms, 'predvars') -# pmethod <- sub("makepredictcall.", "", as.vector(methods("makepredictcall"))) -# for (i in 1:length(tt_terms)) { -# # update predvars if necessary -# varnm_i <- tt_vars[[i]] # varname in model frame -# terms_i <- tt_terms[i] + 2 # index in terms object -# x_i <- model_frame[[varnm_i]] # extract transformed variable from model frame -# nclass <- class(x_i) # check class of transformed variable -# if (any(nclass %in% pmethod)) { # it has a makepredictcall method... -# dummy <- as.call(list(as.name(class(x_i)[1]), tcall[[i]][[2]])) -# ptemp <- makepredictcall(x_i, dummy) -# pvars[[terms_i]] <- ptemp -# } -# } -# attr(model_terms, "predvars") <- pvars -# return(model_terms) -# } - From 820cbc5295eb6d475d6d95d96854157f1b538772 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Dec 2018 12:18:30 +1100 Subject: [PATCH 108/225] Use make_x instead of make_s for pp_data.stansurv --- R/pp_data.R | 74 +++++++++++++++++++++++++++-------------------------- 1 file changed, 38 insertions(+), 36 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index 6290e975f..41c131fee 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -252,6 +252,7 @@ pp_data <- formula <- object$formula basehaz <- object$basehaz + # data with row subsetting etc if (is.null(newdata)) newdata <- get_model_data(object) @@ -259,7 +260,8 @@ pp_data <- has_tde <- object$has_tde has_quadrature <- object$has_quadrature - # define dimensions and times for quadrature + #----- dimensions and times + if (has_quadrature && at_quadpoints) { if (is.null(times)) @@ -286,46 +288,46 @@ pp_data <- } else { # predictions don't require quadrature - pts <- times - wts <- rep(NA, length(times)) - ids <- seq_along(times) + pts <- times + wts <- rep(NA, length(times)) + ids <- seq_along(times) } - # time-fixed predictor matrix - tf_form <- reformulate_rhs(rhs(formula$tf_form)) - mf <- make_model_frame(tf_form, newdata, check_constant = FALSE)$mf - x <- make_x(tf_form, mf, xlevs= object$xlevs, check_constant = FALSE)$x - if (has_quadrature && at_quadpoints) { - x <- rep_rows(x, times = qnodes) - } + #----- model frame for generating predictor matrices - # time-varying predictor matrix - if (has_tde) { # model has tde - if (at_quadpoints) { - # expand covariate data - newdata <- rep_rows(newdata, times = qnodes) - } - if (all(is.na(pts))) { - # temporary replacement to avoid error in creating spline basis - pts_tmp <- rep(0, length(pts)) - } else { - # else use prediction times or quadrature points - pts_tmp <- pts - } - s <- make_s(formula = object$formula$td_form, - data = newdata, - times = pts_tmp, - xlevs = object$xlevs) - if (all(is.na(pts))) { - # if pts were all NA then replace the time-varying predictor - # matrix with all NA, but retain appropriate dimensions - s[] <- NaN - } - } else { # model does not have tde - s <- matrix(0, length(pts), 0) + tt <- delete.response(terms(object)) + + mf <- make_model_frame(tt, newdata, xlevs = object$xlevs)$mf + + if (has_quadrature && at_quadpoints) + mf <- rep_rows(mf, times = qnodes) + + if (has_tde) { + + # formula for generating spline basis for tde effects + bsf <- formula$bs_form + + # generate a model frame with time transformations for tde effects + mf_tde <- make_model_frame(bsf, data.frame(times__ = pts))$mf + + # NB next line avoids dropping terms attribute from 'mf' + mf[, colnames(mf_tde)] <- mf_tde + } - + + # check data classes in the model frame match those used in model fitting + if (!is.null(cl <- attr(tt, "dataClasses"))) + .checkMFClasses(cl, mf) + + #----- time-fixed predictor matrix + + x <- make_x(tt, mf)$x + + #----- time-varying predictor matrix + + s <- if (has_tde) make_x(formula$tt_form, mf)$x else matrix(0, length(pts), 0) + # return object return(nlist(pts, wts, From af326f204324cfdb976de5d698357b1f2b9db479 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Dec 2018 12:42:55 +1100 Subject: [PATCH 109/225] Tidy up stan_surv's parse_formula function --- R/stan_surv.R | 217 ++++++++++++++++++++++++++++---------------------- 1 file changed, 122 insertions(+), 95 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 75256b893..c3a2d93a5 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1270,27 +1270,42 @@ parse_formula <- function(formula, data) { formula <- validate_formula(formula, needs_response = TRUE) + # All variables of entire formula + allvars <- all.vars(formula) + allvars_form <- reformulate(allvars) + + # LHS of entire formula lhs <- lhs(formula) # LHS as expression lhs_form <- reformulate_lhs(lhs) # LHS as formula + # RHS of entire formula rhs <- rhs(formula) # RHS as expression rhs_form <- reformulate_rhs(rhs) # RHS as formula - + + # LHS and fixed-effect part of formula, including 'tde(x, ...)' wrapper + nobars_form <- lme4::nobars(formula) + + # Just fixed-effect part of formula, including 'tde(x, ...)' wrapper fe_form <- lme4::nobars(rhs_form) fe_terms <- terms(fe_form, specials = "tde") - fe_vars <- rownames(attr(fe_terms, "factors")) - + + # Just random-effect part of formula bars <- lme4::findbars(rhs_form) re_parts <- lapply(bars, split_at_bars) re_forms <- fetch(re_parts, "re_form") if (length(bars) > 2L) stop2("A maximum of 2 grouping factors are allowed.") - - allvars <- all.vars(formula) - allvars_form <- reformulate(allvars) - nobars_form <- lme4::nobars(formula) - + # Handle 'tde(x, ...)' in formula + tde_stuff <- handle_tde(fe_terms) + tf_form <- tde_stuff$tf_form + td_form <- tde_stuff$td_form # may be NULL + bs_form <- tde_stuff$bs_form # may be NULL + tt_form <- tde_stuff$tt_form # may be NULL + tt_basis <- tde_stuff$tt_basis # may be NULL + tt_calls <- tde_stuff$tt_calls # may be NULL + + # Evaluated response variables surv <- eval(lhs, envir = data) # Surv object surv <- validate_surv(surv) type <- attr(surv, "type") @@ -1321,90 +1336,6 @@ parse_formula <- function(formula, data) { max_t <- max(surv[, c("time1", "time2")]) } - sel <- attr(fe_terms, "specials")$tde - - if (!is.null(sel)) { # model has tde - - # replace 'tde(x, ...)' in formula with 'x' - tde_oldvars <- fe_vars - tde_newvars <- sapply(tde_oldvars, function(oldvar) { - if (oldvar %in% fe_vars[sel]) { - tde <- function(newvar, ...) { # define tde function locally - safe_deparse(substitute(newvar)) - } - eval(parse(text = oldvar)) - } else oldvar - }, USE.NAMES = FALSE) - tf_term_labels <- attr(fe_terms, "term.labels") - td_term_labels <- c() - k <- 0 # initialise td_term_labels indexing (for creating a new formula) - for (i in sel) { - sel_terms <- which(attr(fe_terms, "factors")[i, ] > 0) - for (j in sel_terms) { - k <- k + 1 - tf_term_labels[j] <- td_term_labels[k] <- gsub(tde_oldvars[i], - tde_newvars[i], - tf_term_labels[j], - fixed = TRUE) - } - } - - # extract 'tde(x, ...)' from formula and construct 'bs(times, ...)' - tde_terms <- lapply(fe_vars[sel], function(x) { - tde <- function(vn, ...) { # define tde function locally - dots <- list(...) - ok_args <- c("df") - if (!isTRUE(all(names(dots) %in% ok_args))) - stop2("Invalid argument to 'tde' function. ", - "Valid arguments are: ", comma(ok_args)) - df <- if (is.null(dots$df)) 3 else dots$df - degree <- 3 - if (df == 3) { - dots[["knots"]] <- numeric(0) - } else { - dx <- (max_t - min_t) / (df - degree + 1) - dots[["knots"]] <- seq(min_t + dx, max_t - dx, dx) - } - dots[["Boundary.knots"]] <- c(min_t, max_t) - sub("^list\\(", "bs\\(times__, ", safe_deparse(dots)) - } - tde_calls <- eval(parse(text = x)) - sel_terms <- which(attr(fe_terms, "factors")[x, ] > 0) - new_calls <- sapply(seq_along(sel_terms), function(j) { - paste0(tf_term_labels[sel_terms[j]], ":", tde_calls) - }) - nlist(tde_calls, new_calls) - }) - - # formula with all variables but no 'tde(x, ...)' wrappers - tf_form <- reformulate(tf_term_labels, response = lhs) - - # formula with only tde variables but no 'tde(x, ...)' wrappers - td_form <- reformulate(td_term_labels, response = lhs) - - # formula with 'bs(times__, ...)' terms based on 'tde(x, ...)' calls - tt_basis <- fetch(tde_terms, "tde_calls") - bs_form <- reformulate(unique(unlist(tt_basis)), - response = NULL, - intercept = FALSE) - - # formula with 'x:bs(times__, ...)' terms based on 'tde(x, ...)' calls - tt_calls <- fetch_(tde_terms, "new_calls") - tt_form <- reformulate(tt_calls, - response = NULL, - intercept = FALSE) - - } else { # model doesn't have tde - - tf_form <- formula - td_form <- NULL - bs_form <- NULL - tt_form <- NULL - tt_basis <- NULL - tt_calls <- NULL - - } - nlist(formula, lhs, lhs_form, @@ -1428,11 +1359,105 @@ parse_formula <- function(formula, data) { surv_type = attr(surv, "type")) } +# Handle the 'tde(x, ...)' terms in the model formula +# +# @param Terms terms object for the fixed effect part of the model formula. +# @return A named list with the following elements: +# +handle_tde <- function(Terms) { + + sel <- attr(Terms, "specials")$tde + + if (is.null(sel)) # model does not have tde terms + return(list(tf_form = formula(Terms), + td_form = NULL, + bs_form = NULL, + tt_form = NULL, + tt_basis = NULL, + tt_calls = NULL)) + + # otherwise model does has tde terms... + varnms <- rownames(attr(Terms, "factors")) + + # replace 'tde(x, ...)' in formula with 'x' + tde_oldvars <- varnms + tde_newvars <- sapply(tde_oldvars, function(oldvar) { + if (oldvar %in% varnms[sel]) { + tde <- function(newvar, ...) { # define tde function locally + safe_deparse(substitute(newvar)) + } + eval(parse(text = oldvar)) + } else oldvar + }, USE.NAMES = FALSE) + tf_term_labels <- attr(Terms, "term.labels") + td_term_labels <- c() + k <- 0 # initialise td_term_labels indexing (for creating a new formula) + for (i in sel) { + sel_terms <- which(attr(Terms, "factors")[i, ] > 0) + for (j in sel_terms) { + k <- k + 1 + tf_term_labels[j] <- td_term_labels[k] <- gsub(tde_oldvars[i], + tde_newvars[i], + tf_term_labels[j], + fixed = TRUE) + } + } + + # extract 'tde(x, ...)' from formula and construct 'bs(times, ...)' + tde_terms <- lapply(varnms[sel], function(x) { + tde <- function(vn, ...) { # define tde function locally + dots <- list(...) + ok_args <- c("df") + if (!isTRUE(all(names(dots) %in% ok_args))) + stop2("Invalid argument to 'tde' function. ", + "Valid arguments are: ", comma(ok_args)) + df <- if (is.null(dots$df)) 3 else dots$df + degree <- 3 + if (df == 3) { + dots[["knots"]] <- numeric(0) + } else { + dx <- (max_t - min_t) / (df - degree + 1) + dots[["knots"]] <- seq(min_t + dx, max_t - dx, dx) + } + dots[["Boundary.knots"]] <- c(min_t, max_t) + sub("^list\\(", "bs\\(times__, ", safe_deparse(dots)) + } + tde_calls <- eval(parse(text = x)) + sel_terms <- which(attr(Terms, "factors")[x, ] > 0) + new_calls <- sapply(seq_along(sel_terms), function(j) { + paste0(tf_term_labels[sel_terms[j]], ":", tde_calls) + }) + nlist(tde_calls, new_calls) + }) + + # formula with all variables but no 'tde(x, ...)' wrappers + tf_form <- reformulate(tf_term_labels, response = lhs) + + # formula with only tde variables but no 'tde(x, ...)' wrappers + td_form <- reformulate(td_term_labels, response = lhs) + + # formula with 'bs(times__, ...)' terms based on 'tde(x, ...)' calls + tt_basis <- fetch(tde_terms, "tde_calls"); utt <- unique(unlist(tt_basis)) + bs_form <- reformulate(utt, response = NULL, intercept = FALSE) + + # formula with 'x:bs(times__, ...)' terms based on 'tde(x, ...)' calls + tt_calls <- fetch_(tde_terms, "new_calls") + tt_form <- reformulate(tt_calls, response = NULL, intercept = FALSE) + + # return object + nlist(tf_form, + td_form, + bs_form, + tt_form, + tt_basis, + tt_calls) +} -# Check formula object +# Check input to the formula argument # # @param formula The user input to the formula argument. # @param needs_response A logical; if TRUE then formula must contain a LHS. +# @return A formula. validate_formula <- function(formula, needs_response = TRUE) { if (!inherits(formula, "formula")) { @@ -1450,8 +1475,10 @@ validate_formula <- function(formula, needs_response = TRUE) { # Check object is a Surv object with a valid type # -# @param x A Surv object; the LHS of a formula evaluated in a data frame environment. -# @param ok_types A character vector giving the allowed types of Surv object. +# @param x A Surv object. That is, the LHS of a formula as evaluated in a +# data frame environment. +# @param ok_types A character vector giving the valid types of Surv object. +# @return A Surv object. validate_surv <- function(x, ok_types = c("right", "counting", "interval", "interval2")) { if (!inherits(x, "Surv")) From b959811e8f9c81ce76be2a35dce787ac81d5fe39 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 5 Feb 2019 15:30:25 +1100 Subject: [PATCH 110/225] Update roxygen version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0405165bf..cf7c1f4b7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -70,4 +70,4 @@ LazyData: true NeedsCompilation: yes URL: http://discourse.mc-stan.org, http://mc-stan.org/, http://mc-stan.org/rstanarm/ BugReports: https://github.com/stan-dev/rstanarm/issues -RoxygenNote: 6.1.0 +RoxygenNote: 6.1.1 From 8b662c3fdcda54ba0e2b88d765a6f7014f359699 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 5 Feb 2019 15:30:39 +1100 Subject: [PATCH 111/225] Remove preclean --- rstanarm.Rproj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/rstanarm.Rproj b/rstanarm.Rproj index e23bb38f1..ecf48868d 100644 --- a/rstanarm.Rproj +++ b/rstanarm.Rproj @@ -13,6 +13,6 @@ RnwWeave: knitr LaTeX: pdfLaTeX BuildType: Package -PackageInstallArgs: --no-multiarch --with-keep.source --precleanO +PackageInstallArgs: --no-multiarch --with-keep.source PackageCheckArgs: --run-dontrun --run-donttest PackageRoxygenize: rd,collate,namespace From 92a90b70bad7bae58870a04cc43f0af4bc99b914 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 5 Feb 2019 15:35:18 +1100 Subject: [PATCH 112/225] stan_surv.R: start adding prior_covariance and Stan data for random effects structure --- R/stan_surv.R | 284 +++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 226 insertions(+), 58 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index c3a2d93a5..d021bb07e 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -383,16 +383,17 @@ #' stan_surv <- function(formula, data, - basehaz = "ms", + basehaz = "ms", basehaz_ops, - qnodes = 15, - prior = normal(), - prior_intercept = normal(), - prior_aux = normal(), - prior_smooth = exponential(autoscale = FALSE), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = 0.95, ...) { + qnodes = 15, + prior = normal(), + prior_intercept = normal(), + prior_aux = normal(), + prior_smooth = exponential(autoscale = FALSE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = 0.95, ...) { #----------------------------- # Pre-processing of arguments @@ -629,31 +630,10 @@ stan_surv <- function(formula, #----- time-fixed predictor matrices - tf <- formula$tf_form - + tf <- formula$tf_form x <- make_x(tf, mf, xlevs = xlevs)$x # only used for scaling priors x_cpts <- make_x(tf, mf_cpts, xlevs = xlevs)$x - K <- ncol(x) - - #----- time-varying predictor matrices - - if (has_tde) { - - s_cpts <- make_x(formula$tt_form, mf_cpts, xlevs = xlevs)$x - smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") - smooth_idx <- get_idx_array(table(smooth_map)) - S <- ncol(s_cpts) # number of tde spline coefficients - - } else { - - s_cpts <- matrix(0,length(cpts),0) - smooth_idx <- matrix(0,0,2) - smooth_map <- integer(0) - S <- 0L - - } - - #----- unstack predictor matrices + K <- ncol(x) if (!has_quadrature) { @@ -677,8 +657,25 @@ stan_surv <- function(formula, x_qpts_rcens <- x_cpts[idx_cpts[4,1]:idx_cpts[4,2], , drop = FALSE] x_qpts_icens <- x_cpts[idx_cpts[5,1]:idx_cpts[5,2], , drop = FALSE] x_qpts_delay <- x_cpts[idx_cpts[7,1]:idx_cpts[7,2], , drop = FALSE] + + } + + #----- time-varying predictor matrices - # time-varying predictor matrices + if (has_tde) { + s_cpts <- make_x(formula$tt_form, mf_cpts, xlevs = xlevs)$x + smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") + smooth_idx <- get_idx_array(table(smooth_map)) + S <- ncol(s_cpts) # number of tde spline coefficients + } else { + s_cpts <- matrix(0,length(cpts),0) + smooth_idx <- matrix(0,0,2) + smooth_map <- integer(0) + S <- 0L + } + + if (has_quadrature) { + s_epts_event <- s_cpts[idx_cpts[1,1]:idx_cpts[1,2], , drop = FALSE] s_qpts_event <- s_cpts[idx_cpts[2,1]:idx_cpts[2,2], , drop = FALSE] s_qpts_lcens <- s_cpts[idx_cpts[3,1]:idx_cpts[3,2], , drop = FALSE] @@ -686,8 +683,60 @@ stan_surv <- function(formula, s_qpts_icenl <- s_cpts[idx_cpts[5,1]:idx_cpts[5,2], , drop = FALSE] s_qpts_icenu <- s_cpts[idx_cpts[6,1]:idx_cpts[6,2], , drop = FALSE] s_qpts_delay <- s_cpts[idx_cpts[7,1]:idx_cpts[7,2], , drop = FALSE] - + + } + + #----- random effects predictor matrices + + # use 'stan_glmer' approach + if (length(formula$bars)) { + group <- lme4::mkReTrms(formula$bars, mf_cpts) + group <- pad_reTrms(Ztlist = group$Ztlist, + cnms = group$cnms, + flist = group$flist) + z_cpts <- group$Z + } else { + group <- NULL + z_cpts <- matrix(0,length(cpts),0) } + + if (!has_quadrature) { + + # random effects predictor matrices, without quadrature + # NB skip index 5 on purpose, since time fixed predictor matrix is + # identical for lower and upper limits of interval censoring time + z_event <- z_cpts[idx_cpts[1,1]:idx_cpts[1,2], , drop = FALSE] + z_lcens <- z_cpts[idx_cpts[2,1]:idx_cpts[2,2], , drop = FALSE] + z_rcens <- z_cpts[idx_cpts[3,1]:idx_cpts[3,2], , drop = FALSE] + z_icens <- z_cpts[idx_cpts[4,1]:idx_cpts[4,2], , drop = FALSE] + z_delay <- z_cpts[idx_cpts[6,1]:idx_cpts[6,2], , drop = FALSE] + + parts_event <- extract_sparse_parts(z_event) + parts_lcens <- extract_sparse_parts(z_lcens) + parts_rcens <- extract_sparse_parts(z_rcens) + parts_icens <- extract_sparse_parts(z_icens) + parts_delay <- extract_sparse_parts(z_delay) + + } else { + + # random effects predictor matrices, with quadrature + # NB skip index 6 on purpose, since time fixed predictor matrix is + # identical for lower and upper limits of interval censoring time + z_epts_event <- z_cpts[idx_cpts[1,1]:idx_cpts[1,2], , drop = FALSE] + z_qpts_event <- z_cpts[idx_cpts[2,1]:idx_cpts[2,2], , drop = FALSE] + z_qpts_lcens <- z_cpts[idx_cpts[3,1]:idx_cpts[3,2], , drop = FALSE] + z_qpts_rcens <- z_cpts[idx_cpts[4,1]:idx_cpts[4,2], , drop = FALSE] + z_qpts_icens <- z_cpts[idx_cpts[5,1]:idx_cpts[5,2], , drop = FALSE] + z_qpts_delay <- z_cpts[idx_cpts[7,1]:idx_cpts[7,2], , drop = FALSE] + + parts_epts_event <- extract_sparse_parts(z_epts_event) + parts_qpts_event <- extract_sparse_parts(z_qpts_event) + parts_qpts_lcens <- extract_sparse_parts(z_qpts_lcens) + parts_qpts_rcens <- extract_sparse_parts(z_qpts_rcens) + parts_qpts_icens <- extract_sparse_parts(z_qpts_icens) + parts_qpts_delay <- extract_sparse_parts(z_qpts_delay) + + } #----- stan data @@ -718,6 +767,30 @@ stan_surv <- function(formula, x_rcens = if (has_quadrature) matrix(0,0,K) else x_rcens, x_icens = if (has_quadrature) matrix(0,0,K) else x_icens, x_delay = if (has_quadrature) matrix(0,0,K) else x_delay, + + w_event = if (has_quadrature || nevent == 0) double(0) else parts_event$w, + w_lcens = if (has_quadrature || nlcens == 0) double(0) else parts_lcens$w, + w_rcens = if (has_quadrature || nrcens == 0) double(0) else parts_rcens$w, + w_icens = if (has_quadrature || nicens == 0) double(0) else parts_icens$w, + w_delay = if (has_quadrature || ndelay == 0) double(0) else parts_delay$w, + + v_event = if (has_quadrature || nevent == 0) integer(0) else parts_event$v - 1L, + v_lcens = if (has_quadrature || nlcens == 0) integer(0) else parts_lcens$v - 1L, + v_rcens = if (has_quadrature || nrcens == 0) integer(0) else parts_rcens$v - 1L, + v_icens = if (has_quadrature || nicens == 0) integer(0) else parts_icens$v - 1L, + v_delay = if (has_quadrature || ndelay == 0) integer(0) else parts_delay$v - 1L, + + u_event = if (has_quadrature || nevent == 0) integer(0) else parts_event$u - 1L, + u_lcens = if (has_quadrature || nlcens == 0) integer(0) else parts_lcens$u - 1L, + u_rcens = if (has_quadrature || nrcens == 0) integer(0) else parts_rcens$u - 1L, + u_icens = if (has_quadrature || nicens == 0) integer(0) else parts_icens$u - 1L, + u_delay = if (has_quadrature || ndelay == 0) integer(0) else parts_delay$u - 1L, + + nnz_event = if (has_quadrature || nevent == 0) 0L else length(parts_event$w), + nnz_lcens = if (has_quadrature || nlcens == 0) 0L else length(parts_lcens$w), + nnz_rcens = if (has_quadrature || nrcens == 0) 0L else length(parts_rcens$w), + nnz_icens = if (has_quadrature || nicens == 0) 0L else length(parts_icens$w), + nnz_delay = if (has_quadrature || ndelay == 0) 0L else length(parts_delay$w), basis_event = if (has_quadrature) matrix(0,0,nvars) else basis_event, ibasis_event = if (has_quadrature) matrix(0,0,nvars) else ibasis_event, @@ -771,6 +844,34 @@ stan_surv <- function(formula, s_qpts_icenu = if (!has_quadrature) matrix(0,0,S) else s_qpts_icenu, s_qpts_delay = if (!has_quadrature) matrix(0,0,S) else s_qpts_delay, + w_epts_event = if (!has_quadrature || qevent == 0) double(0) else parts_epts_event$w, + w_qpts_event = if (!has_quadrature || qevent == 0) double(0) else parts_qpts_event$w, + w_qpts_lcens = if (!has_quadrature || qlcens == 0) double(0) else parts_qpts_lcens$w, + w_qpts_rcens = if (!has_quadrature || qrcens == 0) double(0) else parts_qpts_rcens$w, + w_qpts_icens = if (!has_quadrature || qicens == 0) double(0) else parts_qpts_icens$w, + w_qpts_delay = if (!has_quadrature || qdelay == 0) double(0) else parts_qpts_delay$w, + + v_epts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_epts_event$v - 1L, + v_qpts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_qpts_event$v - 1L, + v_qpts_lcens = if (!has_quadrature || qlcens == 0) integer(0) else parts_qpts_lcens$v - 1L, + v_qpts_rcens = if (!has_quadrature || qrcens == 0) integer(0) else parts_qpts_rcens$v - 1L, + v_qpts_icens = if (!has_quadrature || qicens == 0) integer(0) else parts_qpts_icens$v - 1L, + v_qpts_delay = if (!has_quadrature || qdelay == 0) integer(0) else parts_qpts_delay$v - 1L, + + u_epts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_epts_event$u - 1L, + u_qpts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_qpts_event$u - 1L, + u_qpts_lcens = if (!has_quadrature || qlcens == 0) integer(0) else parts_qpts_lcens$u - 1L, + u_qpts_rcens = if (!has_quadrature || qrcens == 0) integer(0) else parts_qpts_rcens$u - 1L, + u_qpts_icens = if (!has_quadrature || qicens == 0) integer(0) else parts_qpts_icens$u - 1L, + u_qpts_delay = if (!has_quadrature || qdelay == 0) integer(0) else parts_qpts_delay$u - 1L, + + nnz_epts_event = if (!has_quadrature || qevent == 0) 0L else length(parts_epts_event$w), + nnz_qpts_event = if (!has_quadrature || qevent == 0) 0L else length(parts_qpts_event$w), + nnz_qpts_lcens = if (!has_quadrature || qlcens == 0) 0L else length(parts_qpts_lcens$w), + nnz_qpts_rcens = if (!has_quadrature || qrcens == 0) 0L else length(parts_qpts_rcens$w), + nnz_qpts_icens = if (!has_quadrature || qicens == 0) 0L else length(parts_qpts_icens$w), + nnz_qpts_delay = if (!has_quadrature || qdelay == 0) 0L else length(parts_qpts_delay$w), + basis_epts_event = if (!has_quadrature) matrix(0,0,nvars) else basis_epts_event, basis_qpts_event = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_event, basis_qpts_lcens = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_lcens, @@ -779,7 +880,31 @@ stan_surv <- function(formula, basis_qpts_icenu = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_icenu, basis_qpts_delay = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_delay ) + + #----- random-effects structure + if (length(formula$bars)) { + + fl <- group$flist + p <- sapply(group$cnms, FUN = length) + l <- sapply(attr(fl, "assign"), function(i) nlevels(fl[[i]])) + t <- length(l) + standata$p <- as.array(p) # num ranefs for each grouping factor + standata$l <- as.array(l) # num levels for each grouping factor + standata$t <- t # num of grouping factors + standata$q <- ncol(z) # p * l + standata$special_case <- all(sapply(group$cnms, intercept_only)) + + } else { # no random effects structure + + standata$p <- integer(0) + standata$l <- integer(0) + standata$t <- 0L + standata$q <- 0L + standata$special_case <- 0L + + } + #----- priors and hyperparameters # valid priors @@ -790,9 +915,10 @@ stan_surv <- function(formula, "hs_plus", "laplace", "lasso") # disallow product normal - ok_intercept_dists <- ok_dists[1:3] - ok_aux_dists <- ok_dists[1:3] - ok_smooth_dists <- c(ok_dists[1:3], "exponential") + ok_intercept_dists <- ok_dists[1:3] + ok_aux_dists <- ok_dists[1:3] + ok_smooth_dists <- c(ok_dists[1:3], "exponential") + ok_covariance_dists <- c("decov") # priors user_prior_stuff <- prior_stuff <- @@ -822,18 +948,25 @@ stan_surv <- function(formula, default_scale = 1, link = NULL, ok_dists = ok_smooth_dists) - - # stop null priors if prior_PD is TRUE + + user_prior_b_stuff <- prior_b_stuff <- + handle_cov_prior(prior_covariance, + cnms = group$cnms, + ok_dists = ok_covariance_dists) + + # stop null priors if (prior_PD) { if (is.null(prior)) - stop("'prior' cannot be NULL if 'prior_PD' is TRUE") + stop("'prior' cannot be NULL if 'prior_PD' is TRUE.") if (is.null(prior_intercept) && has_intercept) - stop("'prior_intercept' cannot be NULL if 'prior_PD' is TRUE") + stop("'prior_intercept' cannot be NULL if 'prior_PD' is TRUE.") if (is.null(prior_aux)) - stop("'prior_aux' cannot be NULL if 'prior_PD' is TRUE") + stop("'prior_aux' cannot be NULL if 'prior_PD' is TRUE.") if (is.null(prior_smooth) && (S > 0)) - stop("'prior_smooth' cannot be NULL if 'prior_PD' is TRUE") + stop("'prior_smooth' cannot be NULL if 'prior_PD' is TRUE.") } + if (is.null(prior_covariance) && length(group$bars)) + stop("'prior_covariance' cannot be NULL.") # autoscaling of priors prior_stuff <- autoscale_prior(prior_stuff, predictors = x) @@ -846,6 +979,7 @@ stan_surv <- function(formula, standata$prior_dist_for_intercept<- prior_intercept_stuff$prior_dist standata$prior_dist_for_aux <- prior_aux_stuff$prior_dist standata$prior_dist_for_smooth <- prior_smooth_stuff$prior_dist + standata$prior_dist_for_cov <- prior_b_stuff$prior_dist # hyperparameters standata$prior_mean <- prior_stuff$prior_mean @@ -863,10 +997,29 @@ stan_surv <- function(formula, standata$global_prior_df <- prior_stuff$global_prior_df standata$slab_df <- prior_stuff$slab_df standata$slab_scale <- prior_stuff$slab_scale - + + # hyperparameters for covariance + if (!length(bars)) { + standata$b_prior_shape <- prior_b_stuff$prior_shape + standata$b_prior_scale <- prior_b_stuff$prior_scale + standata$b_prior_concentration <- prior_b_stuff$prior_concentration + standata$b_prior_regularization <- prior_b_stuff$prior_regularization + standata$len_concentration <- length(standata$b_prior_concentration) + standata$len_regularization <- length(standata$b_prior_regularization) + standata$len_theta_L <- sum(choose(standata$p, 2), standata$p) + } else { # no random effects structure + standata$len_concentration <- 0L + standata$len_regularization <- 0L + standata$len_theta_L <- 0L + standata$b_prior_shape <- rep(0, 0) + standata$b_prior_scale <- rep(0, 0) + standata$b_prior_concentration <- rep(0, 0) + standata$b_prior_regularization <- rep(0, 0) + } + # any additional flags standata$prior_PD <- ai(prior_PD) - + #--------------- # Prior summary #--------------- @@ -880,7 +1033,10 @@ stan_surv <- function(formula, adjusted_priorEvent_aux_scale = prior_aux_stuff$prior_scale, e_has_intercept = has_intercept, e_has_predictors = K > 0, - basehaz = basehaz + basehaz = basehaz, + user_prior_covariance = prior_covariance, + b_user_prior_stuff = user_prior_b_stuff, + b_prior_stuff = prior_b_stuff ) #----------- @@ -895,7 +1051,8 @@ stan_surv <- function(formula, if (standata$K) "beta", if (standata$S) "beta_tde", if (standata$S) "smooth_sd", - if (standata$nvars) "coefs") + if (standata$nvars) "coefs", + if (standata$t) "b") # fit model using stan if (algorithm == "sampling") { # mcmc @@ -926,11 +1083,13 @@ stan_surv <- function(formula, nms_smooth <- get_smooth_name(s_cpts, type = "smooth_sd") # may be NULL nms_int <- get_int_name_basehaz(basehaz) nms_aux <- get_aux_name_basehaz(basehaz) + nms_b <- if (standata$t) make_b_nms(group) else NULL nms_all <- c(nms_int, nms_beta, nms_tde, nms_smooth, nms_aux, + nms_b, "log-posterior") # substitute new parameter names into 'stanfit' object @@ -1296,15 +1455,6 @@ parse_formula <- function(formula, data) { if (length(bars) > 2L) stop2("A maximum of 2 grouping factors are allowed.") - # Handle 'tde(x, ...)' in formula - tde_stuff <- handle_tde(fe_terms) - tf_form <- tde_stuff$tf_form - td_form <- tde_stuff$td_form # may be NULL - bs_form <- tde_stuff$bs_form # may be NULL - tt_form <- tde_stuff$tt_form # may be NULL - tt_basis <- tde_stuff$tt_basis # may be NULL - tt_calls <- tde_stuff$tt_calls # may be NULL - # Evaluated response variables surv <- eval(lhs, envir = data) # Surv object surv <- validate_surv(surv) @@ -1335,7 +1485,16 @@ parse_formula <- function(formula, data) { min_t <- 0 max_t <- max(surv[, c("time1", "time2")]) } - + + # Handle 'tde(x, ...)' in formula + tde_stuff <- handle_tde(fe_terms, lhs = lhs, min_t = min_t, max_t = max_t) + tf_form <- tde_stuff$tf_form + td_form <- tde_stuff$td_form # may be NULL + bs_form <- tde_stuff$bs_form # may be NULL + tt_form <- tde_stuff$tt_form # may be NULL + tt_basis <- tde_stuff$tt_basis # may be NULL + tt_calls <- tde_stuff$tt_calls # may be NULL + nlist(formula, lhs, lhs_form, @@ -1348,6 +1507,7 @@ parse_formula <- function(formula, data) { tt_basis, tt_calls, fe_form, + bars, re_forms, re_parts, allvars, @@ -1364,7 +1524,7 @@ parse_formula <- function(formula, data) { # @param Terms terms object for the fixed effect part of the model formula. # @return A named list with the following elements: # -handle_tde <- function(Terms) { +handle_tde <- function(Terms, lhs, min_t, max_t) { sel <- attr(Terms, "specials")$tde @@ -1675,3 +1835,11 @@ make_x <- function(formula, model_frame, xlevs = NULL, nlist(x, xbar, N = NROW(x), K = NCOL(x)) } + +# Check if the only element of a character vector is 'Intercept' +# +# @param x A character vector. +# @return A logical. +intercept_only <- function(x) { + length(x) == 1 && x == "(Intercept)" +} From 8591b6c16cb96e48ddbc9aeb71a38d675e2f89b6 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 8 Feb 2019 16:55:33 +1100 Subject: [PATCH 113/225] stan_surv.R: handle group-specific terms --- R/stan_surv.R | 142 +++++++++++++++++++++++++++++++------------------- 1 file changed, 88 insertions(+), 54 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index d021bb07e..6f83c6eb1 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -630,9 +630,9 @@ stan_surv <- function(formula, #----- time-fixed predictor matrices - tf <- formula$tf_form - x <- make_x(tf, mf, xlevs = xlevs)$x # only used for scaling priors - x_cpts <- make_x(tf, mf_cpts, xlevs = xlevs)$x + ff <- formula$fe_form + x <- make_x(ff, mf, xlevs = xlevs)$x # only used for scaling priors + x_cpts <- make_x(ff, mf_cpts, xlevs = xlevs)$x K <- ncol(x) if (!has_quadrature) { @@ -663,15 +663,19 @@ stan_surv <- function(formula, #----- time-varying predictor matrices if (has_tde) { + s_cpts <- make_x(formula$tt_form, mf_cpts, xlevs = xlevs)$x smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") smooth_idx <- get_idx_array(table(smooth_map)) S <- ncol(s_cpts) # number of tde spline coefficients + } else { + s_cpts <- matrix(0,length(cpts),0) smooth_idx <- matrix(0,0,2) smooth_map <- integer(0) S <- 0L + } if (has_quadrature) { @@ -688,16 +692,22 @@ stan_surv <- function(formula, #----- random effects predictor matrices + has_bars <- as.logical(length(formula$bars)) + # use 'stan_glmer' approach - if (length(formula$bars)) { + if (has_bars) { + group <- lme4::mkReTrms(formula$bars, mf_cpts) group <- pad_reTrms(Ztlist = group$Ztlist, cnms = group$cnms, flist = group$flist) z_cpts <- group$Z + } else { + group <- NULL z_cpts <- matrix(0,length(cpts),0) + } if (!has_quadrature) { @@ -883,16 +893,16 @@ stan_surv <- function(formula, #----- random-effects structure - if (length(formula$bars)) { + if (has_bars) { fl <- group$flist p <- sapply(group$cnms, FUN = length) l <- sapply(attr(fl, "assign"), function(i) nlevels(fl[[i]])) t <- length(l) - standata$p <- as.array(p) # num ranefs for each grouping factor - standata$l <- as.array(l) # num levels for each grouping factor - standata$t <- t # num of grouping factors - standata$q <- ncol(z) # p * l + standata$p <- as.array(p) # num ranefs for each grouping factor + standata$l <- as.array(l) # num levels for each grouping factor + standata$t <- t # num of grouping factors + standata$q <- ncol(group$z) # p * l standata$special_case <- all(sapply(group$cnms, intercept_only)) } else { # no random effects structure @@ -948,13 +958,8 @@ stan_surv <- function(formula, default_scale = 1, link = NULL, ok_dists = ok_smooth_dists) - - user_prior_b_stuff <- prior_b_stuff <- - handle_cov_prior(prior_covariance, - cnms = group$cnms, - ok_dists = ok_covariance_dists) - # stop null priors + # stop null priors when prior_PD is true if (prior_PD) { if (is.null(prior)) stop("'prior' cannot be NULL if 'prior_PD' is TRUE.") @@ -965,8 +970,23 @@ stan_surv <- function(formula, if (is.null(prior_smooth) && (S > 0)) stop("'prior_smooth' cannot be NULL if 'prior_PD' is TRUE.") } - if (is.null(prior_covariance) && length(group$bars)) - stop("'prior_covariance' cannot be NULL.") + + # handle prior for random effects structure + if (has_bars) { + + user_prior_b_stuff <- prior_b_stuff <- + handle_cov_prior(prior_covariance, + cnms = group$cnms, + ok_dists = ok_covariance_dists) + + if (is.null(prior_covariance)) + stop("'prior_covariance' cannot be NULL.") + + } else { + user_prior_b_stuff <- NULL + prior_b_stuff <- NULL + prior_covariance <- NULL + } # autoscaling of priors prior_stuff <- autoscale_prior(prior_stuff, predictors = x) @@ -999,7 +1019,7 @@ stan_surv <- function(formula, standata$slab_scale <- prior_stuff$slab_scale # hyperparameters for covariance - if (!length(bars)) { + if (has_bars) { standata$b_prior_shape <- prior_b_stuff$prior_shape standata$b_prior_scale <- prior_b_stuff$prior_scale standata$b_prior_concentration <- prior_b_stuff$prior_concentration @@ -1441,20 +1461,6 @@ parse_formula <- function(formula, data) { rhs <- rhs(formula) # RHS as expression rhs_form <- reformulate_rhs(rhs) # RHS as formula - # LHS and fixed-effect part of formula, including 'tde(x, ...)' wrapper - nobars_form <- lme4::nobars(formula) - - # Just fixed-effect part of formula, including 'tde(x, ...)' wrapper - fe_form <- lme4::nobars(rhs_form) - fe_terms <- terms(fe_form, specials = "tde") - - # Just random-effect part of formula - bars <- lme4::findbars(rhs_form) - re_parts <- lapply(bars, split_at_bars) - re_forms <- fetch(re_parts, "re_form") - if (length(bars) > 2L) - stop2("A maximum of 2 grouping factors are allowed.") - # Evaluated response variables surv <- eval(lhs, envir = data) # Surv object surv <- validate_surv(surv) @@ -1486,16 +1492,28 @@ parse_formula <- function(formula, data) { max_t <- max(surv[, c("time1", "time2")]) } - # Handle 'tde(x, ...)' in formula - tde_stuff <- handle_tde(fe_terms, lhs = lhs, min_t = min_t, max_t = max_t) - tf_form <- tde_stuff$tf_form - td_form <- tde_stuff$td_form # may be NULL - bs_form <- tde_stuff$bs_form # may be NULL - tt_form <- tde_stuff$tt_form # may be NULL - tt_basis <- tde_stuff$tt_basis # may be NULL - tt_calls <- tde_stuff$tt_calls # may be NULL + # Deal with tde(x, ...) + tde_stuff <- handle_tde(formula, min_t = min_t, max_t = max_t) + tf_form <- tde_stuff$tf_form + td_form <- tde_stuff$td_form # may be NULL + bs_form <- tde_stuff$bs_form # may be NULL + tt_form <- tde_stuff$tt_form # may be NULL + tt_basis <- tde_stuff$tt_basis # may be NULL + tt_calls <- tde_stuff$tt_calls # may be NULL + # Just fixed-effect part of formula + fe_form <- lme4::nobars(tf_form) + + # Just random-effect part of formula + bars <- lme4::findbars(tf_form) + re_parts <- lapply(bars, split_at_bars) + re_forms <- fetch(re_parts, "re_form") + if (length(bars) > 2L) + stop2("A maximum of 2 grouping factors are allowed.") + nlist(formula, + allvars, + allvars_form, lhs, lhs_form, rhs, @@ -1508,11 +1526,8 @@ parse_formula <- function(formula, data) { tt_calls, fe_form, bars, - re_forms, re_parts, - allvars, - allvars_form, - nobars_form, + re_forms, tvar_beg, tvar_end, dvar, @@ -1524,19 +1539,23 @@ parse_formula <- function(formula, data) { # @param Terms terms object for the fixed effect part of the model formula. # @return A named list with the following elements: # -handle_tde <- function(Terms, lhs, min_t, max_t) { - - sel <- attr(Terms, "specials")$tde - - if (is.null(sel)) # model does not have tde terms - return(list(tf_form = formula(Terms), +handle_tde <- function(formula, min_t, max_t) { + + Terms <- terms(lme4::nobars(formula), specials = "tde") + + # if no time-dependent effects then just return formula + if (is.null(attr(Terms, "specials")$tde)) { + return(list(tf_form = formula, td_form = NULL, bs_form = NULL, tt_form = NULL, tt_basis = NULL, tt_calls = NULL)) - - # otherwise model does has tde terms... + } + + # extract rhs of formula + Terms <- delete.response(Terms) + sel <- attr(Terms, "specials")$tde varnms <- rownames(attr(Terms, "factors")) # replace 'tde(x, ...)' in formula with 'x' @@ -1590,11 +1609,18 @@ handle_tde <- function(Terms, lhs, min_t, max_t) { nlist(tde_calls, new_calls) }) + # add on the terms labels from the random effects part of the formula + bars <- lme4::findbars(formula) + if (length(bars)) { + bars_term_labels <- sapply(bars, bracket_wrap) + tf_term_labels <- c(tf_term_labels, bars_term_labels) + } + # formula with all variables but no 'tde(x, ...)' wrappers - tf_form <- reformulate(tf_term_labels, response = lhs) + tf_form <- reformulate(tf_term_labels, response = lhs(formula)) # formula with only tde variables but no 'tde(x, ...)' wrappers - td_form <- reformulate(td_term_labels, response = lhs) + td_form <- reformulate(td_term_labels, response = lhs(formula)) # formula with 'bs(times__, ...)' terms based on 'tde(x, ...)' calls tt_basis <- fetch(tde_terms, "tde_calls"); utt <- unique(unlist(tt_basis)) @@ -1613,6 +1639,14 @@ handle_tde <- function(Terms, lhs, min_t, max_t) { tt_calls) } +# Deparse an expression and wrap it in brackets +# +# @param x An expression. +# @return A character string. +bracket_wrap <- function(x) { + paste0("(", deparse(x, 500), ")") +} + # Check input to the formula argument # # @param formula The user input to the formula argument. From cacdc42dc821592fcc5e6dac1a26a4c296be0635 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 11 Feb 2019 12:23:42 +1100 Subject: [PATCH 114/225] surv.stan: start adding random effects structure --- R/jm_data_block.R | 8 +- R/stan_surv.R | 29 +++--- src/stan_files/surv.stan | 211 +++++++++++++++++++++++++++++++++++++-- 3 files changed, 227 insertions(+), 21 deletions(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 04d7863bd..035aa4971 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -1979,7 +1979,7 @@ evaluate_Sigma <- function(stanfit, cnms) { # @param cnms The component names for the group level terms, combined # across all glmer submodels # @return A character vector -get_Sigma_nms <- function(cnms) { +get_Sigma_nms <- function(cnms, prefix = FALSE) { nms <- names(cnms) Sigma_nms <- lapply(cnms, FUN = function(grp) { nm <- outer(grp, grp, FUN = paste, sep = ",") @@ -1988,7 +1988,11 @@ get_Sigma_nms <- function(cnms) { for (j in seq_along(Sigma_nms)) { Sigma_nms[[j]] <- paste0(nms[j], ":", Sigma_nms[[j]]) } - unlist(Sigma_nms) + if (prefix = TRUE) { + paste0("Sigma[", unlist(Sigma_nms), "]") + } else { + unlist(Sigma_nms) + } } diff --git a/R/stan_surv.R b/R/stan_surv.R index 6f83c6eb1..5bef92bd4 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -534,7 +534,7 @@ stan_surv <- function(formula, qrcens <- length(qwts_rcens) qicens <- length(qwts_icenl) qdelay <- length(qwts_delay) - + } else { # times at all different event types @@ -1020,21 +1020,21 @@ stan_surv <- function(formula, # hyperparameters for covariance if (has_bars) { - standata$b_prior_shape <- prior_b_stuff$prior_shape - standata$b_prior_scale <- prior_b_stuff$prior_scale - standata$b_prior_concentration <- prior_b_stuff$prior_concentration - standata$b_prior_regularization <- prior_b_stuff$prior_regularization - standata$len_concentration <- length(standata$b_prior_concentration) - standata$len_regularization <- length(standata$b_prior_regularization) - standata$len_theta_L <- sum(choose(standata$p, 2), standata$p) + standata$b_prior_shape <- prior_b_stuff$prior_shape + standata$b_prior_scale <- prior_b_stuff$prior_scale + standata$concentration <- prior_b_stuff$prior_concentration + standata$regularization <- prior_b_stuff$prior_regularization + standata$len_concentration <- length(standata$concentration) + standata$len_regularization <- length(standata$regularization) + standata$len_theta_L <- sum(choose(standata$p, 2), standata$p) } else { # no random effects structure + standata$b_prior_shape <- rep(0, 0) + standata$b_prior_scale <- rep(0, 0) + standata$concentration <- rep(0, 0) + standata$regularization <- rep(0, 0) standata$len_concentration <- 0L standata$len_regularization <- 0L standata$len_theta_L <- 0L - standata$b_prior_shape <- rep(0, 0) - standata$b_prior_scale <- rep(0, 0) - standata$b_prior_concentration <- rep(0, 0) - standata$b_prior_regularization <- rep(0, 0) } # any additional flags @@ -1072,7 +1072,8 @@ stan_surv <- function(formula, if (standata$S) "beta_tde", if (standata$S) "smooth_sd", if (standata$nvars) "coefs", - if (standata$t) "b") + if (standata$t) "b", + if (standata$t) "theta_L") # fit model using stan if (algorithm == "sampling") { # mcmc @@ -1104,12 +1105,14 @@ stan_surv <- function(formula, nms_int <- get_int_name_basehaz(basehaz) nms_aux <- get_aux_name_basehaz(basehaz) nms_b <- if (standata$t) make_b_nms(group) else NULL + nms_sigma <- if (standata$t) get_Sigma_nms(group$cnms, wrap = TRUE) else NULL nms_all <- c(nms_int, nms_beta, nms_tde, nms_smooth, nms_aux, nms_b, + nms_sigma, "log-posterior") # substitute new parameter names into 'stanfit' object diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 7ecaa45e4..1dead9578 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -481,6 +481,13 @@ data { int smooth_map[S]; // indexing of smooth sds for tde spline coefs int smooth_idx[S > 0 ? max(smooth_map) : 0, 2]; + // dimensions for random efffects structure, see table 3 of + // https://cran.r-project.org/web/packages/lme4/vignettes/lmer.pdf + int t; // num. terms (maybe 0) with a | in the glmer formula + int p[t]; // num. variables on the LHS of each | + int l[t]; // num. levels for the factor(s) on the RHS of each | + int q; // conceptually equals \sum_{i=1}^t p_i \times l_i + // response and time variables vector[nevent] t_event; // time of events vector[nlcens] t_lcens; // time of left censoring @@ -497,7 +504,6 @@ data { vector[qicens] qpts_icenu; // qpts for time of upper limit for interval censoring vector[qdelay] qpts_delay; // qpts for time of entry for delayed entry - // predictor matrices (time-fixed), without quadrature matrix[nevent,K] x_event; // for rows with events matrix[nlcens,K] x_lcens; // for rows with left censoring @@ -522,6 +528,68 @@ data { matrix[qicens,S] s_qpts_icenu; // for rows with interval censoring matrix[qdelay,S] s_qpts_delay; // for rows with delayed entry + // random effects structure, without quadrature + // nnz: number of non-zero elements in the Z matrix + // w: non-zero elements in the implicit Z matrix + // v: column indices for w + // u: where the non-zeros start in each row + int nnz_event; + int nnz_lcens; + int nnz_rcens; + int nnz_icens; + int nnz_delay; + + vector[nnz_event] w_event; + vector[nnz_lcens] w_lcens; + vector[nnz_rcens] w_rcens; + vector[nnz_icens] w_icens; + vector[nnz_delay] w_delay; + + int v_event[nnz_event]; + int v_lcens[nnz_lcens]; + int v_rcens[nnz_rcens]; + int v_icens[nnz_icens]; + int v_delay[nnz_delay]; + + int u_event[t>0 ? N+1 : 0]; + int u_lcens[t>0 ? N+1 : 0]; + int u_rcens[t>0 ? N+1 : 0]; + int u_icens[t>0 ? N+1 : 0]; + int u_delay[t>0 ? N+1 : 0]; + + // random effects structure, with quadrature + // nnz: number of non-zero elements in the Z matrix + // w: non-zero elements in the implicit Z matrix + // v: column indices for w + // u: where the non-zeros start in each row + int nnz_epts_event; + int nnz_qpts_event; + int nnz_qpts_lcens; + int nnz_qpts_rcens; + int nnz_qpts_icens; + int nnz_qpts_delay; + + vector[nnz_epts_event] w_epts_event; + vector[nnz_qpts_event] w_qpts_event; + vector[nnz_qpts_lcens] w_qpts_lcens; + vector[nnz_qpts_rcens] w_qpts_rcens; + vector[nnz_qpts_icens] w_qpts_icens; + vector[nnz_qpts_delay] w_qpts_delay; + + int v_epts_event[nnz_epts_event]; + int v_qpts_event[nnz_qpts_event]; + int v_qpts_lcens[nnz_qpts_lcens]; + int v_qpts_rcens[nnz_qpts_rcens]; + int v_qpts_icens[nnz_qpts_icens]; + int v_qpts_delay[nnz_qpts_delay]; + + int u_epts_event[t > 0 ? N + 1 : 0]; + int u_qpts_event[t > 0 ? N + 1 : 0]; + int u_qpts_lcens[t > 0 ? N + 1 : 0]; + int u_qpts_rcens[t > 0 ? N + 1 : 0]; + int u_qpts_icens[t > 0 ? N + 1 : 0]; + int u_qpts_delay[t > 0 ? N + 1 : 0]; + // basis matrices for M-splines / I-splines, without quadrature matrix[nevent,nvars] basis_event; // at event time matrix[nevent,nvars] ibasis_event; // at event time @@ -594,7 +662,7 @@ data { // 3 = exponential int prior_dist_for_smooth; - // hyperparameter (log hazard ratios), set to 0 if there is no prior + // hyperparameters (log hazard ratios), set to 0 if there is no prior vector[K] prior_mean; vector[K] prior_scale; vector[K] prior_df; @@ -617,12 +685,54 @@ data { vector[S > 0 ? max(smooth_map) : 0] prior_scale_for_smooth; vector[S > 0 ? max(smooth_map) : 0] prior_df_for_smooth; + // hyperparameters (random effects structure), set to 0 if there is no prior + vector[t] b_prior_shape; + vector[t] b_prior_scale; + int len_theta_L; // length of the theta_L vector + int len_concentration; + int len_regularization; + real concentration[len_concentration]; + real regularization[len_regularization]; + int special_case; // is the only term (1|group) + } transformed data { int hs = get_nvars_for_hs(prior_dist); + int sc = special_case; + + int V_event[sc ? t : 0, nevent] = make_V(nevent, sc ? t : 0, v_event); + int V_lcens[sc ? t : 0, nlcens] = make_V(nlcens, sc ? t : 0, v_lcens); + int V_rcens[sc ? t : 0, nrcens] = make_V(nrcens, sc ? t : 0, v_rcens); + int V_icens[sc ? t : 0, nicens] = make_V(nicens, sc ? t : 0, v_icens); + int V_delay[sc ? t : 0, ndelay] = make_V(ndelay, sc ? t : 0, v_delay); + + int V_epts_event[sc ? t : 0, Nevent] = make_V(Nevent, sc ? t : 0, v_epts_event); + int V_qpts_event[sc ? t : 0, qevent] = make_V(qevent, sc ? t : 0, v_qpts_event); + int V_qpts_lcens[sc ? t : 0, qlcens] = make_V(qlcens, sc ? t : 0, v_qpts_lcens); + int V_qpts_rcens[sc ? t : 0, qrcens] = make_V(qrcens, sc ? t : 0, v_qpts_rcens); + int V_qpts_icens[sc ? t : 0, qicens] = make_V(qicens, sc ? t : 0, v_qpts_icens); + int V_qpts_delay[sc ? t : 0, qdelay] = make_V(qdelay, sc ? t : 0, v_qpts_delay); + + int pos = 1; + int len_z_T = 0; + int len_rho = sum(p) - t; + real delta[len_concentration]; + + for (i in 1:t) { + if (p[i] > 1) { + for (j in 1:p[i]) { + delta[pos] = concentration[j]; + pos += 1; + } + } + for (j in 3:p[i]) len_z_T += p[i] - 1; + } + + + } parameters { @@ -647,6 +757,13 @@ parameters { // hyperparameter, the prior sd for the tde spline coefs vector[S > 0 ? max(smooth_map) : 0] smooth_sd_raw; + // parameters for random effects + vector[q] z_b; + vector[len_z_T] z_T; + vector[len_rho] rho; + vector[len_concentration] zeta; + vector[t] tau; + // parameters for priors real global[hs]; vector[hs > 0 ? K : 0] local[hs]; @@ -657,16 +774,20 @@ parameters { transformed parameters { - // log hazard ratios + // declare log hazard ratios vector[K] beta; - // basehaz parameters + // declare basehaz parameters vector[nvars] coefs; - // tde spline coefficients and their hyperparameters + // declare tde spline coefficients and their hyperparameters vector[S] beta_tde; vector[S > 0 ? max(smooth_map) : 0] smooth_sd; // sd for tde splines + // declare random effects and var-cov parameters + vector[q] b; + vector[len_theta_L] theta_L; + // define log hazard ratios if (K > 0) { beta = make_beta(z_beta, @@ -696,6 +817,26 @@ transformed parameters { } } + // define random effects and var-cov parameters + if (t > 0) { + if (special_case == 1) { + int start = 1; + theta_L = b_prior_scale .* tau * 1.0; + if (t == 1) { + b = theta_L[1] * z_b; + } + else for (i in 1:t) { + int end = start + l[i] - 1; + b[start:end] = theta_L[i] * z_b[start:end]; + start = end + 1; + } + } + else { + theta_L = make_theta_L(len_theta_L, p, 1.0, tau, b_prior_scale, zeta, rho, z_T); + b = make_b(z_b, theta_L, p, l); + } + } + } model { @@ -728,7 +869,7 @@ model { if (ndelay > 0) eta_delay = rep_vector(0.0, ndelay); } - // add intercept + // add on intercept to linear predictor if (has_intercept == 1) { if (nevent > 0) eta_event += gamma[1]; if (nlcens > 0) eta_lcens += gamma[1]; @@ -737,6 +878,29 @@ model { if (ndelay > 0) eta_delay += gamma[1]; } + // add on random effects terms to linear predictor + if (t > 0) { + if (special_case) for (i in 1:t) { + if (nevent > 0) eta_event += b[V_event[i]]; + if (nlcens > 0) eta_lcens += b[V_lcens[i]]; + if (nrcens > 0) eta_rcens += b[V_rcens[i]]; + if (nicens > 0) eta_icens += b[V_icens[i]]; + if (ndelay > 0) eta_delay += b[V_delay[i]]; + } + else { + if (nevent > 0) eta_event += + csr_matrix_times_vector2(nevent, q, w_event, v_event, u_event, b); + if (nlcens > 0) eta_lcens += + csr_matrix_times_vector2(nlcens, q, w_lcens, v_lcens, u_lcens, b); + if (nrcens > 0) eta_rcens += + csr_matrix_times_vector2(nrcens, q, w_rcens, v_rcens, u_rcens, b); + if (nicens > 0) eta_icens += + csr_matrix_times_vector2(nicens, q, w_icens, v_icens, u_icens, b); + if (ndelay > 0) eta_delay += + csr_matrix_times_vector2(ndelay, q, w_delay, v_delay, u_delay, b); + } + } + // aft models if (type == 7 || type == 8) { @@ -870,6 +1034,35 @@ model { if (qdelay > 0) eta_qpts_delay += gamma[1]; } + // add on random effects terms to linear predictor + if (t > 0) { + if (special_case) for (i in 1:t) { + if (Nevent > 0) eta_epts_event += b[V_epts_event[i]]; + if (qevent > 0) eta_qpts_event += b[V_qpts_event[i]]; + if (qlcens > 0) eta_qpts_lcens += b[V_qpts_lcens[i]]; + if (qrcens > 0) eta_qpts_rcens += b[V_qpts_rcens[i]]; + if (qicens > 0) eta_qpts_icenl += b[V_qpts_icens[i]]; + if (qicens > 0) eta_qpts_icenu += b[V_qpts_icens[i]]; + if (qdelay > 0) eta_qpts_delay += b[V_qpts_delay[i]]; + } + else { + if (Nevent > 0) eta_epts_event += + csr_matrix_times_vector2(Nevent, q, w_epts_event, v_epts_event, u_epts_event, b); + if (qevent > 0) eta_qpts_event += + csr_matrix_times_vector2(qevent, q, w_qpts_event, v_qpts_event, u_qpts_event, b); + if (qlcens > 0) eta_qpts_lcens += + csr_matrix_times_vector2(qlcens, q, w_qpts_lcens, v_qpts_lcens, u_qpts_lcens, b); + if (qrcens > 0) eta_qpts_rcens += + csr_matrix_times_vector2(qrcens, q, w_qpts_rcens, v_qpts_rcens, u_qpts_rcens, b); + if (qicens > 0) eta_qpts_icenl += + csr_matrix_times_vector2(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); + if (qicens > 0) eta_qpts_icenu += + csr_matrix_times_vector2(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); + if (qdelay > 0) eta_qpts_delay += + csr_matrix_times_vector2(qdelay, q, w_qpts_delay, v_qpts_delay, u_qpts_delay, b); + } + } + // aft models if (type == 7 || type == 8) { @@ -1018,4 +1211,10 @@ model { prior_dist_for_smooth, prior_df_for_smooth); } + // log prior for random effects + if (t > 0) { + real dummy = decov_lp(z_b, z_T, rho, zeta, tau, + regularization, delta, b_prior_shape, t, p); + } + } From d3a985a8d736c089c5a2a0b62eb819f485c335b3 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 11 Feb 2019 12:29:18 +1100 Subject: [PATCH 115/225] surv.stan: add common functions --- src/stan_files/surv.stan | 69 +--------------------------------------- 1 file changed, 1 insertion(+), 68 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 1dead9578..8c9ef2771 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -4,76 +4,9 @@ functions { +#include /functions/common_functions.stan #include /functions/hazard_functions.stan - /** - * Hierarchical shrinkage parameterization - * - * @param z_beta A vector of primitive coefficients - * @param global A real array of positive numbers - * @param local A vector array of positive numbers - * @param global_prior_scale A positive real number - * @param error_scale 1 or sigma in the Gaussian case - * @param c2 A positive real number - * @return A vector of coefficientes - */ - vector hs_prior(vector z_beta, real[] global, vector[] local, - real global_prior_scale, real error_scale, real c2) { - int K = rows(z_beta); - vector[K] lambda = local[1] .* sqrt(local[2]); - real tau = global[1] * sqrt(global[2]) * global_prior_scale * error_scale; - vector[K] lambda2 = square(lambda); - vector[K] lambda_tilde = sqrt( c2 * lambda2 ./ (c2 + square(tau) * lambda2) ); - return z_beta .* lambda_tilde * tau; - } - - /** - * Hierarchical shrinkage plus parameterization - * - * @param z_beta A vector of primitive coefficients - * @param global A real array of positive numbers - * @param local A vector array of positive numbers - * @param global_prior_scale A positive real number - * @param error_scale 1 or sigma in the Gaussian case - * @param c2 A positive real number - * @return A vector of coefficientes - */ - vector hsplus_prior(vector z_beta, real[] global, vector[] local, - real global_prior_scale, real error_scale, real c2) { - int K = rows(z_beta); - vector[K] lambda = local[1] .* sqrt(local[2]); - vector[K] eta = local[3] .* sqrt(local[4]); - real tau = global[1] * sqrt(global[2]) * global_prior_scale * error_scale; - vector[K] lambda_eta2 = square(lambda .* eta); - vector[K] lambda_tilde = sqrt( c2 * lambda_eta2 ./ - ( c2 + square(tau) * lambda_eta2) ); - return z_beta .* lambda_tilde * tau; - } - - /** - * Cornish-Fisher expansion for standard normal to Student t - * - * See result 26.7.5 of - * http://people.math.sfu.ca/~cbm/aands/page_949.htm - * - * @param z A scalar distributed standard normal - * @param df A scalar degrees of freedom - * @return An (approximate) Student t variate with df degrees of freedom - */ - real CFt(real z, real df) { - real z2 = square(z); - real z3 = z2 * z; - real z5 = z2 * z3; - real z7 = z2 * z5; - real z9 = z2 * z7; - real df2 = square(df); - real df3 = df2 * df; - real df4 = df2 * df2; - return z + (z3 + z) / (4 * df) + (5 * z5 + 16 * z3 + 3 * z) / (96 * df2) - + (3 * z7 + 19 * z5 + 17 * z3 - 15 * z) / (384 * df3) - + (79 * z9 + 776 * z7 + 1482 * z5 - 1920 * z3 - 945 * z) / (92160 * df4); - } - /** * Return the lower bound for the baseline hazard parameters * From 2125eda0f678763be7b7bdef5276b64c1b3ebbc0 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 11 Feb 2019 12:39:57 +1100 Subject: [PATCH 116/225] jm_data_block.R: fix small typo --- R/jm_data_block.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 035aa4971..a1e88ab3c 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -1988,7 +1988,7 @@ get_Sigma_nms <- function(cnms, prefix = FALSE) { for (j in seq_along(Sigma_nms)) { Sigma_nms[[j]] <- paste0(nms[j], ":", Sigma_nms[[j]]) } - if (prefix = TRUE) { + if (prefix) { paste0("Sigma[", unlist(Sigma_nms), "]") } else { unlist(Sigma_nms) From 96901a838de517413831e1f034a52ebffb024144 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 11 Feb 2019 12:49:55 +1100 Subject: [PATCH 117/225] surv.stan: fix typo in data declaration --- NAMESPACE | 167 --------------------------------------- src/stan_files/surv.stan | 22 +++--- 2 files changed, 11 insertions(+), 178 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f3605003b..f775900ce 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,172 +1,5 @@ # Generated by roxygen2: do not edit by hand -S3method(VarCorr,stanreg) -S3method(as.array,stanreg) -S3method(as.data.frame,stanreg) -S3method(as.data.frame,summary.stanreg) -S3method(as.matrix,stanreg) -S3method(bayes_R2,stanreg) -S3method(coef,stanmvreg) -S3method(coef,stanreg) -S3method(confint,stanreg) -S3method(family,stanmvreg) -S3method(family,stanreg) -S3method(fitted,stanmvreg) -S3method(fitted,stanreg) -S3method(fixef,stanmvreg) -S3method(fixef,stanreg) -S3method(formula,stanmvreg) -S3method(formula,stanreg) -S3method(get_surv,stanjm) -S3method(get_surv,stansurv) -S3method(get_x,default) -S3method(get_x,gamm4) -S3method(get_x,lmerMod) -S3method(get_x,stanmvreg) -S3method(get_y,default) -S3method(get_y,stanmvreg) -S3method(get_z,lmerMod) -S3method(get_z,stanmvreg) -S3method(launch_shinystan,stanreg) -S3method(log_lik,stanjm) -S3method(log_lik,stanmvreg) -S3method(log_lik,stanreg) -S3method(loo,stanreg) -S3method(loo_linpred,stanreg) -S3method(loo_model_weights,stanreg_list) -S3method(loo_predict,stanreg) -S3method(loo_predictive_interval,stanreg) -S3method(model.frame,stanmvreg) -S3method(model.frame,stanreg) -S3method(model.matrix,stanreg) -S3method(names,stanreg_list) -S3method(ngrps,stanmvreg) -S3method(ngrps,stanreg) -S3method(nobs,stanreg) -S3method(pairs,stanreg) -S3method(plot,predict.stanjm) -S3method(plot,stanreg) -S3method(plot,stansurv) -S3method(plot,survfit.stanjm) -S3method(plot,survfit.stansurv) -S3method(posterior_interval,stanreg) -S3method(posterior_linpred,stanreg) -S3method(posterior_predict,stanmvreg) -S3method(posterior_predict,stanreg) -S3method(posterior_survfit,stanjm) -S3method(posterior_survfit,stansurv) -S3method(posterior_vs_prior,stanreg) -S3method(pp_check,stanreg) -S3method(predict,stanreg) -S3method(predictive_error,ppd) -S3method(predictive_error,stanreg) -S3method(predictive_interval,ppd) -S3method(predictive_interval,stanreg) -S3method(print,compare_rstanarm_loos) -S3method(print,kfold) -S3method(print,prior_summary.stanreg) -S3method(print,stanmvreg) -S3method(print,stanreg) -S3method(print,summary.stanmvreg) -S3method(print,summary.stanreg) -S3method(print,survfit.stanjm) -S3method(print,survfit.stansurv) -S3method(prior_summary,stanreg) -S3method(ranef,stanmvreg) -S3method(ranef,stanreg) -S3method(residuals,stanmvreg) -S3method(residuals,stanreg) -S3method(se,stanmvreg) -S3method(se,stanreg) -S3method(sigma,stanmvreg) -S3method(sigma,stanreg) -S3method(summary,stanmvreg) -S3method(summary,stanreg) -S3method(terms,stanmvreg) -S3method(terms,stanreg) -S3method(update,stanjm) -S3method(update,stanmvreg) -S3method(update,stanreg) -S3method(vcov,stanreg) -S3method(waic,stanreg) -export(R2) -export(Surv) -export(VarCorr) -export(bayes_R2) -export(cauchy) -export(compare_models) -export(decov) -export(dirichlet) -export(exponential) -export(fixef) -export(get_surv) -export(get_x) -export(get_y) -export(get_z) -export(hs) -export(hs_plus) -export(kfold) -export(laplace) -export(lasso) -export(launch_shinystan) -export(lkj) -export(log_lik) -export(loo) -export(loo_linpred) -export(loo_model_weights) -export(loo_predict) -export(loo_predictive_interval) -export(neg_binomial_2) -export(ngrps) -export(normal) -export(pairs_condition) -export(pairs_style_np) -export(plot_nonlinear) -export(plot_stack_jm) -export(posterior_interval) -export(posterior_linpred) -export(posterior_predict) -export(posterior_survfit) -export(posterior_traj) -export(posterior_vs_prior) -export(pp_check) -export(pp_validate) -export(predictive_error) -export(predictive_interval) -export(prior_options) -export(prior_summary) -export(product_normal) -export(ps_check) -export(ranef) -export(se) -export(sigma) -export(stan_aov) -export(stan_betareg) -export(stan_betareg.fit) -export(stan_biglm) -export(stan_biglm.fit) -export(stan_clogit) -export(stan_gamm4) -export(stan_glm) -export(stan_glm.fit) -export(stan_glm.nb) -export(stan_glmer) -export(stan_glmer.nb) -export(stan_jm) -export(stan_lm) -export(stan_lm.fit) -export(stan_lm.wfit) -export(stan_lmer) -export(stan_mvmer) -export(stan_nlmer) -export(stan_polr) -export(stan_polr.fit) -export(stan_surv) -export(stanjm_list) -export(stanmvreg_list) -export(stanreg_list) -export(student_t) -export(waic) if(getRversion()>='3.3.0') importFrom(stats, sigma) else importFrom(lme4,sigma) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 8c9ef2771..a8ac62a69 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -484,11 +484,11 @@ data { int v_icens[nnz_icens]; int v_delay[nnz_delay]; - int u_event[t>0 ? N+1 : 0]; - int u_lcens[t>0 ? N+1 : 0]; - int u_rcens[t>0 ? N+1 : 0]; - int u_icens[t>0 ? N+1 : 0]; - int u_delay[t>0 ? N+1 : 0]; + int u_event[(t > 0 && nevent > 0) ? nevent + 1 : 0]; + int u_lcens[(t > 0 && nlcens > 0) ? nlcens + 1 : 0]; + int u_rcens[(t > 0 && nrcens > 0) ? nrcens + 1 : 0]; + int u_icens[(t > 0 && nicens > 0) ? nicens + 1 : 0]; + int u_delay[(t > 0 && ndelay > 0) ? ndelay + 1 : 0]; // random effects structure, with quadrature // nnz: number of non-zero elements in the Z matrix @@ -516,12 +516,12 @@ data { int v_qpts_icens[nnz_qpts_icens]; int v_qpts_delay[nnz_qpts_delay]; - int u_epts_event[t > 0 ? N + 1 : 0]; - int u_qpts_event[t > 0 ? N + 1 : 0]; - int u_qpts_lcens[t > 0 ? N + 1 : 0]; - int u_qpts_rcens[t > 0 ? N + 1 : 0]; - int u_qpts_icens[t > 0 ? N + 1 : 0]; - int u_qpts_delay[t > 0 ? N + 1 : 0]; + int u_epts_event[(t > 0 && Nevent > 0) ? Nevent + 1 : 0]; + int u_qpts_event[(t > 0 && qevent > 0) ? qevent + 1 : 0]; + int u_qpts_lcens[(t > 0 && qlcens > 0) ? qlcens + 1 : 0]; + int u_qpts_rcens[(t > 0 && qrcens > 0) ? qrcens + 1 : 0]; + int u_qpts_icens[(t > 0 && qicens > 0) ? qicens + 1 : 0]; + int u_qpts_delay[(t > 0 && qdelay > 0) ? qdelay + 1 : 0]; // basis matrices for M-splines / I-splines, without quadrature matrix[nevent,nvars] basis_event; // at event time From a5b3c6df7e4bedab519f52b98835e384c73bbea6 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 11 Feb 2019 15:11:20 +1100 Subject: [PATCH 118/225] surv.stan: get frailty models working --- NAMESPACE | 167 ++++++++++++++++++++++++++++++++++++++++++ R/jm_data_block.R | 8 +- R/print-and-summary.R | 2 +- R/stan_surv.R | 127 ++++++++++++++++++-------------- 4 files changed, 244 insertions(+), 60 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f775900ce..f3605003b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,172 @@ # Generated by roxygen2: do not edit by hand +S3method(VarCorr,stanreg) +S3method(as.array,stanreg) +S3method(as.data.frame,stanreg) +S3method(as.data.frame,summary.stanreg) +S3method(as.matrix,stanreg) +S3method(bayes_R2,stanreg) +S3method(coef,stanmvreg) +S3method(coef,stanreg) +S3method(confint,stanreg) +S3method(family,stanmvreg) +S3method(family,stanreg) +S3method(fitted,stanmvreg) +S3method(fitted,stanreg) +S3method(fixef,stanmvreg) +S3method(fixef,stanreg) +S3method(formula,stanmvreg) +S3method(formula,stanreg) +S3method(get_surv,stanjm) +S3method(get_surv,stansurv) +S3method(get_x,default) +S3method(get_x,gamm4) +S3method(get_x,lmerMod) +S3method(get_x,stanmvreg) +S3method(get_y,default) +S3method(get_y,stanmvreg) +S3method(get_z,lmerMod) +S3method(get_z,stanmvreg) +S3method(launch_shinystan,stanreg) +S3method(log_lik,stanjm) +S3method(log_lik,stanmvreg) +S3method(log_lik,stanreg) +S3method(loo,stanreg) +S3method(loo_linpred,stanreg) +S3method(loo_model_weights,stanreg_list) +S3method(loo_predict,stanreg) +S3method(loo_predictive_interval,stanreg) +S3method(model.frame,stanmvreg) +S3method(model.frame,stanreg) +S3method(model.matrix,stanreg) +S3method(names,stanreg_list) +S3method(ngrps,stanmvreg) +S3method(ngrps,stanreg) +S3method(nobs,stanreg) +S3method(pairs,stanreg) +S3method(plot,predict.stanjm) +S3method(plot,stanreg) +S3method(plot,stansurv) +S3method(plot,survfit.stanjm) +S3method(plot,survfit.stansurv) +S3method(posterior_interval,stanreg) +S3method(posterior_linpred,stanreg) +S3method(posterior_predict,stanmvreg) +S3method(posterior_predict,stanreg) +S3method(posterior_survfit,stanjm) +S3method(posterior_survfit,stansurv) +S3method(posterior_vs_prior,stanreg) +S3method(pp_check,stanreg) +S3method(predict,stanreg) +S3method(predictive_error,ppd) +S3method(predictive_error,stanreg) +S3method(predictive_interval,ppd) +S3method(predictive_interval,stanreg) +S3method(print,compare_rstanarm_loos) +S3method(print,kfold) +S3method(print,prior_summary.stanreg) +S3method(print,stanmvreg) +S3method(print,stanreg) +S3method(print,summary.stanmvreg) +S3method(print,summary.stanreg) +S3method(print,survfit.stanjm) +S3method(print,survfit.stansurv) +S3method(prior_summary,stanreg) +S3method(ranef,stanmvreg) +S3method(ranef,stanreg) +S3method(residuals,stanmvreg) +S3method(residuals,stanreg) +S3method(se,stanmvreg) +S3method(se,stanreg) +S3method(sigma,stanmvreg) +S3method(sigma,stanreg) +S3method(summary,stanmvreg) +S3method(summary,stanreg) +S3method(terms,stanmvreg) +S3method(terms,stanreg) +S3method(update,stanjm) +S3method(update,stanmvreg) +S3method(update,stanreg) +S3method(vcov,stanreg) +S3method(waic,stanreg) +export(R2) +export(Surv) +export(VarCorr) +export(bayes_R2) +export(cauchy) +export(compare_models) +export(decov) +export(dirichlet) +export(exponential) +export(fixef) +export(get_surv) +export(get_x) +export(get_y) +export(get_z) +export(hs) +export(hs_plus) +export(kfold) +export(laplace) +export(lasso) +export(launch_shinystan) +export(lkj) +export(log_lik) +export(loo) +export(loo_linpred) +export(loo_model_weights) +export(loo_predict) +export(loo_predictive_interval) +export(neg_binomial_2) +export(ngrps) +export(normal) +export(pairs_condition) +export(pairs_style_np) +export(plot_nonlinear) +export(plot_stack_jm) +export(posterior_interval) +export(posterior_linpred) +export(posterior_predict) +export(posterior_survfit) +export(posterior_traj) +export(posterior_vs_prior) +export(pp_check) +export(pp_validate) +export(predictive_error) +export(predictive_interval) +export(prior_options) +export(prior_summary) +export(product_normal) +export(ps_check) +export(ranef) +export(se) +export(sigma) +export(stan_aov) +export(stan_betareg) +export(stan_betareg.fit) +export(stan_biglm) +export(stan_biglm.fit) +export(stan_clogit) +export(stan_gamm4) +export(stan_glm) +export(stan_glm.fit) +export(stan_glm.nb) +export(stan_glmer) +export(stan_glmer.nb) +export(stan_jm) +export(stan_lm) +export(stan_lm.fit) +export(stan_lm.wfit) +export(stan_lmer) +export(stan_mvmer) +export(stan_nlmer) +export(stan_polr) +export(stan_polr.fit) +export(stan_surv) +export(stanjm_list) +export(stanmvreg_list) +export(stanreg_list) +export(student_t) +export(waic) if(getRversion()>='3.3.0') importFrom(stats, sigma) else importFrom(lme4,sigma) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index a1e88ab3c..04d7863bd 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -1979,7 +1979,7 @@ evaluate_Sigma <- function(stanfit, cnms) { # @param cnms The component names for the group level terms, combined # across all glmer submodels # @return A character vector -get_Sigma_nms <- function(cnms, prefix = FALSE) { +get_Sigma_nms <- function(cnms) { nms <- names(cnms) Sigma_nms <- lapply(cnms, FUN = function(grp) { nm <- outer(grp, grp, FUN = paste, sep = ",") @@ -1988,11 +1988,7 @@ get_Sigma_nms <- function(cnms, prefix = FALSE) { for (j in seq_along(Sigma_nms)) { Sigma_nms[[j]] <- paste0(nms[j], ":", Sigma_nms[[j]]) } - if (prefix) { - paste0("Sigma[", unlist(Sigma_nms), "]") - } else { - unlist(Sigma_nms) - } + unlist(Sigma_nms) } diff --git a/R/print-and-summary.R b/R/print-and-summary.R index 58f9860e6..534d866fc 100644 --- a/R/print-and-summary.R +++ b/R/print-and-summary.R @@ -99,7 +99,7 @@ print.stanreg <- function(x, digits = 1, ...) { cat("\n------\n") - mer <- is.mer(x) + mer <- is.mer(x) || (surv && x$has_bars) gamm <- isTRUE(x$stan_function == "stan_gamm4") ord <- is_polr(x) && !("(Intercept)" %in% rownames(x$stan_summary)) diff --git a/R/stan_surv.R b/R/stan_surv.R index 5bef92bd4..41b2f4030 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -778,29 +778,29 @@ stan_surv <- function(formula, x_icens = if (has_quadrature) matrix(0,0,K) else x_icens, x_delay = if (has_quadrature) matrix(0,0,K) else x_delay, - w_event = if (has_quadrature || nevent == 0) double(0) else parts_event$w, - w_lcens = if (has_quadrature || nlcens == 0) double(0) else parts_lcens$w, - w_rcens = if (has_quadrature || nrcens == 0) double(0) else parts_rcens$w, - w_icens = if (has_quadrature || nicens == 0) double(0) else parts_icens$w, - w_delay = if (has_quadrature || ndelay == 0) double(0) else parts_delay$w, + w_event = if (has_quadrature || !has_bars || nevent == 0) double(0) else parts_event$w, + w_lcens = if (has_quadrature || !has_bars || nlcens == 0) double(0) else parts_lcens$w, + w_rcens = if (has_quadrature || !has_bars || nrcens == 0) double(0) else parts_rcens$w, + w_icens = if (has_quadrature || !has_bars || nicens == 0) double(0) else parts_icens$w, + w_delay = if (has_quadrature || !has_bars || ndelay == 0) double(0) else parts_delay$w, - v_event = if (has_quadrature || nevent == 0) integer(0) else parts_event$v - 1L, - v_lcens = if (has_quadrature || nlcens == 0) integer(0) else parts_lcens$v - 1L, - v_rcens = if (has_quadrature || nrcens == 0) integer(0) else parts_rcens$v - 1L, - v_icens = if (has_quadrature || nicens == 0) integer(0) else parts_icens$v - 1L, - v_delay = if (has_quadrature || ndelay == 0) integer(0) else parts_delay$v - 1L, - - u_event = if (has_quadrature || nevent == 0) integer(0) else parts_event$u - 1L, - u_lcens = if (has_quadrature || nlcens == 0) integer(0) else parts_lcens$u - 1L, - u_rcens = if (has_quadrature || nrcens == 0) integer(0) else parts_rcens$u - 1L, - u_icens = if (has_quadrature || nicens == 0) integer(0) else parts_icens$u - 1L, - u_delay = if (has_quadrature || ndelay == 0) integer(0) else parts_delay$u - 1L, - - nnz_event = if (has_quadrature || nevent == 0) 0L else length(parts_event$w), - nnz_lcens = if (has_quadrature || nlcens == 0) 0L else length(parts_lcens$w), - nnz_rcens = if (has_quadrature || nrcens == 0) 0L else length(parts_rcens$w), - nnz_icens = if (has_quadrature || nicens == 0) 0L else length(parts_icens$w), - nnz_delay = if (has_quadrature || ndelay == 0) 0L else length(parts_delay$w), + v_event = if (has_quadrature || !has_bars || nevent == 0) integer(0) else parts_event$v - 1L, + v_lcens = if (has_quadrature || !has_bars || nlcens == 0) integer(0) else parts_lcens$v - 1L, + v_rcens = if (has_quadrature || !has_bars || nrcens == 0) integer(0) else parts_rcens$v - 1L, + v_icens = if (has_quadrature || !has_bars || nicens == 0) integer(0) else parts_icens$v - 1L, + v_delay = if (has_quadrature || !has_bars || ndelay == 0) integer(0) else parts_delay$v - 1L, + + u_event = if (has_quadrature || !has_bars || nevent == 0) integer(0) else parts_event$u - 1L, + u_lcens = if (has_quadrature || !has_bars || nlcens == 0) integer(0) else parts_lcens$u - 1L, + u_rcens = if (has_quadrature || !has_bars || nrcens == 0) integer(0) else parts_rcens$u - 1L, + u_icens = if (has_quadrature || !has_bars || nicens == 0) integer(0) else parts_icens$u - 1L, + u_delay = if (has_quadrature || !has_bars || ndelay == 0) integer(0) else parts_delay$u - 1L, + + nnz_event = if (has_quadrature || !has_bars || nevent == 0) 0L else length(parts_event$w), + nnz_lcens = if (has_quadrature || !has_bars || nlcens == 0) 0L else length(parts_lcens$w), + nnz_rcens = if (has_quadrature || !has_bars || nrcens == 0) 0L else length(parts_rcens$w), + nnz_icens = if (has_quadrature || !has_bars || nicens == 0) 0L else length(parts_icens$w), + nnz_delay = if (has_quadrature || !has_bars || ndelay == 0) 0L else length(parts_delay$w), basis_event = if (has_quadrature) matrix(0,0,nvars) else basis_event, ibasis_event = if (has_quadrature) matrix(0,0,nvars) else ibasis_event, @@ -854,33 +854,33 @@ stan_surv <- function(formula, s_qpts_icenu = if (!has_quadrature) matrix(0,0,S) else s_qpts_icenu, s_qpts_delay = if (!has_quadrature) matrix(0,0,S) else s_qpts_delay, - w_epts_event = if (!has_quadrature || qevent == 0) double(0) else parts_epts_event$w, - w_qpts_event = if (!has_quadrature || qevent == 0) double(0) else parts_qpts_event$w, - w_qpts_lcens = if (!has_quadrature || qlcens == 0) double(0) else parts_qpts_lcens$w, - w_qpts_rcens = if (!has_quadrature || qrcens == 0) double(0) else parts_qpts_rcens$w, - w_qpts_icens = if (!has_quadrature || qicens == 0) double(0) else parts_qpts_icens$w, - w_qpts_delay = if (!has_quadrature || qdelay == 0) double(0) else parts_qpts_delay$w, - - v_epts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_epts_event$v - 1L, - v_qpts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_qpts_event$v - 1L, - v_qpts_lcens = if (!has_quadrature || qlcens == 0) integer(0) else parts_qpts_lcens$v - 1L, - v_qpts_rcens = if (!has_quadrature || qrcens == 0) integer(0) else parts_qpts_rcens$v - 1L, - v_qpts_icens = if (!has_quadrature || qicens == 0) integer(0) else parts_qpts_icens$v - 1L, - v_qpts_delay = if (!has_quadrature || qdelay == 0) integer(0) else parts_qpts_delay$v - 1L, - - u_epts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_epts_event$u - 1L, - u_qpts_event = if (!has_quadrature || qevent == 0) integer(0) else parts_qpts_event$u - 1L, - u_qpts_lcens = if (!has_quadrature || qlcens == 0) integer(0) else parts_qpts_lcens$u - 1L, - u_qpts_rcens = if (!has_quadrature || qrcens == 0) integer(0) else parts_qpts_rcens$u - 1L, - u_qpts_icens = if (!has_quadrature || qicens == 0) integer(0) else parts_qpts_icens$u - 1L, - u_qpts_delay = if (!has_quadrature || qdelay == 0) integer(0) else parts_qpts_delay$u - 1L, - - nnz_epts_event = if (!has_quadrature || qevent == 0) 0L else length(parts_epts_event$w), - nnz_qpts_event = if (!has_quadrature || qevent == 0) 0L else length(parts_qpts_event$w), - nnz_qpts_lcens = if (!has_quadrature || qlcens == 0) 0L else length(parts_qpts_lcens$w), - nnz_qpts_rcens = if (!has_quadrature || qrcens == 0) 0L else length(parts_qpts_rcens$w), - nnz_qpts_icens = if (!has_quadrature || qicens == 0) 0L else length(parts_qpts_icens$w), - nnz_qpts_delay = if (!has_quadrature || qdelay == 0) 0L else length(parts_qpts_delay$w), + w_epts_event = if (!has_quadrature || !has_bars || qevent == 0) double(0) else parts_epts_event$w, + w_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) double(0) else parts_qpts_event$w, + w_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) double(0) else parts_qpts_lcens$w, + w_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) double(0) else parts_qpts_rcens$w, + w_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) double(0) else parts_qpts_icens$w, + w_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) double(0) else parts_qpts_delay$w, + + v_epts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_epts_event$v - 1L, + v_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_qpts_event$v - 1L, + v_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) integer(0) else parts_qpts_lcens$v - 1L, + v_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) integer(0) else parts_qpts_rcens$v - 1L, + v_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) integer(0) else parts_qpts_icens$v - 1L, + v_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) integer(0) else parts_qpts_delay$v - 1L, + + u_epts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_epts_event$u - 1L, + u_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_qpts_event$u - 1L, + u_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) integer(0) else parts_qpts_lcens$u - 1L, + u_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) integer(0) else parts_qpts_rcens$u - 1L, + u_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) integer(0) else parts_qpts_icens$u - 1L, + u_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) integer(0) else parts_qpts_delay$u - 1L, + + nnz_epts_event = if (!has_quadrature || !has_bars || qevent == 0) 0L else length(parts_epts_event$w), + nnz_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) 0L else length(parts_qpts_event$w), + nnz_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) 0L else length(parts_qpts_lcens$w), + nnz_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) 0L else length(parts_qpts_rcens$w), + nnz_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) 0L else length(parts_qpts_icens$w), + nnz_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) 0L else length(parts_qpts_delay$w), basis_epts_event = if (!has_quadrature) matrix(0,0,nvars) else basis_epts_event, basis_qpts_event = if (!has_quadrature) matrix(0,0,nvars) else basis_qpts_event, @@ -902,7 +902,7 @@ stan_surv <- function(formula, standata$p <- as.array(p) # num ranefs for each grouping factor standata$l <- as.array(l) # num levels for each grouping factor standata$t <- t # num of grouping factors - standata$q <- ncol(group$z) # p * l + standata$q <- ncol(group$Z) # p * l standata$special_case <- all(sapply(group$cnms, intercept_only)) } else { # no random effects structure @@ -1104,15 +1104,15 @@ stan_surv <- function(formula, nms_smooth <- get_smooth_name(s_cpts, type = "smooth_sd") # may be NULL nms_int <- get_int_name_basehaz(basehaz) nms_aux <- get_aux_name_basehaz(basehaz) - nms_b <- if (standata$t) make_b_nms(group) else NULL - nms_sigma <- if (standata$t) get_Sigma_nms(group$cnms, wrap = TRUE) else NULL + nms_b <- get_b_names(group) # may be NULL + nms_vc <- get_varcov_names(group) # may be NULL nms_all <- c(nms_int, nms_beta, nms_tde, nms_smooth, nms_aux, nms_b, - nms_sigma, + nms_vc, "log-posterior") # substitute new parameter names into 'stanfit' object @@ -1123,6 +1123,7 @@ stan_surv <- function(formula, formula, has_tde, has_quadrature, + has_bars, data, model_frame = mf, terms = mt, @@ -1369,6 +1370,26 @@ get_smooth_name <- function(x, type = "smooth_coefs") { stop2("Bug found: invalid input to 'type' argument.")) } +# Return the names for the group-specific parameters +# +# @param group List returned by rstanarm:::pad_reTerms. +# @return A character vector. +get_b_names <- function(group) { + if (is.null(group)) + return(NULL) # no random effects structure + c(paste0("b[", make_b_nms(group), "]")) +} + +# Return the names for the var-cov parameters +# +# @param group List returned by rstanarm:::pad_reTerms. +# @return A character vector. +get_varcov_names <- function(group) { + if (is.null(group)) + return(NULL) # no random effects structure + paste0("Sigma[", get_Sigma_nms(group$cnms), "]") +} + # Return the default scale parameter for 'prior_aux'. # # @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. From 0819216ecb0b9df9347698a4492a6060c66a1205 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 11 Feb 2019 15:30:55 +1100 Subject: [PATCH 119/225] stansurv.R: add some missing elements to returned model object --- R/stan_surv.R | 7 +++++-- R/stanreg-methods.R | 6 ++++++ R/stansurv.R | 5 +++++ 3 files changed, 16 insertions(+), 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 41b2f4030..c21499d7e 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1129,8 +1129,11 @@ stan_surv <- function(formula, terms = mt, xlevels = .getXlevels(mt, mf), x, - x_cpts = if (has_tde) x_cpts else NULL, - s_cpts = if (has_tde) s_cpts else NULL, + x_cpts = if (has_tde) x_cpts else NULL, + s_cpts = if (has_tde) s_cpts else NULL, + z_cpts = if (has_bars) z_cpts else NULL, + cnms = if (has_bars) group$cnms else NULL, + flist = if (has_bars) group$flist else NULL, t_beg, t_end, status, diff --git a/R/stanreg-methods.R b/R/stanreg-methods.R index 277e98082..2dca4ed87 100644 --- a/R/stanreg-methods.R +++ b/R/stanreg-methods.R @@ -413,11 +413,17 @@ terms.stanreg <- function(x, ..., fixed.only = TRUE, random.only = FALSE) { .glmer_check(object) object$glmod$reTrms$cnms } +.cnms.stansurv <- function(object, ...) { + object$cnms +} .flist <- function(object, ...) UseMethod(".flist") .flist.stanreg <- function(object, ...) { .glmer_check(object) as.list(object$glmod$reTrms$flist) } +.flist.stansurv <- function(object, ...) { + as.list(object$flist) +} coef_mer <- function(object, ...) { if (length(list(...))) diff --git a/R/stansurv.R b/R/stansurv.R index f5a5569df..9eaab6d81 100644 --- a/R/stansurv.R +++ b/R/stansurv.R @@ -63,11 +63,16 @@ stansurv <- function(object) { formula = object$formula, has_tde = object$has_tde, has_quadrature= object$has_quadrature, + has_bars = object$has_bars, terms = object$terms, data = object$data, model_frame = object$model_frame, x = object$x, + x_cpts = object$x_cpts, s_cpts = object$s_cpts, + z_cpts = object$z_cpts, + cnms = object$cnms, + flist = object$flist, entrytime = object$t_beg, eventtime = object$t_end, event = object$event, From b735546d5172447995e1a0bbec1de2718feb02ee Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 11 Feb 2019 17:10:57 +1100 Subject: [PATCH 120/225] Fix bug in handle_cov_prior --- R/jm_data_block.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 04d7863bd..1a22afec6 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -171,7 +171,7 @@ reformulate_rhs <- function(x, subbars = FALSE) { handle_cov_prior <- function(prior, cnms, ok_dists = nlist("decov", "lkj")) { if (!is.list(prior)) stop(sQuote(deparse(substitute(prior))), " should be a named list") - t <- length(unique(cnms)) # num grouping factors + t <- length(cnms) # num grouping factors p <- sapply(cnms, length) # num terms for each grouping factor prior_dist_name <- prior$dist if (!prior_dist_name %in% unlist(ok_dists)) { From 5cd7150293a01b248bfb6ca9d8297cd33d2b2256 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 12 Feb 2019 17:00:36 +1100 Subject: [PATCH 121/225] stan_surv.R: fix reported number of levels for grouping factors --- R/stan_surv.R | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index c21499d7e..0730cc380 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -697,10 +697,10 @@ stan_surv <- function(formula, # use 'stan_glmer' approach if (has_bars) { - group <- lme4::mkReTrms(formula$bars, mf_cpts) - group <- pad_reTrms(Ztlist = group$Ztlist, - cnms = group$cnms, - flist = group$flist) + group_unpadded <- lme4::mkReTrms(formula$bars, mf_cpts) + group <- pad_reTrms(Ztlist = group_unpadded$Ztlist, + cnms = group_unpadded$cnms, + flist = group_unpadded$flist) z_cpts <- group$Z } else { @@ -1098,6 +1098,10 @@ stan_surv <- function(formula, } check_stanfit(stanfit) + # replace 'theta_L' with the variance-covariance matrix + if (has_bars) + stanfit <- evaluate_Sigma(stanfit, group$cnms) + # define new parameter names nms_beta <- colnames(x) # may be NULL nms_tde <- get_smooth_name(s_cpts, type = "smooth_coefs") # may be NULL @@ -1132,8 +1136,8 @@ stan_surv <- function(formula, x_cpts = if (has_tde) x_cpts else NULL, s_cpts = if (has_tde) s_cpts else NULL, z_cpts = if (has_bars) z_cpts else NULL, - cnms = if (has_bars) group$cnms else NULL, - flist = if (has_bars) group$flist else NULL, + cnms = if (has_bars) group_unpadded$cnms else NULL, + flist = if (has_bars) group_unpadded$flist else NULL, t_beg, t_end, status, From f2e986c28deeb33c2c0b78e1ff8678dbcf829dcc Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 19 Feb 2019 17:12:39 +1100 Subject: [PATCH 122/225] stan_surv.R: fix stuff related to merging in dirichlet prior --- R/stan_surv.R | 18 +++++++++++------- src/stan_files/surv.stan | 26 +++++++++++++------------- 2 files changed, 24 insertions(+), 20 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 098a76dbe..aa7431f2b 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -774,7 +774,7 @@ stan_surv <- function(formula, standata <- nlist( K, S, nvars, - x_bar, + x_bar = x_stuff$x_bar, has_intercept, has_quadrature, smooth_map, @@ -1251,6 +1251,7 @@ handle_basehaz_surv <- function(basehaz, if (any(knots > max_t)) stop2("'knots' cannot be placed beyond the latest event time.") } + } if (basehaz %in% c("exp", "exp-aft")) { @@ -1418,12 +1419,14 @@ get_smooth_name <- function(x, type = "smooth_coefs") { get_ok_priors_for_aux <- function(basehaz) { nm <- get_basehaz_name(basehaz) switch(nm, - exp = nlist(), - weibull = nlist("normal", student_t = "t", "cauchy", "exponential"), - gompertz = nlist("normal", student_t = "t", "cauchy", "exponential"), - ms = nlist("dirichlet"), - bs = nlist("normal", student_t = "t", "cauchy"), - piecewise = nlist("normal", student_t = "t", "cauchy"), + exp = nlist(), + exp-aft = nlist(), + weibull = nlist("normal", student_t = "t", "cauchy", "exponential"), + weibull-aft = nlist("normal", student_t = "t", "cauchy", "exponential"), + gompertz = nlist("normal", student_t = "t", "cauchy", "exponential"), + ms = nlist("dirichlet"), + bs = nlist("normal", student_t = "t", "cauchy"), + piecewise = nlist("normal", student_t = "t", "cauchy"), stop2("Bug found: unknown type of baseline hazard.")) } @@ -1441,6 +1444,7 @@ get_default_prior_for_aux <- function(basehaz) { bs = normal(), piecewise = normal(), stop2("Bug found: unknown type of baseline hazard.")) +} # Return the names for the group-specific parameters # diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index b95643715..7e92f5e61 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -916,12 +916,12 @@ model { if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); } else if (type == 4) { // M-splines, on haz scale - if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, coefs); - if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, coefs); - if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, coefs); - if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, coefs); - if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, coefs); - if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, coefs); + if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, ms_coefs[1]); + if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, ms_coefs[1]); + if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, ms_coefs[1]); + if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, ms_coefs[1]); + if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, ms_coefs[1]); + if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, ms_coefs[1]); } else { reject("Bug found: invalid baseline hazard (without quadrature)."); @@ -1108,13 +1108,13 @@ model { if (qdelay > 0) lhaz_qpts_delay = gompertz_log_haz(eta_qpts_delay, qpts_delay, scale); } else if (type == 4) { // M-splines, on haz scale - if (Nevent > 0) lhaz_epts_event = mspline_log_haz(eta_epts_event, basis_epts_event, coefs); - if (qevent > 0) lhaz_qpts_event = mspline_log_haz(eta_qpts_event, basis_qpts_event, coefs); - if (qlcens > 0) lhaz_qpts_lcens = mspline_log_haz(eta_qpts_lcens, basis_qpts_lcens, coefs); - if (qrcens > 0) lhaz_qpts_rcens = mspline_log_haz(eta_qpts_rcens, basis_qpts_rcens, coefs); - if (qicens > 0) lhaz_qpts_icenl = mspline_log_haz(eta_qpts_icenl, basis_qpts_icenl, coefs); - if (qicens > 0) lhaz_qpts_icenu = mspline_log_haz(eta_qpts_icenu, basis_qpts_icenu, coefs); - if (qdelay > 0) lhaz_qpts_delay = mspline_log_haz(eta_qpts_delay, basis_qpts_delay, coefs); + if (Nevent > 0) lhaz_epts_event = mspline_log_haz(eta_epts_event, basis_epts_event, ms_coefs[1]); + if (qevent > 0) lhaz_qpts_event = mspline_log_haz(eta_qpts_event, basis_qpts_event, ms_coefs[1]); + if (qlcens > 0) lhaz_qpts_lcens = mspline_log_haz(eta_qpts_lcens, basis_qpts_lcens, ms_coefs[1]); + if (qrcens > 0) lhaz_qpts_rcens = mspline_log_haz(eta_qpts_rcens, basis_qpts_rcens, ms_coefs[1]); + if (qicens > 0) lhaz_qpts_icenl = mspline_log_haz(eta_qpts_icenl, basis_qpts_icenl, ms_coefs[1]); + if (qicens > 0) lhaz_qpts_icenu = mspline_log_haz(eta_qpts_icenu, basis_qpts_icenu, ms_coefs[1]); + if (qdelay > 0) lhaz_qpts_delay = mspline_log_haz(eta_qpts_delay, basis_qpts_delay, ms_coefs[1]); } else if (type == 2) { // B-splines, on log haz scale if (Nevent > 0) lhaz_epts_event = bspline_log_haz(eta_epts_event, basis_epts_event, coefs); From 80d788c75c96f5c2d8b083e3776c45b1e893470f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 19 Feb 2019 17:13:36 +1100 Subject: [PATCH 123/225] stan_surv.R: add quotes to a switch call --- R/stan_surv.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index aa7431f2b..a8d8fbaa6 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1419,14 +1419,14 @@ get_smooth_name <- function(x, type = "smooth_coefs") { get_ok_priors_for_aux <- function(basehaz) { nm <- get_basehaz_name(basehaz) switch(nm, - exp = nlist(), - exp-aft = nlist(), - weibull = nlist("normal", student_t = "t", "cauchy", "exponential"), - weibull-aft = nlist("normal", student_t = "t", "cauchy", "exponential"), - gompertz = nlist("normal", student_t = "t", "cauchy", "exponential"), - ms = nlist("dirichlet"), - bs = nlist("normal", student_t = "t", "cauchy"), - piecewise = nlist("normal", student_t = "t", "cauchy"), + "exp" = nlist(), + "exp-aft" = nlist(), + "weibull" = nlist("normal", student_t = "t", "cauchy", "exponential"), + "weibull-aft" = nlist("normal", student_t = "t", "cauchy", "exponential"), + "gompertz" = nlist("normal", student_t = "t", "cauchy", "exponential"), + "ms" = nlist("dirichlet"), + "bs" = nlist("normal", student_t = "t", "cauchy"), + "piecewise" = nlist("normal", student_t = "t", "cauchy"), stop2("Bug found: unknown type of baseline hazard.")) } From fe663427bf1882e5e9924cca15d41352cc050703 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 19 Feb 2019 17:16:49 +1100 Subject: [PATCH 124/225] stan_surv.R: add default prior_aux for AFT models --- R/stan_surv.R | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index a8d8fbaa6..7c6f36c96 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1437,12 +1437,14 @@ get_ok_priors_for_aux <- function(basehaz) { get_default_prior_for_aux <- function(basehaz) { nm <- get_basehaz_name(basehaz) switch(nm, - exp = NULL, - weibull = normal(), - gompertz = normal(), - ms = dirichlet(), - bs = normal(), - piecewise = normal(), + "exp" = NULL, + "exp-aft" = NULL, + "weibull" = normal(), + "weibull-aft" = normal(), + "gompertz" = normal(), + "ms" = dirichlet(), + "bs" = normal(), + "piecewise" = normal(), stop2("Bug found: unknown type of baseline hazard.")) } From 499b489483e45c9d035df1dfd75f777a95d94b27 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 20 Feb 2019 15:29:13 +1100 Subject: [PATCH 125/225] stan_surv.R: fix intercept shift for AFT models --- R/stan_surv.R | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 7c6f36c96..50cba769b 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -469,11 +469,12 @@ stan_surv <- function(formula, t_icenu <- t_upp[status == 3] # upper limit of interval censoring time t_delay <- t_beg[delayed] # delayed entry time - # calculate log(crude event rate) and -log(mean event time) + # calculate log crude event rate t_tmp <- sum(rowMeans(cbind(t_end, t_upp), na.rm = TRUE) - t_beg) d_tmp <- sum(!status == 0) - log_crude_event_rate = log(d_tmp / t_tmp) - log_crude_event_time = log(t_tmp / d_tmp) + log_crude_event_rate <- log(d_tmp / t_tmp) + if (is.infinite(log_crude_event_rate)) + log_crude_event_rate <- 0 # avoids error when there are zero events # dimensions nevent <- sum(status == 1) @@ -501,8 +502,11 @@ stan_surv <- function(formula, nvars <- basehaz$nvars # number of basehaz aux parameters # flag if intercept is required for baseline hazard - has_intercept <- ai(has_intercept(basehaz)) + has_intercept <- ai(has_intercept(basehaz)) + # flag if AFT specification + is_aft <- get_basehaz_name(basehaz) %in% c("exp-aft", "weibull-aft") + #----- define dimensions and times for quadrature # flag if formula uses time-dependent effects @@ -780,9 +784,9 @@ stan_surv <- function(formula, smooth_map, smooth_idx, type = basehaz$type, - log_crude_event_rate, - log_crude_event_time, - + log_crude_event_rate = + ifelse(is_aft, -log_crude_event_rate, log_crude_event_rate), + nevent = if (has_quadrature) 0L else nevent, nlcens = if (has_quadrature) 0L else nlcens, nrcens = if (has_quadrature) 0L else nrcens, @@ -1067,7 +1071,7 @@ stan_surv <- function(formula, # any additional flags standata$prior_PD <- ai(prior_PD) - + #--------------- # Prior summary #--------------- From 4a9255371256cf9a652b0f708f58b8be1083b18f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 20 Feb 2019 15:29:38 +1100 Subject: [PATCH 126/225] prior_summary: fix auxiliary paramters for AFT survival models --- R/jm_data_block.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 034abd5c7..801492009 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -529,11 +529,12 @@ summarize_jm_prior <- .rename_e_aux <- function(basehaz) { nm <- basehaz$type_name switch(nm, - weibull = "weibull-shape", - gompertz = "gompertz-scale", - bs = "B-spline-coefficients", - ms = "M-spline-coefficients", - piecewise = "piecewise-coefficients", + "weibull" = "weibull-shape", + "weibull-aft" = "weibull-shape", + "gompertz" = "gompertz-scale", + "bs" = "B-spline-coefficients", + "ms" = "M-spline-coefficients", + "piecewise" = "piecewise-coefficients", NA) } From 130e6e794083d731f69bc3e0a7983bfe27996008 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 28 Feb 2019 16:53:03 +1100 Subject: [PATCH 127/225] Add an example dataset for frailty models --- R/doc-datasets.R | 22 +++++++++++++++++++++- data/frail.rda | Bin 0 -> 2234 bytes 2 files changed, 21 insertions(+), 1 deletion(-) create mode 100644 data/frail.rda diff --git a/R/doc-datasets.R b/R/doc-datasets.R index 2be6aac9e..599dc177a 100644 --- a/R/doc-datasets.R +++ b/R/doc-datasets.R @@ -20,7 +20,7 @@ #' Small datasets for use in \pkg{rstanarm} examples and vignettes. #' #' @name rstanarm-datasets -#' @aliases bball1970 bball2006 bcancer kidiq mice mortality pbcLong pbcSurv tumors radon roaches wells +#' @aliases bball1970 bball2006 bcancer frail kidiq mice mortality pbcLong pbcSurv tumors radon roaches wells #' @format #' \describe{ #' \item{\code{bball1970}}{ @@ -66,6 +66,26 @@ #' by Sauerbrei and Royston (1999) (\code{Good}, \code{Medium}, \code{Poor}) #' } #' } +#' \item{\code{frail}}{ +#' A simulated dataset of event times (i.e. survival data) for 200 patients +#' clustered within 20 hospital sites (10 patients per hospital site). +#' The event times are simulated from a parametric proportional hazards model +#' under the following assumptions: (i) a constant (i.e. exponential) baseline +#' hazard rate of 0.1; (ii) a fixed treatment effect with log hazard ratio of +#' 0.3; and (iii) a site-specific random intercept (specified on the log +#' hazard scale) drawn from a \eqn{N(0,1)} distribution. +#' +#' 200 obs. of 6 variables +#' \itemize{ +#' \item \code{id} ID unique to each patient +#' \item \code{site} ID unique to each hospital site (i.e. cluster) +#' \item \code{trt} Treatment indicator (0 = untreated, 1 = treated) +#' \item \code{b} Cluster-specific random intercept used to simulate the +#' event times +#' \item \code{eventtime} Event or censoring time +#' \item \code{status} Event indicator (0 = right censored, 1 = event) +#' } +#' } #' \item{\code{kidiq}}{ #' Data from a survey of adult American women and their children #' (a subsample from the National Longitudinal Survey of Youth). diff --git a/data/frail.rda b/data/frail.rda new file mode 100644 index 0000000000000000000000000000000000000000..3563ff9bcd491189d20e810ddca0f0950b98cd23 GIT binary patch literal 2234 zcmV;r2u1fFiwFP!000002Cdl(JXP5q2k^u3eutzQd4y0z4~*1W(*x0qUMebyQc5{T z%A@3XU1f5UrkXSwOkJsj6x9elRC>9ICZ%E$=^>;-?(f`?>ovPOXMaB5^WS@&wf^gG z?X%CZ&vBUQI7Z4*ip63Hv)H0SEMYcwMTGGn#1dgiB8s|uyLfoASZpO6h=D8={I>&t z5T4+V;CF0)UK}KVKbW6b8f4nX$$>m5zyMGLeqLo52r4iLRADd-fuZmnsKGE$2My2! zEf@~kpaZ%v0`x#13}7UT0z)u@(O?WFFb2lLI2aG6UxQvtTyN0ef(OxiAmr!va_cj<5(8!xC@;XIKi$U^%$J3UGy$ z;0Ern3RZ&$tbw(F^T%2T>%j{)z(()}4sgK-Hi0i}hArR+{ty6xuobpJ5NwBF;6Vt4 zLKuWY1pEUcVF&DlDEJX}K{Wgmc0&y8fmqlJKfylO4+r39I0$iY2!4ThI1Il+0wh8b z{02whDEteO;TWXAaX0}dAr($R8l*!8oQ6y|17{%%vf&(@hYRpK!a&+!h|qGY=%S_5@kq?A#sKz7?Na2iXmx+WEhfVNRAp$CN(?D8 z)N!5gHzC&7t?Pc*w(jk{_3PTVtNwBcb&I{_@9+BUtq;?@eYJgS{eM+!UwyxI>-snK zmxpQn{jC|3bJSao-sb6R?6=h2Ti*WiGda)w5Lm2lwAEI|?k8^KN+N@SX}Pl4oIubgOLl3MyWd44$9qshusTNFINr zM?Ef83M%HjPrdKEBx|FfB56!=+w#ojfxu$nDp5^$_E|y2oC=?r#VNI01r(=tf?l!?L9 zMJlL#MPYpLbw6tK6ui+{;k4Jja<^0ZlEu@rjcaDgx?ukK9}mM*nA!zvxBN^yKp=;Z%Ahz z#X9|py45_YqJD9$e)&MES##y{lGg{Q;w3|;gKp(i+IURm_UszcoU+%!VEiNU!NaOV z?@AFVo-@PQYuqAIB{ADR<9R3*Z`}BDSIA5{tTOi%Hzkd{oa`lHE3%Y|E#g?2hon)Z zgtR6z(>-(`3D|e*^mwX!JFUu;w~(sH*(@3xlrDezj9pnbs&GNPt3ilGM_5w#fY4nrbcdls;ikiNRKLAwhXp*RwA`O+iH(= zcA*;6ZtM>=ile&gG~-Lc9q5p#Qx6@&bLfbd_k4_O_fsLc!DFI}4^oBvW+~^^43cji zF7e>vkEGl%HQhgWB2|=4WXlf=q%xe-RmFNO{O?lMZuZy(HeRGsvgF^l!b&=ySE9nTWBnp} zjMIMp@Z;)c4bnC-S8Q>e43*b^rBc?CN)=2LwEZ7XrG}yUXI9l)_ZZhb>UfCP+6|c1 zd2AS9eo$|}6KQHn(o7zlN9E=oJ>_rbN_E1XIMr;dBK2$EZgKG2(YfC5t6Ocox9~`9 zzy^1hnx$0jl;!bIrOTut_58Ix4GH9Va;CPASMXof!7!3{+jhrB$z;&M3Y^8GjVa-m)yJm!LGc(j|wGd|LJL* zPOkElOC<|+Nz*ms7I*GRQm6lzryll{vRzgfJAHUcm4kf7aZ4kpM)Kk$YuOFd;E#$8 z{u-q{>Xx=IOAna6yhr<}goN|Q$WCey<*-KFH<-$vEV@)ub)9ONp3sWc%J0#C*qe_5 zoZ|*m^NnS*^dv%c?%Kb;*m)Mm^_EnQO<} zv!?S{_xn#}^LWdtetO89NSk|9{8h8Y=C&*NZ+*Od0acIBk6QS$n0!|G^Z9P}C)T%rzt!J;TwnKsOzvrWyLS|X?zx!O@c+!y z+gwcV%-|bi=?-guTjTL{L550 z2oG&-ZRXv}arJcJbd=N4D7Dgs>tf{Yjq%;Oi*VfB_`fvp|AQ2wzle0K)Mvi`04@@q I9!eSj0FBmhCjbBd literal 0 HcmV?d00001 From 1a8569de9fa5ff72bdb2420636a5eaefc804c0f8 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 28 Feb 2019 17:31:05 +1100 Subject: [PATCH 128/225] Start adding some tests for frailty models --- tests/testthat/test_stan_surv.R | 689 ++++++++++++++++++++++---------- 1 file changed, 477 insertions(+), 212 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 8ad313e73..e09f80725 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -51,6 +51,8 @@ ew <- function(...) { expect_warning(...) } es <- function(...) { expect_stanreg(...) } up <- function(...) { update(...) } +run_sims <- FALSE # if TRUE then long running simulations are run + #----------------------------- Models ----------------------------------- #--- Time fixed covariates, time fixed coefficients @@ -109,7 +111,7 @@ test_that("qnodes argument works", { }) test_that("basehaz argument works", { - + es(up(testmod, basehaz = "exp")) es(up(testmod, basehaz = "weibull")) es(up(testmod, basehaz = "gompertz")) @@ -124,13 +126,13 @@ test_that("basehaz argument works", { es(up(testmod, basehaz = "ms", basehaz_ops = knl)) es(up(testmod, basehaz = "bs", basehaz_ops = dfl)) es(up(testmod, basehaz = "bs", basehaz_ops = knl)) - + ee(up(testmod, basehaz_ops = list(junk = 3)), "can only include") - + ee(up(testmod, basehaz_ops = list(df = 1)), "cannot be negative") ee(up(testmod, basehaz_ops = list(knots = -1)), "earliest entry time") ee(up(testmod, basehaz_ops = list(knots = c(1,2,50))), "latest event time") - + }) test_that("prior arguments work", { @@ -141,7 +143,7 @@ test_that("prior arguments work", { es(up(testmod, prior = hs_plus())) es(up(testmod, prior = lasso())) es(up(testmod, prior = laplace())) - + es(up(testmod, prior_intercept = normal())) es(up(testmod, prior_intercept = student_t())) es(up(testmod, prior_intercept = cauchy())) @@ -163,130 +165,130 @@ test_that("prior arguments work", { #---- Compare parameter estimates: stan_surv vs coxph - compare_surv <- function(data, basehaz = "weibull", ...) { - require(survival) - fm <- Surv(eventtime, status) ~ X1 + X2 - surv1 <- coxph(fm, data) - stan1 <- stan_surv(formula = fm, - data = data, - basehaz = basehaz, - iter = ITER, - refresh = REFRESH, - chains = CHAINS, - seed = SEED, ...) - tols <- get_tols(surv1, tolscales = TOLSCALES) - pars_surv <- recover_pars(surv1) - pars_stan <- recover_pars(stan1) - for (i in names(tols$fixef)) - expect_equal(pars_surv$fixef[[i]], - pars_stan$fixef[[i]], - tol = tols$fixef[[i]], - info = basehaz) - } - - #---- exponential data - - set.seed(543634) - covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) - dat <- simsurv(dist = "weibull", - lambdas = 0.1, - gammas = 1, - betas = c(X1 = 0.3, X2 = -0.5), - x = covs) - dat <- merge(dat, covs) - - compare_surv(data = dat, basehaz = "exp") - - #---- weibull data +compare_surv <- function(data, basehaz = "weibull", ...) { + require(survival) + fm <- Surv(eventtime, status) ~ X1 + X2 + surv1 <- coxph(fm, data) + stan1 <- stan_surv(formula = fm, + data = data, + basehaz = basehaz, + iter = ITER, + refresh = REFRESH, + chains = CHAINS, + seed = SEED, ...) + tols <- get_tols(surv1, tolscales = TOLSCALES) + pars_surv <- recover_pars(surv1) + pars_stan <- recover_pars(stan1) + for (i in names(tols$fixef)) + expect_equal(pars_surv$fixef[[i]], + pars_stan$fixef[[i]], + tol = tols$fixef[[i]], + info = basehaz) +} + +#---- exponential data + +set.seed(543634) +covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) +dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) +dat <- merge(dat, covs) + +compare_surv(data = dat, basehaz = "exp") + +#---- weibull data + +set.seed(543634) +covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) +dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1.3, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) +dat <- merge(dat, covs) + +compare_surv(data = dat, basehaz = "weibull") +compare_surv(data = dat, basehaz = "ms") +compare_surv(data = dat, basehaz = "bs") + +#---- gompertz data + +set.seed(45357) +covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) +dat <- simsurv(dist = "gompertz", + lambdas = 0.1, + gammas = 0.05, + betas = c(X1 = -0.6, X2 = -0.4), + x = covs) +dat <- merge(dat, covs) + +compare_surv(data = dat, basehaz = "gompertz") - set.seed(543634) - covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) - dat <- simsurv(dist = "weibull", - lambdas = 0.1, - gammas = 1.3, - betas = c(X1 = 0.3, X2 = -0.5), - x = covs) - dat <- merge(dat, covs) - - compare_surv(data = dat, basehaz = "weibull") - compare_surv(data = dat, basehaz = "ms") - compare_surv(data = dat, basehaz = "bs") - - #---- gompertz data - - set.seed(45357) - covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) - dat <- simsurv(dist = "gompertz", - lambdas = 0.1, - gammas = 0.05, - betas = c(X1 = -0.6, X2 = -0.4), - x = covs) - dat <- merge(dat, covs) - compare_surv(data = dat, basehaz = "gompertz") +#---- Compare parameter estimates: stan_surv vs survreg +compare_surv <- function(data, basehaz = "weibull-aft", ...) { + require(survival) + fm <- Surv(eventtime, status) ~ X1 + X2 + dist <- ifelse(basehaz == "weibull-aft", "weibull", "exponential") + surv1 <- survreg(fm, data, dist = dist) + stan1 <- stan_surv(formula = fm, + data = data, + basehaz = basehaz, + iter = ITER, + refresh = REFRESH, + chains = CHAINS, + seed = SEED, ...) + tols <- get_tols(surv1, tolscales = TOLSCALES) + pars_surv <- recover_pars(surv1) + pars_stan <- recover_pars(stan1) + for (i in names(tols$fixef)) + expect_equal(pars_surv$fixef[[i]], + pars_stan$fixef[[i]], + tol = tols$fixef[[i]], + info = basehaz) +} + +#---- exponential data + +set.seed(543634) +covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) +dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) +dat <- merge(dat, covs) + +compare_surv(data = dat, basehaz = "exp-aft") + +#---- weibull data + +set.seed(543634) +covs <- data.frame(id = 1:300, + X1 = rbinom(300, 1, 0.3), + X2 = rnorm (300, 2, 2.0)) +dat <- simsurv(dist = "weibull", + lambdas = 0.1, + gammas = 1.3, + betas = c(X1 = 0.3, X2 = -0.5), + x = covs) +dat <- merge(dat, covs) + +compare_surv(data = dat, basehaz = "weibull-aft") -#---- Compare parameter estimates: stan_surv vs survreg - - compare_surv <- function(data, basehaz = "weibull-aft", ...) { - require(survival) - fm <- Surv(eventtime, status) ~ X1 + X2 - dist <- ifelse(basehaz == "weibull-aft", "weibull", "exponential") - surv1 <- survreg(fm, data, dist = dist) - stan1 <- stan_surv(formula = fm, - data = data, - basehaz = basehaz, - iter = ITER, - refresh = REFRESH, - chains = CHAINS, - seed = SEED, ...) - tols <- get_tols(surv1, tolscales = TOLSCALES) - pars_surv <- recover_pars(surv1) - pars_stan <- recover_pars(stan1) - for (i in names(tols$fixef)) - expect_equal(pars_surv$fixef[[i]], - pars_stan$fixef[[i]], - tol = tols$fixef[[i]], - info = basehaz) - } - - #---- exponential data - - set.seed(543634) - covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) - dat <- simsurv(dist = "weibull", - lambdas = 0.1, - gammas = 1, - betas = c(X1 = 0.3, X2 = -0.5), - x = covs) - dat <- merge(dat, covs) - - compare_surv(data = dat, basehaz = "exp-aft") - - #---- weibull data - - set.seed(543634) - covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) - dat <- simsurv(dist = "weibull", - lambdas = 0.1, - gammas = 1.3, - betas = c(X1 = 0.3, X2 = -0.5), - x = covs) - dat <- merge(dat, covs) - - compare_surv(data = dat, basehaz = "weibull-aft") - # COMMENTED OUT TO AVOID ADDING PACKAGES TO SUGGESTS # # #---- Compare parameter estimates: stan_surv vs icenReg (interval censored) @@ -386,103 +388,366 @@ test_that("prior arguments work", { # expect_error(expect_equal(coef(f_weib)['sesfixedupper'][[1]], # coef(v_weib)['sesupper'][[1]], # tol = 0.1), "not equal") - - -#-------- Check post-estimation functions work - pbcSurv$t0 <- 0 - pbcSurv$t0[pbcSurv$futimeYears > 2] <- 1 # delayed entry - - pbcSurv$t1 <- pbcSurv$futimeYears - 1 # lower limit for interval censoring - pbcSurv$t1[pbcSurv$t1 <= 0] <- -Inf # left censoring - - # different baseline hazards - o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, - data = pbcSurv, - basehaz = "ms", - chains = 1, - iter = 40, - refresh = REFRESH, - seed = SEED)) - o<-SW(f2 <- update(f1, basehaz = "bs")) - o<-SW(f3 <- update(f1, basehaz = "exp")) - o<-SW(f4 <- update(f1, basehaz = "weibull")) - o<-SW(f5 <- update(f1, basehaz = "gompertz")) - o<-SW(f6 <- update(f1, basehaz = "exp-aft")) - o<-SW(f7 <- update(f1, basehaz = "weibull-aft")) - - # time-dependent effects - o<-SW(f8 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f9 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f10 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f11 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f12 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f13 <- update(f6, Surv(futimeYears, death) ~ sex + tde(trt))) - o<-SW(f14 <- update(f7, Surv(futimeYears, death) ~ sex + tde(trt))) - - # start-stop notation (incl. delayed entry) - o<-SW(f15 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) - o<-SW(f16 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) - o<-SW(f17 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) - o<-SW(f18 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) - - # left and interval censoring - o<-SW(f19 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) - o<-SW(f20 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) - o<-SW(f21 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) - o<-SW(f22 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) - - # new data for predictions - nd1 <- pbcSurv[pbcSurv$id == 2,] - nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] - - # test the models - for (j in c(1:22)) { - - mod <- try(get(paste0("f", j)), silent = TRUE) - - if (class(mod)[1L] == "try-error") { - - cat("Model not found:", paste0("f", j), "\n") - - } else { - cat("Checking model:", paste0("f", j), "\n") +#-------- Check post-estimation functions work - test_that("log_lik works with estimation data", { - ll <- log_lik(mod) - expect_matrix(ll) - }) +pbcSurv$t0 <- 0 +pbcSurv$t0[pbcSurv$futimeYears > 2] <- 1 # delayed entry - test_that("log_lik works with new data (one individual)", { - ll <- log_lik(mod, newdata = nd1) - expect_matrix(ll) - }) +pbcSurv$t1 <- pbcSurv$futimeYears - 1 # lower limit for interval censoring +pbcSurv$t1[pbcSurv$t1 <= 0] <- -Inf # left censoring - test_that("log_lik works with new data (multiple individuals)", { - ll <- log_lik(mod, newdata = nd2) - expect_matrix(ll) - }) - - test_that("loo and waic work", { - expect_equivalent_loo(mod) +# different baseline hazards +o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, + data = pbcSurv, + basehaz = "ms", + chains = 1, + iter = 40, + refresh = REFRESH, + seed = SEED)) +o<-SW(f2 <- update(f1, basehaz = "bs")) +o<-SW(f3 <- update(f1, basehaz = "exp")) +o<-SW(f4 <- update(f1, basehaz = "weibull")) +o<-SW(f5 <- update(f1, basehaz = "gompertz")) +o<-SW(f6 <- update(f1, basehaz = "exp-aft")) +o<-SW(f7 <- update(f1, basehaz = "weibull-aft")) + +# time-dependent effects +o<-SW(f8 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt))) +o<-SW(f9 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt))) +o<-SW(f10 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt))) +o<-SW(f11 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt))) +o<-SW(f12 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt))) +o<-SW(f13 <- update(f6, Surv(futimeYears, death) ~ sex + tde(trt))) +o<-SW(f14 <- update(f7, Surv(futimeYears, death) ~ sex + tde(trt))) + +# start-stop notation (incl. delayed entry) +o<-SW(f15 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) +o<-SW(f16 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) +o<-SW(f17 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) +o<-SW(f18 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) + +# left and interval censoring +o<-SW(f19 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) +o<-SW(f20 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) +o<-SW(f21 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) +o<-SW(f22 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) + +# new data for predictions +nd1 <- pbcSurv[pbcSurv$id == 2,] +nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] + +# test the models +for (j in c(1:22)) { + + mod <- try(get(paste0("f", j)), silent = TRUE) + + if (class(mod)[1L] == "try-error") { + + cat("Model not found:", paste0("f", j), "\n") + + } else { + + cat("Checking model:", paste0("f", j), "\n") + + test_that("log_lik works with estimation data", { + ll <- log_lik(mod) + expect_matrix(ll) + }) + + test_that("log_lik works with new data (one individual)", { + ll <- log_lik(mod, newdata = nd1) + expect_matrix(ll) + }) + + test_that("log_lik works with new data (multiple individuals)", { + ll <- log_lik(mod, newdata = nd2) + expect_matrix(ll) + }) + + test_that("loo and waic work", { + expect_equivalent_loo(mod) + }) + + if (mod$ndelayed == 0) # only test if no delayed entry + test_that("posterior_survfit works with estimation data", { + SW(ps <- posterior_survfit(mod)) + expect_survfit(ps) }) + + test_that("posterior_survfit works with new data (one individual)", { + SW(ps <- posterior_survfit(mod, newdata = nd1)) + expect_survfit(ps) + }) + + test_that("posterior_survfit works with new data (multiple individuals)", { + SW(ps <- posterior_survfit(mod, newdata = nd2)) + expect_survfit(ps) + }) + + } +} - if (mod$ndelayed == 0) # only test if no delayed entry - test_that("posterior_survfit works with estimation data", { - SW(ps <- posterior_survfit(mod)) - expect_survfit(ps) - }) - test_that("posterior_survfit works with new data (one individual)", { - SW(ps <- posterior_survfit(mod, newdata = nd1)) - expect_survfit(ps) - }) +#-------- Check hazard models with group-specific terms - test_that("posterior_survfit works with new data (multiple individuals)", { - SW(ps <- posterior_survfit(mod, newdata = nd2)) - expect_survfit(ps) - }) +#--- test estimates for each model type using one simulated dataset +# define a function to simulate a survival dataset +make_data <- function(n = 10, # number of patients per site + K = 30, # number of sites + dist = "exponential", # basehaz for simulation + delay = FALSE, # induce delayed entry + icens = FALSE) { # induce interval censoring + + if (delay && icens) + stop("'delay' and 'icens' cannot both be TRUE.") + + # dimensions + N <- n * K # total num individuals + + # true sd for the random intercepts + true_sd <- 1 + + # sample random intercept for each site + bb <- rnorm(K, 0, true_sd) + + # covariate data + cov <- data.frame(id = 1:N, + site = rep(1:K, each = n), + trt = rbinom(N, 1, 0.5), + b = bb[rep(1:K, each = n)]) + + # simulate event times + dat <- simsurv(dist = dist, + lambdas = 0.1, + gammas = switch(dist, + "weibull" = 1.3, + "gompertz" = 0.05, + NULL), + x = cov, + betas = c(trt = 0.3, b = 1), + maxt = 15) + + # create delayed entry + if (delay) { + dat[["start"]] <- runif(N, 0, dat[["eventtime"]] / 2) + dat[["stop"]] <- dat[["eventtime"]] + } + + # create interval censoring + if (icens) { + + dd <- dat[["status"]] # event indicator + dat[["lower"]] <- rep(NA, nrow(dat)) + dat[["upper"]] <- rep(NA, nrow(dat)) + + # construct lower/upper interval cens times for right censored individuals + dat[dd == 0, "lower"] <- dat[dd == 0, "eventtime"] + dat[dd == 0, "upper"] <- Inf + + # construct lower/upper interval cens times for individuals with events + dat[dd == 1, "lower"] <- runif(sum(dd == 1), + dat[dd == 1, "eventtime"] / 2, + dat[dd == 1, "eventtime"]) + dat[dd == 1, "upper"] <- runif(sum(dd == 1), + dat[dd == 1, "eventtime"], + dat[dd == 1, "eventtime"] * 1.5) + + } + + merge(cov, dat) + +} + +# true parameter values used to simulate & corresponding tolerances for tests +true <- c(intercept = log(0.1), trt = 0.3, b_sd = 1) +tols <- c(0.2, 0.1, 0.2) + +# function to return the parameter estimates to test +get_ests <- function(mod) { + c(intercept = fixef(mod)[["(Intercept)"]], + trt = fixef(mod)[["trt"]], + b_sd = attr(VarCorr(mod)[[1]], "stddev")[[1]]) +} + +# fit right censored models +set.seed(5434) +dat <- make_data(n = 20, K = 50) +ff <- Surv(eventtime, status) ~ trt + (1 | site) +m1 <- stan_surv(ff, data = dat, chains = 1, basehaz = "exp") +m2 <- stan_surv(ff, data = dat, chains = 1, basehaz = "weibull") +m3 <- stan_surv(ff, data = dat, chains = 1, basehaz = "gompertz") +m4 <- stan_surv(ff, data = dat, chains = 1, basehaz = "ms") +for (i in 1:3) + expect_equal(get_ests(m1)[[i]], true[[i]], tol = tols[[i]]) +for (i in 1:3) + expect_equal(get_ests(m2)[[i]], true[[i]], tol = tols[[i]]) +for (i in 1:3) + expect_equal(get_ests(m3)[[i]], true[[i]], tol = tols[[i]]) +for (i in 2:3) + expect_equal(get_ests(m4)[[i]], true[[i]], tol = tols[[i]]) + +# fit delayed entry models +set.seed(8765) +dat_delay <- make_data(n = 20, K = 50, delay = TRUE) +ffd <- Surv(start, stop, status) ~ trt + (1 | site) +m5 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "exp") +m6 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "weibull") +m7 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "gompertz") +m8 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "ms") +for (i in 1:3) + expect_equal(get_ests(m5)[[i]], true[[i]], tol = tols[[i]]) +for (i in 1:3) + expect_equal(get_ests(m6)[[i]], true[[i]], tol = tols[[i]]) +for (i in 1:3) + expect_equal(get_ests(m7)[[i]], true[[i]], tol = tols[[i]]) +for (i in 2:3) + expect_equal(get_ests(m8)[[i]], true[[i]], tol = tols[[i]]) + +# fit interval censored models +set.seed(3254) +dat_icens <- make_data(n = 20, K = 50, icens = TRUE) +ffi <- Surv(lower, upper, type = "interval2") ~ trt + (1 | site) +m9 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "exp") +m10 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "weibull") +m11 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "gompertz") +m12 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "ms") +for (i in 1:3) + expect_equal(get_ests(m9)[[i]], true[[i]], tol = tols[[i]]) +for (i in 1:3) + expect_equal(get_ests(m10)[[i]], true[[i]], tol = tols[[i]]) +for (i in 1:3) + expect_equal(get_ests(m11)[[i]], true[[i]], tol = tols[[i]]) +for (i in 2:3) + expect_equal(get_ests(m12)[[i]], true[[i]], tol = tols[[i]]) + +#--- previous tests use really weak tolerances to check the +# parameter estimates; therefore the next part conducts a full +# simulation study to test each model specification and uses a +# stronger tolerance, checking that relative bias is less than 5% + +if (run_sims) { + + # number of simulations (for each model specification) + n_sims <- 2 + + # define a function to fit the model to one simulated dataset + sim_run <- function(n = 10, # number of patients per site + K = 30, # number of sites + basehaz = "exp", # basehaz for analysis + dist = "exponential", # basehaz for simulation + delay = FALSE, # induce delayed entry + icens = FALSE, # induce interval censoring + return_relb = FALSE) { + + # simulate data + dat <- make_data(n = n, K = K, dist = dist, delay = delay, icens = icens) + + # define appropriate model formula + if (delay) { + ff <- Surv(start, stop, status) ~ trt + (1 | site) + } else if (icens) { + ff <- Surv(lower, upper, type = "interval2") ~ trt + (1 | site) + } else { + ff <- Surv(eventtime, status) ~ trt + (1 | site) + } + + # fit model + mod <- stan_surv(formula = ff, + data = dat, + basehaz = basehaz, + chains = 1, + refresh = 0, + iter = 2000) + + # true parameters (hard coded here) + true <- c(intercept = log(0.1), + trt = 0.3, + b_sd = 1) + + # extract parameter estimates + ests <- c(intercept = fixef(mod)["(Intercept)"], + trt = fixef(mod)["trt"], + b_sd = attr(VarCorr(mod)[[1]], "stddev")[[1]]) + + # intercept is irrelevant for spline model + if (basehaz %in% c("ms", "bs")) { + true <- true[2:3] + ests <- ests[2:3] } + + if (return_relb) + return(as.vector((ests - true) / true)) + + list(true = true, + ests = ests, + bias = ests - true, + relb = (ests - true) / true) + } + + # functions to summarise the simulations and check relative bias + summarise_sims <- function(x) { + rbind(true = colMeans(do.call(rbind, x["true",])), + ests = colMeans(do.call(rbind, x["ests",])), + bias = colMeans(do.call(rbind, x["bias",])), + relb = colMeans(do.call(rbind, x["relb",]))) + } + validate_relbias <- function(x, tol = 0.05) { + relb <- as.vector(summarise_sims(x)["relb",]) + expect_equal(relb, rep(0, length(relb)), tol = tol) } + + # right censored models + set.seed(5050) + sims_exp <- replicate(n_sims, sim_run(basehaz = "exp")) + validate_relbias(sims_exp) + + set.seed(6060) + sims_weibull <- replicate(n_sims, sim_run(basehaz = "weibull")) + validate_relbias(sims_weibull) + + set.seed(7070) + sims_gompertz <- replicate(n_sims, sim_run(basehaz = "gompertz")) + validate_relbias(sims_gompertz) + + set.seed(8080) + sims_ms <- replicate(n_sims, sim_run(basehaz = "ms")) + validate_relbias(sims_ms) + + # delayed entry models + set.seed(5050) + sims_exp_d <- replicate(n_sims, sim_run(basehaz = "exp", delay = TRUE)) + validate_relbias(sims_exp_d) + + set.seed(6060) + sims_weibull_d <- replicate(n_sims, sim_run(basehaz = "weibull", delay = TRUE)) + validate_relbias(sims_weibull_d) + + set.seed(7070) + sims_gompertz_d <- replicate(n_sims, sim_run(basehaz = "gompertz", delay = TRUE)) + validate_relbias(sims_gompertz_d) + + set.seed(8080) + sims_ms_d <- replicate(n_sims, sim_run(basehaz = "ms", delay = TRUE)) + validate_relbias(sims_ms_d) + + # interval censored models + set.seed(5050) + sims_exp_i <- replicate(n_sims, sim_run(basehaz = "exp", icens = TRUE)) + validate_relbias(sims_exp_i) + + set.seed(6060) + sims_weibull_i <- replicate(n_sims, sim_run(basehaz = "weibull", icens = TRUE)) + validate_relbias(sims_weibull_i) + + set.seed(7070) + sims_gompertz_i <- replicate(n_sims, sim_run(basehaz = "gompertz", icens = TRUE)) + validate_relbias(sims_gompertz_i) + + set.seed(8080) + sims_ms_i <- replicate(n_sims, sim_run(basehaz = "ms", icens = TRUE)) + validate_relbias(sims_ms_i) + +} From 91343fca129cee559abbb6c97af570ef2c8a450a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 20 Mar 2019 10:13:38 +1100 Subject: [PATCH 129/225] Add formula and terms methods for stansurv objects --- R/stanreg-methods.R | 40 +++++++++++++++++++++++++++++++++------- 1 file changed, 33 insertions(+), 7 deletions(-) diff --git a/R/stanreg-methods.R b/R/stanreg-methods.R index 2dca4ed87..4ae2e8bc9 100644 --- a/R/stanreg-methods.R +++ b/R/stanreg-methods.R @@ -362,13 +362,15 @@ model.matrix.stanreg <- function(object, ...) { #' @export #' @param x A stanreg object. #' @param ... Can contain \code{fixed.only} and \code{random.only} arguments -#' that both default to \code{FALSE}. +#' that both default to \code{FALSE}. Also, for stan_surv models, can contain +#' \code{remove.tde} which defaults to FALSE, but if TRUE then any +#' 'tde(varname)' terms in the model formula are returned as 'varname'. #' formula.stanreg <- function(x, ..., m = NULL) { if (is.mer(x) && !isTRUE(x$stan_function == "stan_gamm4")) - return(formula_mer(x, ...)) + return(formula_mer(x, ...)) if (is.surv(x)) - return(x$formula$formula) + return(formula_surv(x, ...)) x$formula } @@ -378,10 +380,11 @@ formula.stanreg <- function(x, ..., m = NULL) { #' @param x,fixed.only,random.only,... See lme4:::terms.merMod. #' terms.stanreg <- function(x, ..., fixed.only = TRUE, random.only = FALSE) { - if (!is.mer(x)) + if (!any(is.mer(x), is.stansurv(x))) return(NextMethod("terms")) - fr <- x$glmod$fr + fr <- if (is.stansurv(x)) model.frame(x) else x$glmod$fr + if (missing(fixed.only) && random.only) fixed.only <- FALSE if (fixed.only && random.only) @@ -389,11 +392,12 @@ terms.stanreg <- function(x, ..., fixed.only = TRUE, random.only = FALSE) { Terms <- attr(fr, "terms") if (fixed.only) { - Terms <- terms.formula(formula(x, fixed.only = TRUE)) + Terms <- terms.formula(formula(x, fixed.only = TRUE, remove.tde = TRUE)) attr(Terms, "predvars") <- attr(terms(fr), "predvars.fixed") } if (random.only) { - Terms <- terms.formula(lme4::subbars(formula.stanreg(x, random.only = TRUE))) + Terms <- terms.formula(lme4::subbars(formula.stanreg(x, random.only = TRUE, + remove.tde = TRUE))) attr(Terms, "predvars") <- attr(terms(fr), "predvars.random") } @@ -480,3 +484,25 @@ formula_mer <- function (x, fixed.only = FALSE, random.only = FALSE, ...) { return(form) } +formula_surv <- function(x, + fixed.only = FALSE, + random.only = FALSE, + remove.tde = FALSE, + ...) { + if (missing(fixed.only) && random.only) + fixed.only <- FALSE + if (fixed.only && random.only) + stop2("'fixed.only' and 'random.only' can't both be TRUE.") + if (remove.tde) { + form <- x$formula$tf_form + } else { + form <- x$formula$formula + } + if (is.null(form)) + stop2("Can't find formula in model object.") + if (fixed.only) + form[[length(form)]] <- lme4::nobars(form[[length(form)]]) + if (random.only) + form <- justRE(form, response = TRUE) + return(form) +} From da77d7e489a415945d8c1de686c2ea4f3e996823 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 20 Mar 2019 10:14:05 +1100 Subject: [PATCH 130/225] Handle predvars in make_model_frame for stansurv --- R/stan_surv.R | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 50cba769b..cafc7699d 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1926,16 +1926,31 @@ make_model_data <- function(formula, data) { make_model_frame <- function(formula, data, xlevs = NULL, check_constant = FALSE) { - # construct terms object from formula + # construct model frame Terms <- terms(lme4::subbars(formula)) + mf <- stats::model.frame(Terms, data, xlev = xlevs, drop.unused.levels = TRUE) - # construct model frame - mf <- model.frame(Terms, data, xlev = xlevs) + # get predvars for fixed part of formula + TermsF <- terms(lme4::nobars(formula)) + mfF <- stats::model.frame(TermsF, data, xlev = xlevs, drop.unused.levels = TRUE) + attr(attr(mf, "terms"), "predvars.fixed") <- attr(attr(mfF, "terms"), "predvars") + + # get predvars for random part of formula + has_bars <- length(lme4::findbars(formula)) > 0 + if (has_bars) { + TermsR <- terms(lme4::subbars(justRE(formula, response = TRUE))) + mfR <- stats::model.frame(TermsR, data, xlev = xlevs, drop.unused.levels = TRUE) + attr(attr(mf, "terms"), "predvars.random") <- attr(attr(mfR, "terms"), "predvars") + } else { + attr(attr(mf, "terms"), "predvars.random") <- NULL + } # check no constant vars if (check_constant) mf <- check_constant_vars(mf) + # add additional predvars attributes + # check for terms mt <- attr(mf, "terms") if (is.empty.model(mt)) From 9d83be22a0f950524920a524b3bcb62a36854ae7 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 20 Mar 2019 10:14:51 +1100 Subject: [PATCH 131/225] pp_data.R: start dealing with random effects for stansurv objects --- R/pp_data.R | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index 41c131fee..90cb82656 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -259,6 +259,7 @@ pp_data <- # flags has_tde <- object$has_tde has_quadrature <- object$has_quadrature + has_bars <- object$has_bars #----- dimensions and times @@ -296,7 +297,7 @@ pp_data <- #----- model frame for generating predictor matrices - tt <- delete.response(terms(object)) + tt <- delete.response(terms(object, fixed.only = FALSE)) mf <- make_model_frame(tt, newdata, xlevs = object$xlevs)$mf @@ -322,19 +323,35 @@ pp_data <- #----- time-fixed predictor matrix - x <- make_x(tt, mf)$x + x <- make_x(tt, mf, check_constant = FALSE)$x #----- time-varying predictor matrix - s <- if (has_tde) make_x(formula$tt_form, mf)$x else matrix(0, length(pts), 0) + if (has_tde) { + s <- make_x(formula$tt_form, mf, check_constant = FALSE)$x + } else { + s <- matrix(0, nrow(mf), 0) + } + + #----- random effects predictor matrices + if (has_bars) { + ReTrms <- lme4::mkReTrms(formula$bars, mf) + z <- nlist(Zt = ReTrms$Zt, Z_names = make_b_nms(ReTrms)) + } else { + z <- list() + } + # return object return(nlist(pts, wts, ids, x, s, + z, has_quadrature, + has_tde, + has_bars, at_quadpoints, qnodes = object$qnodes)) } @@ -492,7 +509,7 @@ get_model_data <- function(object, ...) UseMethod("get_model_data") get_model_data.stansurv <- function(object, ...) { validate_stansurv_object(object) - terms <- terms(object) + terms <- terms(object, fixed.only = FALSE) row_nms <- row.names(model.frame(object)) get_all_vars(terms, object$data)[row_nms, , drop = FALSE] } From 920fb4071d95c5a2691e66fc2ef101276045d4a3 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 8 May 2019 18:16:40 +1000 Subject: [PATCH 132/225] Allow tde() to be piecewise constant or a B-spline function --- R/plots.R | 50 +++++--- R/stan_surv.R | 320 +++++++++++++++++++++++++++++++++++--------------- 2 files changed, 258 insertions(+), 112 deletions(-) diff --git a/R/plots.R b/R/plots.R index a0a967c14..1b6b60f50 100644 --- a/R/plots.R +++ b/R/plots.R @@ -210,7 +210,7 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, t_min <- min(x$entrytime) t_max <- max(x$eventtime) - times <- seq(t_min, t_max, by = (t_max - t_min) / 200) + times <- seq(t_min, t_max, by = (t_max - t_min) / 1000) if (plotfun == "basehaz") { @@ -226,6 +226,8 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, basehaz <- do.call(evaluate_basehaz, args) basehaz <- median_and_bounds(basehaz, prob, na.rm = TRUE) plotdat <- data.frame(times, basehaz) + + requires_smooth <- !(get_basehaz_name(x) %in% c("piecewise")) ylab <- "Baseline hazard rate" xlab <- "Time" @@ -253,35 +255,53 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, betas_td <- stanpars$beta_tde[, sel2, drop = FALSE] betas <- cbind(betas_tf, betas_td) - times__ <- times - basis <- eval(parse(text = x$formula$tt_basis[sel1])) - basis <- add_intercept(basis) - coef <- linear_predictor(betas, basis) + tt_varid <- unique(x$formula$tt_map[smooth_map == sel1]) + tt_type <- x$formula$tt_types[[tt_varid]] + tt_form <- x$formula$tt_forms[[tt_varid]] + tt_data <- data.frame(times__ = times) + tt_x <- model.matrix(tt_form, tt_data) + + coef <- linear_predictor(betas, tt_x) - is_aft <- get_basehaz_name(x$basehaz) %in% c("exp-aft", "weibull-aft") + is_aft <- get_basehaz_name(x$basehaz) %in% c("exp-aft", "weibull-aft") - plotdat <- median_and_bounds(exp(coef), prob, na.rm = TRUE) - plotdat <- data.frame(times, plotdat) + plotdat <- median_and_bounds(exp(coef), prob, na.rm = TRUE) + plotdat <- data.frame(times, plotdat) + requires_smooth <- !(tt_type %in% c("pw", "piecewise")) + xlab <- "Time" - ylab <- ifelse(is_aft, "Survival time ratio", "Hazard ratio") + ylab <- ifelse(is_aft, + paste0("Survival time ratio\n(", pars, ")"), + paste0("Hazard ratio\n(", pars, ")")) } - + geom_defs <- list(color = "black") # default plot args geom_args <- set_geom_args(geom_defs, ...) geom_ylab <- ggplot2::ylab(ylab) geom_xlab <- ggplot2::xlab(xlab) - geom_maps <- list(aes_string(x = "times", y = "med"), method = "loess", se = FALSE) geom_base <- ggplot(plotdat) + geom_ylab + geom_xlab + ggplot2::theme_bw() - geom_plot <- geom_base + do.call(ggplot2::geom_smooth, c(geom_maps, geom_args)) + if (requires_smooth) { + geom_maps <- list(aes_string(x = "times", y = "med"), method = "loess", se = FALSE) + geom_plot <- geom_base + do.call(ggplot2::geom_smooth, c(geom_maps, geom_args)) + } else { + geom_maps <- list(aes_string(x = "times", y = "med")) + geom_plot <- geom_base + do.call(ggplot2::geom_step, c(geom_maps, geom_args)) + } if (limits == "ci") { lim_defs <- list(alpha = 0.3) # default plot args for ci lim_args <- c(defaults = list(lim_defs), ci_geom_args) lim_args <- do.call("set_geom_args", lim_args) lim_maps <- list(mapping = aes_string(x = "times", ymin = "lb", ymax = "ub")) - lim_tmp <- geom_base + - ggplot2::stat_smooth(aes_string(x = "times", y = "lb"), method = "loess") + - ggplot2::stat_smooth(aes_string(x = "times", y = "ub"), method = "loess") + if (requires_smooth) { + lim_tmp <- geom_base + + ggplot2::stat_smooth(aes_string(x = "times", y = "lb"), method = "loess") + + ggplot2::stat_smooth(aes_string(x = "times", y = "ub"), method = "loess") + } else { + lim_tmp <- geom_base + + ggplot2::geom_step(aes_string(x = "times", y = "lb")) + + ggplot2::geom_step(aes_string(x = "times", y = "ub")) + } lim_build<- ggplot2::ggplot_build(lim_tmp) lim_data <- list(data = data.frame(times = lim_build$data[[1]]$x, lb = lim_build$data[[1]]$y, diff --git a/R/stan_surv.R b/R/stan_surv.R index cafc7699d..4fada6544 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -424,8 +424,8 @@ stan_surv <- function(formula, dots <- list(...) algorithm <- match.arg(algorithm) - formula <- parse_formula(formula, data) - data <- make_model_data(formula$allvars_form, data) # row subsetting etc. + formula <- parse_formula_and_data(formula, data) + data <- formula$data; formula[["data"]] <- NULL #---------------- # Construct data @@ -641,11 +641,8 @@ stan_surv <- function(formula, if (has_tde) { - # formula for generating spline basis for tde effects - bsf <- formula$bs_form - # generate a model frame with time transformations for tde effects - mf_tde_times <- make_model_frame(bsf, data.frame(times__ = cpts))$mf + mf_tde_times <- make_model_frame(formula$tt_frame, data.frame(times__ = cpts))$mf # NB next line avoids dropping terms attribute from 'mf_cpts' mf_cpts[, colnames(mf_tde_times)] <- mf_tde_times @@ -689,16 +686,30 @@ stan_surv <- function(formula, if (has_tde) { - s_cpts <- make_x(formula$tt_form, mf_cpts, xlevs = xlevs)$x - smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") - smooth_idx <- get_idx_array(table(smooth_map)) - S <- ncol(s_cpts) # number of tde spline coefficients + s_cpts_parts <- xapply( + formula$tt_vars, + formula$tt_forms, + FUN = function(vn, tt) { + m1 <- make_x(vn, mf_cpts, xlevs = xlevs)$x + m2 <- make_x(tt, mf_cpts, xlevs = xlevs)$x + m3 <- matrix(apply(m1, 2L, `*`, m2), nrow = nrow(m2)) + colnames(m3) <- uapply(colnames(m1), paste, colnames(m2), sep = ":") + return(m3) + }) + formula$tt_ncol <- sapply(s_cpts_parts, ncol) + formula$tt_map <- rep(1:length(formula$tt_ncol), formula$tt_ncol) + s_cpts <- do.call("cbind", s_cpts_parts) + smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") + smooth_idx <- get_idx_array(table(smooth_map)) + S <- ncol(s_cpts) # number of tde coefficients } else { - s_cpts <- matrix(0,length(cpts),0) - smooth_idx <- matrix(0,0,2) - smooth_map <- integer(0) + formula$tt_ncol <- integer(0) + formula$tt_map <- integer(0) + s_cpts <- matrix(0,length(cpts),0) + smooth_idx <- matrix(0,0,2) + smooth_map <- integer(0) S <- 0L } @@ -1366,6 +1377,10 @@ get_iknots <- function(x, df = 5L, degree = 3L, iknots = NULL, intercept = FALSE stop2("Number of internal knots cannot be negative.") } + # if no internal knots then return empty vector + if (nk == 0) + return(numeric(0)) + # obtain default knot locations if necessary if (is.null(iknots)) { iknots <- qtile(x, nq = nk + 1) # evenly spaced percentiles @@ -1403,16 +1418,19 @@ get_smooth_name <- function(x, type = "smooth_coefs") { if (is.null(x) || !ncol(x)) return(NULL) - nms <- gsub(":bs\\(times__.*\\)[0-9]*$", "", colnames(x)) - tally <- table(nms) - indices <- uapply(tally, seq_len) - suffix <- paste0(":tde-spline-coef", indices) - + nms <- colnames(x) + nms <- gsub(":splines::bs\\(times__.*\\)[0-9]*$", ":tde-bs-coef", nms) + nms <- gsub(":base::cut\\(times__.*\\]$", ":tde-pw-coef", nms) + + nms_trim <- gsub(":tde-[a-z][a-z]-coef$", "", nms) + tally <- table(nms_trim) + indices <- uapply(tally, seq_len) + switch(type, - "smooth_coefs" = paste0(nms, suffix), - "smooth_sd" = paste0("smooth_sd[", unique(nms), "]"), + "smooth_coefs" = paste0(nms, indices), + "smooth_sd" = paste0("smooth_sd[", unique(nms_trim), "]"), "smooth_map" = rep(seq_along(tally), tally), - "smooth_vars" = unique(nms), + "smooth_vars" = unique(nms_trim), stop2("Bug found: invalid input to 'type' argument.")) } @@ -1547,11 +1565,13 @@ basis_matrix <- function(times, basis, integrate = FALSE) { aa(out) } -# Parse the model formula +# Parse the model formula and data # # @param formula The user input to the formula argument. # @param data The user input to the data argument (i.e. a data frame). -parse_formula <- function(formula, data) { +# @param A list with the model data (following removal of NA rows etc) and +# a number of elements corresponding to different parts of the formula. +parse_formula_and_data <- function(formula, data) { formula <- validate_formula(formula, needs_response = TRUE) @@ -1567,6 +1587,9 @@ parse_formula <- function(formula, data) { rhs <- rhs(formula) # RHS as expression rhs_form <- reformulate_rhs(rhs) # RHS as formula + # Evaluate model data (row subsetting etc) + data <- make_model_data(allvars_form, data) + # Evaluated response variables surv <- eval(lhs, envir = data) # Surv object surv <- validate_surv(surv) @@ -1578,35 +1601,48 @@ parse_formula <- function(formula, data) { dvar <- as.character(lhs[[3L]]) min_t <- 0 max_t <- max(surv[, "time"]) + status <- as.vector(surv[, "status"]) + t_end <- as.vector(surv[, "time"]) } else if (type == "counting") { tvar_beg <- as.character(lhs[[2L]]) tvar_end <- as.character(lhs[[3L]]) dvar <- as.character(lhs[[4L]]) min_t <- min(surv[, "start"]) max_t <- max(surv[, "stop"]) + status <- as.vector(surv[, "status"]) + t_end <- as.vector(surv[, "stop"]) } else if (type == "interval") { tvar_beg <- NULL tvar_end <- as.character(lhs[[2L]]) dvar <- as.character(lhs[[4L]]) min_t <- 0 - max_t <- max(surv[, c("time1", "time2")]) + max_t <- max(surv[, c("time1", "time2")]) + status <- as.vector(surv[, "status"]) + t_end <- as.vector(surv[, "time1"]) } else if (type == "interval2") { tvar_beg <- NULL tvar_end <- as.character(lhs[[2L]]) dvar <- as.character(lhs[[3L]]) min_t <- 0 max_t <- max(surv[, c("time1", "time2")]) + status <- as.vector(surv[, "status"]) + t_end <- as.vector(surv[, "time1"]) } # Deal with tde(x, ...) - tde_stuff <- handle_tde(formula, min_t = min_t, max_t = max_t) + tde_stuff <- handle_tde(formula, + min_t = min_t, + max_t = max_t, + times = t_end, + status = status) tf_form <- tde_stuff$tf_form td_form <- tde_stuff$td_form # may be NULL - bs_form <- tde_stuff$bs_form # may be NULL - tt_form <- tde_stuff$tt_form # may be NULL - tt_basis <- tde_stuff$tt_basis # may be NULL - tt_calls <- tde_stuff$tt_calls # may be NULL - + tt_vars <- tde_stuff$tt_vars # may be NULL + tt_frame <- tde_stuff$tt_frame # may be NULL + tt_types <- tde_stuff$tt_types # may be NULL + tt_calls <- tde_stuff$tt_calls # may be NULL + tt_forms <- tde_stuff$tt_forms # may be NULL + # Just fixed-effect part of formula fe_form <- lme4::nobars(tf_form) @@ -1618,6 +1654,7 @@ parse_formula <- function(formula, data) { stop2("A maximum of 2 grouping factors are allowed.") nlist(formula, + data, allvars, allvars_form, lhs, @@ -1626,10 +1663,11 @@ parse_formula <- function(formula, data) { rhs_form, tf_form, td_form, - bs_form, - tt_form, - tt_basis, + tt_vars, + tt_frame, + tt_types, tt_calls, + tt_forms, fe_form, bars, re_parts, @@ -1645,104 +1683,192 @@ parse_formula <- function(formula, data) { # @param Terms terms object for the fixed effect part of the model formula. # @return A named list with the following elements: # -handle_tde <- function(formula, min_t, max_t) { +handle_tde <- function(formula, min_t, max_t, times, status) { - Terms <- terms(lme4::nobars(formula), specials = "tde") + # extract terms objects for fixed effect part of model formula + Terms <- delete.response(terms(lme4::nobars(formula), specials = "tde")) - # if no time-dependent effects then just return formula - if (is.null(attr(Terms, "specials")$tde)) { + # check which fixed effect terms have a tde() wrapper + sel <- attr(Terms, "specials")$tde + + # if no tde() terms then just return the fixed effect formula as is + if (is.null(sel)) { return(list(tf_form = formula, td_form = NULL, - bs_form = NULL, - tt_form = NULL, - tt_basis = NULL, - tt_calls = NULL)) + tt_vars = NULL, + tt_frame = NULL, + tt_calls = NULL, + tt_forms = NULL)) } - # extract rhs of formula - Terms <- delete.response(Terms) - sel <- attr(Terms, "specials")$tde - varnms <- rownames(attr(Terms, "factors")) + # otherwise extract rhs of formula + all_vars <- rownames(attr(Terms, "factors")) # all variables in fe formula + tde_vars <- all_vars[sel] # variables with a tde() wrapper # replace 'tde(x, ...)' in formula with 'x' - tde_oldvars <- varnms - tde_newvars <- sapply(tde_oldvars, function(oldvar) { - if (oldvar %in% varnms[sel]) { - tde <- function(newvar, ...) { # define tde function locally - safe_deparse(substitute(newvar)) - } - eval(parse(text = oldvar)) - } else oldvar + old_vars <- all_vars + new_vars <- sapply(old_vars, function(x) { + if (x %in% tde_vars) { + # strip tde() from variable + tde <- function(y, ...) { safe_deparse(substitute(y)) } # define locally + return(eval(parse(text = x))) + } else { + # just return variable + return(x) + } }, USE.NAMES = FALSE) - tf_term_labels <- attr(Terms, "term.labels") - td_term_labels <- c() - k <- 0 # initialise td_term_labels indexing (for creating a new formula) + tf_terms <- attr(Terms, "term.labels") + td_terms <- c() + k <- 0 # initialise td_terms indexing (for creating a new formula) for (i in sel) { sel_terms <- which(attr(Terms, "factors")[i, ] > 0) for (j in sel_terms) { k <- k + 1 - tf_term_labels[j] <- td_term_labels[k] <- gsub(tde_oldvars[i], - tde_newvars[i], - tf_term_labels[j], - fixed = TRUE) + tf_terms[j] <- td_terms[k] <- gsub(old_vars[i], + new_vars[i], + tf_terms[j], + fixed = TRUE) } } - # extract 'tde(x, ...)' from formula and construct 'bs(times, ...)' - tde_terms <- lapply(varnms[sel], function(x) { - tde <- function(vn, ...) { # define tde function locally + # extract 'tde(x, ...)' from formula and return '~ x' and '~ bs(times, ...)' + idx <- 1 + tt_vars <- list() + tt_types <- list() + tt_calls <- list() + + for (i in seq_along(sel)) { + + # define tde() function locally; uses objects from the parent environment + # + # @param x The variable the time-varying effect is going to be applied to. + # @param type Character string, the type of time-varying effect to use. Can + # currently be one of: bs, ms, pw. + # @param ... Additional arguments passed by the user that control aspects of + # the time-varying effect. + # @return The call used to construct a time-dependent basis. + tde <- function(x, type = "bs", ...) { + dots <- list(...) - ok_args <- c("df") - if (!isTRUE(all(names(dots) %in% ok_args))) - stop2("Invalid argument to 'tde' function. ", - "Valid arguments are: ", comma(ok_args)) - df <- if (is.null(dots$df)) 3 else dots$df - degree <- 3 - if (df == 3) { - dots[["knots"]] <- numeric(0) - } else { - dx <- (max_t - min_t) / (df - degree + 1) - dots[["knots"]] <- seq(min_t + dx, max_t - dx, dx) + + df <- dots[["df"]] + knots <- dots[["knots"]] + degree <- dots[["degree"]] + + ok_args <- switch(type, + "bs" = c("df", "knots", "degree"), + "ms" = c("df", "knots", "degree"), + "pw" = c("df", "knots"), + "piecewise" = c("df", "knots"), + stop2("Invalid 'type' argument for the 'tde' function.")) + + dots <- validate_tde_args(dots, ok_args = ok_args) + + if (!is.null(df) && !is.null(knots)) + stop2("Cannot specify both 'df' and 'knots' in the 'tde' function.") + + if (is.null(df)) + df <- 3L # assumes no intercept, ignored if the user specified knots + + if (is.null(degree)) + degree <- 3L + + # note that times and status are taken from the parent environment + tt <- times[status == 1] # uncensored event times + if (is.null(knots) && !length(tt)) { + warning2("No observed events found in the data. Censoring times will ", + "be used to evaluate default knot locations for tde().") + tt <- times } - dots[["Boundary.knots"]] <- c(min_t, max_t) - sub("^list\\(", "bs\\(times__, ", safe_deparse(dots)) + + # note that min_t and max_t are taken from the parent environment + if (!is.null(knots)) { + if (any(knots < min_t)) + stop2("In tde(), 'knots' cannot be placed before the earliest entry time.") + if (any(knots > max_t)) + stop2("In tde(), 'knots' cannot be placed beyond the latest event time.") + } + + if (type == "bs") { + + bknots <- c(min_t, max_t) + iknots <- get_iknots(tt, df = df, iknots = knots) + + new_args <- list(knots = iknots, + Boundary.knots = bknots, + degree = degree) + + return(list( + type = type, + call = sub("^list\\(", "splines::bs\\(times__, ", safe_deparse(new_args)))) + + } else if (type == "ms") { + + stop("Bug found: not yet implemented.") + + } else if (type == "pw" || type == "piecewise") { + + iknots <- get_iknots(tt, df = df, degree = 1, iknots = knots) + + new_args <- list(breaks = c(min_t, iknots, max_t), + include.lowest = TRUE) + + return(list( + type = type, + call = sub("^list\\(", "base::cut\\(times__, ", safe_deparse(new_args)))) + + } + + } + + tt_parsed <- eval(parse(text = all_vars[sel[i]])) + tt_terms <- which(attr(Terms, "factors")[i, ] > 0) + for (j in tt_terms) { + tt_vars [[idx]] <- tf_terms[j] + tt_types[[idx]] <- tt_parsed$type + tt_calls[[idx]] <- tt_parsed$call + idx <- idx + 1 } - tde_calls <- eval(parse(text = x)) - sel_terms <- which(attr(Terms, "factors")[x, ] > 0) - new_calls <- sapply(seq_along(sel_terms), function(j) { - paste0(tf_term_labels[sel_terms[j]], ":", tde_calls) - }) - nlist(tde_calls, new_calls) - }) + } # add on the terms labels from the random effects part of the formula bars <- lme4::findbars(formula) if (length(bars)) { - bars_term_labels <- sapply(bars, bracket_wrap) - tf_term_labels <- c(tf_term_labels, bars_term_labels) + re_terms <- sapply(bars, bracket_wrap) + tf_terms <- c(tf_terms, re_terms) } # formula with all variables but no 'tde(x, ...)' wrappers - tf_form <- reformulate(tf_term_labels, response = lhs(formula)) + tf_form <- reformulate(tf_terms, response = lhs(formula)) # formula with only tde variables but no 'tde(x, ...)' wrappers - td_form <- reformulate(td_term_labels, response = lhs(formula)) + td_form <- reformulate(td_terms, response = lhs(formula)) - # formula with 'bs(times__, ...)' terms based on 'tde(x, ...)' calls - tt_basis <- fetch(tde_terms, "tde_calls"); utt <- unique(unlist(tt_basis)) - bs_form <- reformulate(utt, response = NULL, intercept = FALSE) + # unique set of '~ bs(times__, ...)' calls based on all 'tde(x, ...)' terms + tt_frame <- reformulate(unique(unlist(tt_calls)), intercept = FALSE) - # formula with 'x:bs(times__, ...)' terms based on 'tde(x, ...)' calls - tt_calls <- fetch_(tde_terms, "new_calls") - tt_form <- reformulate(tt_calls, response = NULL, intercept = FALSE) + # formula with '~ x' and '~ bs(times__, ...)' from each 'tde(x, ...)' call + tt_vars <- lapply(tt_vars, reformulate) + tt_forms <- lapply(tt_calls, reformulate) # return object nlist(tf_form, td_form, - bs_form, - tt_form, - tt_basis, - tt_calls) + tt_vars, + tt_frame, + tt_types, + tt_calls, + tt_forms) +} + +# Ensure only valid arguments are passed to the tde() call +validate_tde_args <- function(dots, ok_args) { + + if (!isTRUE(all(names(dots) %in% ok_args))) + stop2("Invalid argument to 'tde' function. ", + "Valid arguments are: ", comma(ok_args)) + + return(dots) } # Deparse an expression and wrap it in brackets From 2485d7c89ea69bfba46f88f4dcdcf43b711686d2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 9 May 2019 16:38:38 +1000 Subject: [PATCH 133/225] Add some tests for piecewise tde() --- R/stan_surv.R | 27 ++++--- R/stansurv.R | 34 +++++--- tests/testthat/helpers/recover_pars_surv.R | 17 +++- tests/testthat/test_stan_surv.R | 94 +++++++++++++++++++--- 4 files changed, 138 insertions(+), 34 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 4fada6544..88e15be20 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1164,7 +1164,7 @@ stan_surv <- function(formula, # substitute new parameter names into 'stanfit' object stanfit <- replace_stanfit_nms(stanfit, nms_all) - + # return an object of class 'stansurv' fit <- nlist(stanfit, formula, @@ -1378,12 +1378,13 @@ get_iknots <- function(x, df = 5L, degree = 3L, iknots = NULL, intercept = FALSE } # if no internal knots then return empty vector - if (nk == 0) + if (nk == 0) { return(numeric(0)) + } # obtain default knot locations if necessary if (is.null(iknots)) { - iknots <- qtile(x, nq = nk + 1) # evenly spaced percentiles + iknots <- qtile(x, nq = nk + 1) # evenly spaced percentiles } # return internal knot locations, ensuring they are positive @@ -1420,16 +1421,16 @@ get_smooth_name <- function(x, type = "smooth_coefs") { nms <- colnames(x) nms <- gsub(":splines::bs\\(times__.*\\)[0-9]*$", ":tde-bs-coef", nms) - nms <- gsub(":base::cut\\(times__.*\\]$", ":tde-pw-coef", nms) + nms <- gsub(":base::cut\\(times__.*\\]$", ":tde-pw-coef", nms) - nms_trim <- gsub(":tde-[a-z][a-z]-coef$", "", nms) + nms_trim <- gsub(":tde-[a-z][a-z]-coef[0-9]*$", "", nms) tally <- table(nms_trim) indices <- uapply(tally, seq_len) switch(type, "smooth_coefs" = paste0(nms, indices), "smooth_sd" = paste0("smooth_sd[", unique(nms_trim), "]"), - "smooth_map" = rep(seq_along(tally), tally), + "smooth_map" = aa(rep(seq_along(tally), tally)), "smooth_vars" = unique(nms_trim), stop2("Bug found: invalid input to 'type' argument.")) } @@ -1575,7 +1576,7 @@ parse_formula_and_data <- function(formula, data) { formula <- validate_formula(formula, needs_response = TRUE) - # All variables of entire formula + # all variables of entire formula allvars <- all.vars(formula) allvars_form <- reformulate(allvars) @@ -1587,10 +1588,10 @@ parse_formula_and_data <- function(formula, data) { rhs <- rhs(formula) # RHS as expression rhs_form <- reformulate_rhs(rhs) # RHS as formula - # Evaluate model data (row subsetting etc) + # evaluate model data (row subsetting etc) data <- make_model_data(allvars_form, data) - # Evaluated response variables + # evaluated response variables surv <- eval(lhs, envir = data) # Surv object surv <- validate_surv(surv) type <- attr(surv, "type") @@ -1629,7 +1630,7 @@ parse_formula_and_data <- function(formula, data) { t_end <- as.vector(surv[, "time1"]) } - # Deal with tde(x, ...) + # deal with tde(x, ...) tde_stuff <- handle_tde(formula, min_t = min_t, max_t = max_t, @@ -1643,10 +1644,10 @@ parse_formula_and_data <- function(formula, data) { tt_calls <- tde_stuff$tt_calls # may be NULL tt_forms <- tde_stuff$tt_forms # may be NULL - # Just fixed-effect part of formula + # just fixed-effect part of formula fe_form <- lme4::nobars(tf_form) - # Just random-effect part of formula + # just random-effect part of formula bars <- lme4::findbars(tf_form) re_parts <- lapply(bars, split_at_bars) re_forms <- fetch(re_parts, "re_form") @@ -1692,7 +1693,7 @@ handle_tde <- function(formula, min_t, max_t, times, status) { sel <- attr(Terms, "specials")$tde # if no tde() terms then just return the fixed effect formula as is - if (is.null(sel)) { + if (!length(sel)) { return(list(tf_form = formula, td_form = NULL, tt_vars = NULL, diff --git a/R/stansurv.R b/R/stansurv.R index 9eaab6d81..78627d4f6 100644 --- a/R/stansurv.R +++ b/R/stansurv.R @@ -36,16 +36,32 @@ stansurv <- function(object) { stan_summary <- make_stan_summary(stanfit) # number of parameters - nvars <- ncol(object$x) + has_intercept(basehaz) + basehaz$nvars + nvars <- + has_intercept(basehaz) + + ncol(object$x) + + ncol(object$s_cpts) + + basehaz$nvars + + nms_beta <- colnames(object$x_cpts) + nms_tde <- get_smooth_name(object$s_cpts, type = "smooth_coefs") + nms_smooth <- get_smooth_name(object$s_cpts, type = "smooth_sd") + nms_int <- get_int_name_basehaz(object$basehaz) + nms_aux <- get_aux_name_basehaz(object$basehaz) + nms_b <- get_b_names(object$group) + nms_vc <- get_varcov_names(object$group) + nms_coefs <- c(nms_int, + nms_beta, + nms_tde, + nms_aux, + nms_b) # obtain medians - coefs <- stan_summary[seq(nvars), select_median(alg)] - coefs_nms <- rownames(stan_summary)[seq(nvars)] - names(coefs) <- coefs_nms # ensure parameter names are retained + coefs <- stan_summary[nms_coefs, select_median(alg)] + names(coefs) <- nms_coefs # ensure parameter names are retained # obtain standard errors and covariance matrix - stanmat <- as.matrix(stanfit)[, seq(nvars), drop = FALSE] - colnames(stanmat) <- coefs_nms + stanmat <- as.matrix(stanfit)[, nms_coefs, drop = FALSE] + colnames(stanmat) <- nms_coefs ses <- apply(stanmat, 2L, mad) covmat <- cov(stanmat) @@ -104,12 +120,12 @@ stansurv <- function(object) { #---------- internal -# Return the model fitting time in minutes. +# Return the model fitting time in seconds # # @param stanfit An object of class 'stanfit'. # @return A matrix of runtimes, stratified by warmup/sampling and chain/overall. get_runtime <- function(stanfit) { tt <- rstan::get_elapsed_time(stanfit) - tt <- round(tt / 60, digits = 1L) # time per chain - tt <- cbind(tt, total = rowSums(tt)) # time per chain & overall + tt <- round(tt, digits = 0L) # time per chain + tt <- cbind(tt, total = rowSums(tt)) # time per chain & overall } diff --git a/tests/testthat/helpers/recover_pars_surv.R b/tests/testthat/helpers/recover_pars_surv.R index fd28e9c7f..24aa5150a 100644 --- a/tests/testthat/helpers/recover_pars_surv.R +++ b/tests/testthat/helpers/recover_pars_surv.R @@ -9,11 +9,22 @@ recover_pars <- function(mod) { cl <- class(mod)[1L] fixef_pars <- switch(cl, - coxph = mod$coefficients, - survreg = mod$coefficients, - stansurv = fixef(mod), + "coxph" = mod$coefficients, + "survreg" = mod$coefficients, + "stansurv" = fixef(mod), NULL) + if (cl == "stansurv") { + sel <- grep(":tde-[a-z][a-z]-coef[0-9]*$", names(fixef_pars)) + # replace stansurv tde names with coxph tt names + if (length(sel)) { + nms <- names(fixef_pars)[sel] + nms <- gsub(":tde-[a-z][a-z]-coef[0-9]*$", "", nms) + nms <- paste0("tt(", nms, ")") + names(fixef_pars)[sel] <- nms + } + } + ret <- Filter(function(x) !is.null(x), list(fixef = fixef_pars)) return(ret) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index e09f80725..d254f3b6a 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -162,6 +162,41 @@ test_that("prior arguments work", { ee(up(testmod, prior_smooth = lasso()), "prior distribution") }) +test_that("tde function works", { + + # single tde call + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1) + x2)) + + # multiple tde calls + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1) + tde(x2))) + + # b-spline and piecewise tde in same model + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "bs") + tde(x2, type = "pw"))) + + # b-spline tde optional arguments + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "bs", knots = c(1,2)) + x2)) + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "bs", df = 4) + x2)) + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "bs", degree = 2) + x2)) + ee(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "bs", junk = 2) + x2), + "Invalid argument to 'tde' function.") + + # piecewise tde optional arguments + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "pw", knots = c(1,2)) + x2)) + es(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "pw", df = 4) + x2)) + ee(up(testmod, formula. = + Surv(eventtime, status) ~ tde(x1, type = "pw", degree = 2) + x2), + "Invalid argument to 'tde' function.") +}) + #---- Compare parameter estimates: stan_surv vs coxph @@ -389,6 +424,39 @@ compare_surv(data = dat, basehaz = "weibull-aft") # coef(v_weib)['sesupper'][[1]], # tol = 0.1), "not equal") +#---- Check tde models against coxph + +#---- piecewise constant + +set.seed(1919002) +covs <- data.frame(id = 1:1000, + X1 = rbinom(1000, 1, 0.3), + X2 = rnorm (1000, 2, 2.0)) +dat <- simsurv(dist = "exponential", + lambdas = 0.1, + betas = c(X1 = 0.3, X2 = -0.3), + x = covs, + tde = c(X1 = -0.6), + tdefun = function(t) as.numeric(t > 10), + maxt = 30) +dat <- merge(dat, covs) + +fmsurv <- Surv(eventtime, status) ~ X1 + tt(X1) + X2 +o<-SW(surv1 <- coxph(fmsurv, dat, tt = function(x, t, ...) { x * as.numeric(t > 10) })) + +fmstan <- Surv(eventtime, status) ~ tde(X1, type = "pw", knots = c(10)) + X2 +o<-SW(stan1 <- stan_surv(fmstan, dat, chains = 1, refresh = 0L, iter = 1000, basehaz = "exp")) + +tols <- get_tols(surv1, tolscales = TOLSCALES) +pars_surv <- recover_pars(surv1) +pars_stan <- recover_pars(stan1) +for (i in names(tols$fixef)) + expect_equal(pars_surv$fixef[[i]], + pars_stan$fixef[[i]], + tol = tols$fixef[[i]], + info = "compare_estimates_tde_pw") + + #-------- Check post-estimation functions work @@ -422,24 +490,32 @@ o<-SW(f12 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt))) o<-SW(f13 <- update(f6, Surv(futimeYears, death) ~ sex + tde(trt))) o<-SW(f14 <- update(f7, Surv(futimeYears, death) ~ sex + tde(trt))) +o<-SW(f15 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) +o<-SW(f16 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) +o<-SW(f17 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) +o<-SW(f18 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) +o<-SW(f19 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) +o<-SW(f20 <- update(f6, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) +o<-SW(f21 <- update(f7, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) + # start-stop notation (incl. delayed entry) -o<-SW(f15 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) -o<-SW(f16 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) -o<-SW(f17 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) -o<-SW(f18 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) +o<-SW(f22 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) +o<-SW(f23 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) +o<-SW(f24 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) +o<-SW(f25 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) # left and interval censoring -o<-SW(f19 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) -o<-SW(f20 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) -o<-SW(f21 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) -o<-SW(f22 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) +o<-SW(f26 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) +o<-SW(f27 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) +o<-SW(f28 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) +o<-SW(f29 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models -for (j in c(1:22)) { +for (j in c(1:29)) { mod <- try(get(paste0("f", j)), silent = TRUE) From a6fe804916265abdb09020800884e1ca3fdb918f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 9 May 2019 17:30:13 +1000 Subject: [PATCH 134/225] Fix small bug in stansurv pp_data --- R/stan_surv.R | 31 +++++++++++++++++++++++-------- R/stansurv.R | 1 + 2 files changed, 24 insertions(+), 8 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 88e15be20..03841d4b0 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -433,7 +433,7 @@ stan_surv <- function(formula, #----- model frame stuff - mf_stuff <- make_model_frame(formula$tf_form, data) + mf_stuff <- make_model_frame(formula$tf_form, data, drop.unused.levels = TRUE) mf <- mf_stuff$mf # model frame mt <- mf_stuff$mt # model terms @@ -2044,29 +2044,42 @@ make_model_data <- function(formula, data) { # # @param formula The parsed model formula. # @param data The model data frame. -# @param xlev Passed to xlev argument of model.frame. +# @param xlevs Passed to xlev argument of model.frame. +# @param drop.unused.levels Passed to drop.unused.levels argument of model.frame. # @param check_constant If TRUE then an error is thrown is the returned # model frame contains any constant variables. # @return A list with the following elements: # mf: the model frame based on the formula. # mt: the model terms associated with the returned model frame. -make_model_frame <- function(formula, data, xlevs = NULL, +make_model_frame <- function(formula, + data, + xlevs = NULL, + drop.unused.levels = FALSE, check_constant = FALSE) { # construct model frame Terms <- terms(lme4::subbars(formula)) - mf <- stats::model.frame(Terms, data, xlev = xlevs, drop.unused.levels = TRUE) + mf <- stats::model.frame(Terms, + data, + xlev = xlevs, + drop.unused.levels = drop.unused.levels) # get predvars for fixed part of formula TermsF <- terms(lme4::nobars(formula)) - mfF <- stats::model.frame(TermsF, data, xlev = xlevs, drop.unused.levels = TRUE) + mfF <- stats::model.frame(TermsF, + data, + xlev = xlevs, + drop.unused.levels = drop.unused.levels) attr(attr(mf, "terms"), "predvars.fixed") <- attr(attr(mfF, "terms"), "predvars") # get predvars for random part of formula has_bars <- length(lme4::findbars(formula)) > 0 if (has_bars) { TermsR <- terms(lme4::subbars(justRE(formula, response = TRUE))) - mfR <- stats::model.frame(TermsR, data, xlev = xlevs, drop.unused.levels = TRUE) + mfR <- stats::model.frame(TermsR, + data, + xlev = xlevs, + drop.unused.levels = drop.unused.levels) attr(attr(mf, "terms"), "predvars.random") <- attr(attr(mfR, "terms"), "predvars") } else { attr(attr(mf, "terms"), "predvars.random") <- NULL @@ -2090,7 +2103,7 @@ make_model_frame <- function(formula, data, xlevs = NULL, # # @param formula The parsed model formula. # @param model_frame The model frame. -# @param xlev Passed to xlev argument of model.frame. +# @param xlevs Passed to xlev argument of model.matrix. # @param check_constant If TRUE then an error is thrown is the returned # predictor matrix contains any constant columns. # @return A named list with the following elements: @@ -2099,7 +2112,9 @@ make_model_frame <- function(formula, data, xlevs = NULL, # x_centered: the fe model matrix, centered. # N: number of rows (observations) in the model matrix. # K: number of cols (predictors) in the model matrix. -make_x <- function(formula, model_frame, xlevs = NULL, +make_x <- function(formula, + model_frame, + xlevs = NULL, check_constant = TRUE) { # uncentred predictor matrix, without intercept diff --git a/R/stansurv.R b/R/stansurv.R index 78627d4f6..faead9fcb 100644 --- a/R/stansurv.R +++ b/R/stansurv.R @@ -83,6 +83,7 @@ stansurv <- function(object) { terms = object$terms, data = object$data, model_frame = object$model_frame, + xlevs = object$xlevels, x = object$x, x_cpts = object$x_cpts, s_cpts = object$s_cpts, From fa0faf0cbda5bf1eea867e584b085d5752377c56 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 10 May 2019 13:14:02 +1000 Subject: [PATCH 135/225] Create make_s function --- R/stan_surv.R | 100 ++++++++++++++++++++++++++++++++++---------------- 1 file changed, 69 insertions(+), 31 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 03841d4b0..d2f2b8559 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -462,12 +462,12 @@ stan_surv <- function(formula, delayed <- as.logical(!t_beg == 0) # time variables for stan - t_event <- t_end[status == 1] # exact event time - t_lcens <- t_end[status == 2] # left censoring time - t_rcens <- t_end[status == 0] # right censoring time - t_icenl <- t_end[status == 3] # lower limit of interval censoring time - t_icenu <- t_upp[status == 3] # upper limit of interval censoring time - t_delay <- t_beg[delayed] # delayed entry time + t_event <- aa(t_end[status == 1]) # exact event time + t_lcens <- aa(t_end[status == 2]) # left censoring time + t_rcens <- aa(t_end[status == 0]) # right censoring time + t_icenl <- aa(t_end[status == 3]) # lower limit of interval censoring time + t_icenu <- aa(t_upp[status == 3]) # upper limit of interval censoring time + t_delay <- aa(t_beg[delayed]) # delayed entry time # calculate log crude event rate t_tmp <- sum(rowMeans(cbind(t_end, t_upp), na.rm = TRUE) - t_beg) @@ -642,19 +642,19 @@ stan_surv <- function(formula, if (has_tde) { # generate a model frame with time transformations for tde effects - mf_tde_times <- make_model_frame(formula$tt_frame, data.frame(times__ = cpts))$mf + mf_tde <- make_model_frame(formula$tt_frame, data.frame(times__ = cpts))$mf # NB next line avoids dropping terms attribute from 'mf_cpts' - mf_cpts[, colnames(mf_tde_times)] <- mf_tde_times + mf_cpts[, colnames(mf_tde)] <- mf_tde } #----- time-fixed predictor matrices ff <- formula$fe_form - x_stuff <- make_x(ff, mf, xlevs = xlevs) - x_cpts <- make_x(ff, mf_cpts, xlevs = xlevs)$x - x_centred <- sweep(x_cpts, 2, x_stuff$x_bar, FUN = "-") + x <- make_x(ff, mf )$x + x_cpts <- make_x(ff, mf_cpts)$x + x_centred <- sweep(x_cpts, 2, colMeans(x), FUN = "-") K <- ncol(x_cpts) if (!has_quadrature) { @@ -686,36 +686,34 @@ stan_surv <- function(formula, if (has_tde) { - s_cpts_parts <- xapply( - formula$tt_vars, - formula$tt_forms, - FUN = function(vn, tt) { - m1 <- make_x(vn, mf_cpts, xlevs = xlevs)$x - m2 <- make_x(tt, mf_cpts, xlevs = xlevs)$x - m3 <- matrix(apply(m1, 2L, `*`, m2), nrow = nrow(m2)) - colnames(m3) <- uapply(colnames(m1), paste, colnames(m2), sep = ":") - return(m3) - }) - formula$tt_ncol <- sapply(s_cpts_parts, ncol) - formula$tt_map <- rep(1:length(formula$tt_ncol), formula$tt_ncol) - s_cpts <- do.call("cbind", s_cpts_parts) + # time-varying predictor matrix + s_cpts <- make_s(formula, mf_cpts, xlevs = xlevs) smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") smooth_idx <- get_idx_array(table(smooth_map)) S <- ncol(s_cpts) # number of tde coefficients + # store some additional information in model formula + # stating how many columns in the predictor matrix + # each tde() term in the model formula corresponds to + formula$tt_ncol <- attr(s_cpts, "tt_ncol") + formula$tt_map <- attr(s_cpts, "tt_map") + } else { - formula$tt_ncol <- integer(0) - formula$tt_map <- integer(0) + # dud entries if no tde() terms in model formula s_cpts <- matrix(0,length(cpts),0) smooth_idx <- matrix(0,0,2) smooth_map <- integer(0) - S <- 0L + S <- 0L + + formula$tt_ncol <- integer(0) + formula$tt_map <- integer(0) } if (has_quadrature) { + # time-varying predictor matrices, with quadrature s_epts_event <- s_cpts[idx_cpts[1,1]:idx_cpts[1,2], , drop = FALSE] s_qpts_event <- s_cpts[idx_cpts[2,1]:idx_cpts[2,2], , drop = FALSE] s_qpts_lcens <- s_cpts[idx_cpts[3,1]:idx_cpts[3,2], , drop = FALSE] @@ -789,7 +787,7 @@ stan_surv <- function(formula, standata <- nlist( K, S, nvars, - x_bar = x_stuff$x_bar, + x_bar = colMeans(x), has_intercept, has_quadrature, smooth_map, @@ -1031,7 +1029,7 @@ stan_surv <- function(formula, } # autoscaling of priors - prior_stuff <- autoscale_prior(prior_stuff, predictors = x_stuff$x) + prior_stuff <- autoscale_prior(prior_stuff, predictors = x) prior_intercept_stuff <- autoscale_prior(prior_intercept_stuff) prior_aux_stuff <- autoscale_prior(prior_aux_stuff) prior_smooth_stuff <- autoscale_prior(prior_smooth_stuff) @@ -1175,7 +1173,7 @@ stan_surv <- function(formula, model_frame = mf, terms = mt, xlevels = .getXlevels(mt, mf), - x = x_stuff$x, + x, x_cpts, s_cpts = if (has_tde) s_cpts else NULL, z_cpts = if (has_bars) z_cpts else NULL, @@ -2114,7 +2112,7 @@ make_model_frame <- function(formula, # K: number of cols (predictors) in the model matrix. make_x <- function(formula, model_frame, - xlevs = NULL, + xlevs = NULL, check_constant = TRUE) { # uncentred predictor matrix, without intercept @@ -2137,6 +2135,46 @@ make_x <- function(formula, nlist(x, x_centered, x_bar, N = NROW(x), K = NCOL(x)) } +# Return the tde predictor matrix +# +# @param formula The parsed model formula. +# @param model_frame The model frame. +# @param xlevs Passed to xlev argument of model.matrix. +# @return A named list with the following elements: +# s: model matrix for time-varying terms, not centered and without intercept. +# tt_ncol: stored attribute, a numeric vector with the number of columns in +# the model matrix that correspond to each tde() term in the original +# model formula. +# tt_map: stored attribute, a numeric vector with indexing for the columns +# of the model matrix stating which tde() term in the original model +# formula they correspond to. +make_s <- function(formula, + model_frame, + xlevs = NULL) { + + # create the design matrix for each tde() term + s_parts <- xapply( + formula$tt_vars, # names of variables with a tde() wrapper + formula$tt_forms, # time-transformation functions to interact them with + FUN = function(vn, tt) { + m1 <- make_x(vn, model_frame, xlevs = xlevs, check_constant = FALSE)$x + m2 <- make_x(tt, model_frame, xlevs = xlevs, check_constant = FALSE)$x + m3 <- matrix(apply(m1, 2L, `*`, m2), nrow = nrow(m2)) + colnames(m3) <- uapply(colnames(m1), paste, colnames(m2), sep = ":") + return(m3) + }) + + # bind columns to form one design matrix for tde() terms + s <- do.call("cbind", s_parts) + + # store indexing of the columns in the design matrix + tt_ncol <- sapply(s_parts, ncol) + tt_map <- rep(seq_along(tt_ncol), tt_ncol) + + # return design matrix with indexing info as an attribute + structure(s, tt_ncol = tt_ncol, tt_map = tt_map) +} + # Check if the only element of a character vector is 'Intercept' # # @param x A character vector. From a2787e313c33c2f46e20fe02a82ec5148480451a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 10 May 2019 13:14:20 +1000 Subject: [PATCH 136/225] Deal with NAs in stansurv pp_data --- R/pp_data.R | 43 +++++++++++++++++++++++++++++-------------- 1 file changed, 29 insertions(+), 14 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index 90cb82656..4f47cec50 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -297,26 +297,16 @@ pp_data <- #----- model frame for generating predictor matrices + # drop response from model terms tt <- delete.response(terms(object, fixed.only = FALSE)) + # make model frame based on time-fixed part of model formula mf <- make_model_frame(tt, newdata, xlevs = object$xlevs)$mf + # if using quadrature then expand rows of time-fixed predictor matrix if (has_quadrature && at_quadpoints) mf <- rep_rows(mf, times = qnodes) - if (has_tde) { - - # formula for generating spline basis for tde effects - bsf <- formula$bs_form - - # generate a model frame with time transformations for tde effects - mf_tde <- make_model_frame(bsf, data.frame(times__ = pts))$mf - - # NB next line avoids dropping terms attribute from 'mf' - mf[, colnames(mf_tde)] <- mf_tde - - } - # check data classes in the model frame match those used in model fitting if (!is.null(cl <- attr(tt, "dataClasses"))) .checkMFClasses(cl, mf) @@ -328,9 +318,34 @@ pp_data <- #----- time-varying predictor matrix if (has_tde) { - s <- make_x(formula$tt_form, mf, check_constant = FALSE)$x + + if (all(is.na(pts))) { + # temporary replacement to avoid error in creating spline basis + pts_tmp <- rep(0, length(pts)) + } else { + # else use prediction times or quadrature points + pts_tmp <- pts + } + + # generate a model frame with time transformations for tde effects + mf_tde <- make_model_frame(formula$tt_frame, data.frame(times__ = pts_tmp))$mf + + # NB next line avoids dropping terms attribute from 'mf' + mf[, colnames(mf_tde)] <- mf_tde + + # construct time-varying predictor matrix + s <- make_s(formula, mf, xlevs = xlevs) + + if (all(is.na(pts))) { + # if pts were all NA then replace the time-varying predictor + # matrix with all NA, but retain appropriate dimensions + s[] <- NaN + } + } else { + s <- matrix(0, nrow(mf), 0) + } #----- random effects predictor matrices From 791f981e42b0a2003557df1e730e225c4225424b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 10 May 2019 13:14:35 +1000 Subject: [PATCH 137/225] Get stansurv loo test passing --- tests/testthat/test_stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index d254f3b6a..1eff18793 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -471,7 +471,7 @@ o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, data = pbcSurv, basehaz = "ms", chains = 1, - iter = 40, + iter = 60, refresh = REFRESH, seed = SEED)) o<-SW(f2 <- update(f1, basehaz = "bs")) @@ -515,7 +515,7 @@ nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models -for (j in c(1:29)) { +for (j in c(15:21)) { mod <- try(get(paste0("f", j)), silent = TRUE) From dbb97f63965a9e836191dfc1daf9f3d22a00bd54 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 10 May 2019 14:36:03 +1000 Subject: [PATCH 138/225] Add a couple of tests for prior_aux in stansurv models --- tests/testthat/test_stan_surv.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 1eff18793..5ffb30035 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -148,9 +148,11 @@ test_that("prior arguments work", { es(up(testmod, prior_intercept = student_t())) es(up(testmod, prior_intercept = cauchy())) - es(up(testmod, prior_aux = normal())) - es(up(testmod, prior_aux = student_t())) - es(up(testmod, prior_aux = cauchy())) + es(up(testmod, prior_aux = dirichlet())) + es(up(testmod, prior_aux = normal(), basehaz = "weibull")) + es(up(testmod, prior_aux = student_t(), basehaz = "weibull")) + es(up(testmod, prior_aux = cauchy(), basehaz = "weibull")) + es(up(testmod, prior_aux = exponential(), basehaz = "weibull")) es(up(testmod, prior_smooth = exponential())) es(up(testmod, prior_smooth = normal())) From c55dc03a51c2ae8f7a3248a247150cf9b6ba919a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 10 May 2019 14:36:43 +1000 Subject: [PATCH 139/225] Fix x_bar for stan_surv when there is just one predictor --- R/stan_surv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index d2f2b8559..9a400ee66 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -787,7 +787,7 @@ stan_surv <- function(formula, standata <- nlist( K, S, nvars, - x_bar = colMeans(x), + x_bar = aa(colMeans(x)), has_intercept, has_quadrature, smooth_map, From 08138dbfb926b89dcc8b58de54cc6c32f92f977c Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 10 May 2019 18:12:13 +1000 Subject: [PATCH 140/225] stan_surv: add an exported tde function with help file --- NAMESPACE | 1 + R/stan_surv.R | 200 +++++++++++++++++++++++++++++++++++++------------- 2 files changed, 150 insertions(+), 51 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f3605003b..44028f756 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -166,6 +166,7 @@ export(stanjm_list) export(stanmvreg_list) export(stanreg_list) export(student_t) +export(tde) export(waic) if(getRversion()>='3.3.0') importFrom(stats, sigma) else importFrom(lme4,sigma) diff --git a/R/stan_surv.R b/R/stan_surv.R index 9a400ee66..3285528af 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -29,11 +29,11 @@ #' either proportional or non-proportional hazards; and #' (iii) standard parametric (exponential, Weibull) accelerated failure time #' models, with covariates included under assumptions of either time-fixed or -#' time-dependent acceleration factors. -#' Where relevant, time-dependent effects (i.e. time-dependent hazard ratios -#' or time-dependent acceleration factors) are modelled using a flexible -#' cubic spline-based function for the time-dependent coefficient in the -#' linear predictor. +#' time-dependent survival time ratios. +#' Where relevant, the user can choose between either a smooth B-spline +#' function or a piecewise constant function for modelling each time-dependent +#' coefficient (i.e. time-dependent log hazard ratio or time-dependent log +#' survival time ratio) in the linear predictor. #' #' @export #' @importFrom splines bs @@ -97,19 +97,18 @@ #' @param basehaz_ops A named list specifying options related to the baseline #' hazard. Currently this can include: \cr #' \itemize{ -#' \item \code{df}: a positive integer specifying the degrees of freedom +#' \item \code{df}: A positive integer specifying the degrees of freedom #' for the M-splines or B-splines. Two boundary knots and \code{df - 3} #' internal knots are used to generate the cubic spline basis. The default #' is \code{df = 5}; that is, two boundary knots and two internal knots. -#' \item \code{knots}: An optional numeric vector specifying internal +#' The internal knots are placed at equally spaced percentiles of the +#' distribution of uncensored event times. +#' \item \code{knots}: A numeric vector explicitly specifying internal #' knot locations for the M-splines or B-splines. Note that \code{knots} -#' cannot be specified if \code{df} is specified. If \code{knots} are -#' \strong{not} specified, then \code{df - 3} internal knots are placed -#' at equally spaced percentiles of the distribution of uncensored event -#' times. +#' cannot be specified if \code{df} is specified. #' } -#' Note that for the M-splines and B-splines - in addition to any internal -#' \code{knots} - a lower boundary knot is placed at the earliest entry time +#' Note that for the M-splines and B-splines -- in addition to any internal +#' \code{knots} -- a lower boundary knot is placed at the earliest entry time #' and an upper boundary knot is placed at the latest event or censoring time. #' These boundary knot locations are the default and cannot be changed by the #' user. @@ -130,18 +129,18 @@ #' #' \strong{Note:} The prior distribution for the intercept is set so it #' applies to the value \emph{when all predictors are centered} and with an -#' adjustment (i.e. "constant shift") equal to the \emph{log crude event rate}. +#' adjustment ("constant shift") equal to the \emph{log crude event rate}. #' However, the reported \emph{estimates} for the intercept always correspond #' to a parameterization without centered predictors and without the #' "constant shift". That is, these adjustments are made internally to help #' with numerical stability and sampling, but the necessary #' back-transformations are made so that they are not relevant for the #' estimates returned to the user. -#' @param prior_aux The prior distribution for "auxiliary" parameters related to -#' the baseline hazard. The relevant parameters differ depending +#' @param prior_aux The prior distribution for "auxiliary" parameters related +#' to the baseline hazard. The relevant parameters differ depending #' on the type of baseline hazard specified in the \code{basehaz} -#' argument. The following applies (however, for further technical details, -#' refer to the \emph{stan_surv: Survival (Time-to-Event) Models vignette)}: +#' argument. The following applies (for further technical details, +#' refer to the \emph{stan_surv: Survival (Time-to-Event) Models vignette}): #' \itemize{ #' \item \code{basehaz = "ms"}: the auxiliary parameters are the #' coefficients for the M-spline basis terms on the baseline hazard. @@ -185,9 +184,13 @@ #' specified in the model (i.e. the \code{tde()} function is used in the #' model formula. When that is the case, \code{prior_smooth} determines the #' prior distribution given to the hyperparameter (standard deviation) -#' contained in a random-walk prior for the cubic B-spline coefficients used -#' to model the time-dependent coefficient. Lower values for the hyperparameter -#' yield a less a flexible smooth function for the time-dependent coefficient. +#' contained in a random-walk prior for the parameters of the function +#' used to generate the time-varying coefficient (i.e. the B-spline +#' coefficients when a B-spline function is used to model the time-varying +#' coefficient, or the deviations in the log hazard ratio specific to each +#' time interval when a piecewise constant function is used to model the +#' time-varying coefficient). Lower values for the hyperparameter +#' yield a less a flexible function for the time-dependent coefficient. #' Specifically, \code{prior_smooth} can be a call to \code{exponential} to #' use an exponential distribution, or \code{normal}, \code{student_t} or #' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy @@ -255,7 +258,7 @@ #' provides more extensive details on the model formulations, including the #' parameterisations for each of the parametric distributions. #' } -#' \subsection{More details on time dependent effects}{ +#' \subsection{Time-dependent effects}{ #' By default, any covariate effects specified in the \code{formula} are #' included in the model under a proportional hazards assumption (for models #' estimated using a hazard scale formulation) or under the assumption of @@ -279,8 +282,9 @@ #' #' A time-dependent effect can be specified in the model \code{formula} #' by wrapping the covariate name in the \code{tde()} function (note that -#' this function is not an exported function, rather it is an internal function -#' that can only be evaluated within the formula of a \code{stan_surv} call). +#' this function is not an exported function, rather it is an internal +#' function that only has meaning when evaluated within the formula of +#' a \code{stan_surv} call). #' #' For example, if we wish to estimate a time-dependent effect for the #' covariate \code{sex} then we can specify \code{tde(sex)} in the @@ -402,7 +406,7 @@ stan_surv <- function(formula, qnodes = 15, prior = normal(), prior_intercept = normal(), - prior_aux = normal(), + prior_aux, prior_smooth = exponential(autoscale = FALSE), prior_covariance = decov(), prior_PD = FALSE, @@ -455,6 +459,9 @@ stan_surv <- function(formula, # event indicator for each row of data status <- make_d(mf) + if (any(is.na(status))) + stop2("Invalid status indicator in Surv object.") + if (any(status < 0 || status > 3)) stop2("Invalid status indicator in Surv object.") @@ -1202,6 +1209,108 @@ stan_surv <- function(formula, } +#' Time-varying effects in Bayesian survival models +#' +#' This is a special function that can be used in the formula of a Bayesian +#' survival model estimated using \code{\link{stan_surv}}. It specifies that a +#' time-varying coefficient should be estimated for the covariate \code{x}. +#' The \code{tde} function only has meaning when evaluated within the formula +#' of a \code{\link{stan_surv}} call and does not have meaning outside of that +#' context. The exported function documented here just returns \code{x}. +#' However, when called internally the \code{tde} function returns several +#' other pieces of useful information used in the model fitting. +#' +#' @export +#' +#' @param x The covariate for which a time-varying coefficient should be +#' estimated. +#' @param type The type of function used to model the time-varying coefficient. +#' Can currently be one of the following: +#' \itemize{ +#' \item \code{"bs"}: A B-spline function. Cubic B-splines by default, but +#' this can be changed by the user via the \code{degree} argument +#' described below. +#' \item \code{"pw"}: A piecewise constant function, with the number of +#' "pieces" or "time intervals" determined by either the \code{df} or +#' \code{knots} arguments described below. +#' } +#' @param df A positive integer specifying the degrees of freedom +#' for the B-splines (when \code{type = "bs"}) or the number of time +#' intervals for the piecewise constant function (when \code{type = "pw"}). +#' When \code{type = "bs"} two boundary knots and \code{df - degree} +#' internal knots are used to generate the B-spline function. +#' When \code{type = "pw"} two boundary knots and \code{df - 1} +#' internal knots are used to generate the piecewise constant function. +#' The internal knots are placed at equally spaced percentiles of the +#' distribution of the uncensored event times. +#' The default is to use \code{df = 3} unless \code{df} or \code{knots} is +#' explicitly specified by the user. +#' @param knots A numeric vector explicitly specifying internal knot +#' locations for the piecewise constant or B-spline function. Note that +#' \code{knots} cannot be specified if \code{df} is specified. Also note +#' that this argument only controls the \emph{internal} knot locations. +#' In addition, boundary knots are placed at the earliest entry time and +#' latest event or censoring time and these cannot be changed by the user. +#' @param degree A positive integer specifying the degree for the B-spline +#' function. The order of the B-spline is equal to \code{degree + 1}. +#' This argument is only relevant for B-splines (i.e. when +#' \code{type = "bs"}) and not for the piecewise constant function (when +#' \code{type = "pw"}). +#' +#' @return The exported \code{tde} function documented here just returns +#' \code{x}. However, when called internally the \code{tde} function returns +#' several other pieces of useful information. For the most part, these are +#' added to the formula element of the returned \code{\link{stanreg}} object +#' (that is \code{object[["formula"]]} where \code{object} is the fitted +#' model). Information added to the formula element of the \code{stanreg} +#' object includes the following: +#' \itemize{ +#' \item \code{tt_vars}: A list with the names of variables in the model +#' formula that were wrapped in the \code{tde} function. +#' \item \code{tt_types}: A list with the \code{type} (e.g. \code{"bs"}, +#' \code{"pw"}) of \code{tde} function corresponding to each variable in +#' \code{tt_vars}. +#' \item \code{tt_calls}: A list with the call required to construct the +#' transformation of time for each variable in \code{tt_vars}. +#' \item \code{tt_forms}: Same as \code{tt_calls} but expressed as formulas. +#' \item \code{tt_frame}: A single formula that can be used to generate a +#' model frame that contains the unique set of transformations of time (e.g. +#' basis terms or dummy indicators) that are required to build all +#' time-varying coefficients in the model. In other words a single formula +#' with the unique element(s) contained in \code{tt_forms}. +#' } +#' +#' @examples +#' # Exported function just returns the input variable +#' identical(pbcSurv$trt, tde(pbcSurv$trt)) +#' +#' # Internally the function returns and stores information +#' # used to form the time-varying coefficient in the model +#' m1 <- stan_surv(Surv(futimeYears, death) ~ tde(trt) + tde(sex, "pw"), +#' data = pbcSurv, chains = 1, iter = 50) +#' m1$formula[grep("^tt_", names(m1$formula))] +#' +tde <- function(x, + type = c("bs", "pw"), + df = NULL, + knots = NULL, + degree = 3L) { + + type <- match.arg(type) + + if (!is.null(df) && !is.null(knots)) + stop("Cannot specify both 'df' and 'knots' in the 'tde' function.") + + if (degree < 1) + stop("In 'tde' function, 'degree' must be positive.") + + if (is.null(df) && is.null(knots)) + df <- 3L + + x +} + + #---------- internal # Construct a list with information about the baseline hazard @@ -1627,6 +1736,12 @@ parse_formula_and_data <- function(formula, data) { status <- as.vector(surv[, "status"]) t_end <- as.vector(surv[, "time1"]) } + + if (any(is.na(status))) + stop2("Invalid status indicator in Surv object.") + + if (any(status < 0 || status > 3)) + stop2("Invalid status indicator in Surv object.") # deal with tde(x, ...) tde_stuff <- handle_tde(formula, @@ -1746,31 +1861,18 @@ handle_tde <- function(formula, min_t, max_t, times, status) { # @param ... Additional arguments passed by the user that control aspects of # the time-varying effect. # @return The call used to construct a time-dependent basis. - tde <- function(x, type = "bs", ...) { - - dots <- list(...) - - df <- dots[["df"]] - knots <- dots[["knots"]] - degree <- dots[["degree"]] - - ok_args <- switch(type, - "bs" = c("df", "knots", "degree"), - "ms" = c("df", "knots", "degree"), - "pw" = c("df", "knots"), - "piecewise" = c("df", "knots"), - stop2("Invalid 'type' argument for the 'tde' function.")) + tde <- function(x, type = c("bs", "pw"), df = NULL, knots = NULL, degree = 3L) { - dots <- validate_tde_args(dots, ok_args = ok_args) + type <- match.arg(type) if (!is.null(df) && !is.null(knots)) - stop2("Cannot specify both 'df' and 'knots' in the 'tde' function.") + stop("Cannot specify both 'df' and 'knots' in the 'tde' function.") - if (is.null(df)) - df <- 3L # assumes no intercept, ignored if the user specified knots - - if (is.null(degree)) - degree <- 3L + if (degree < 1) + stop("In 'tde' function, 'degree' must be positive.") + + if (is.null(df) && is.null(knots)) + df <- 3L # note that times and status are taken from the parent environment tt <- times[status == 1] # uncensored event times @@ -1801,11 +1903,7 @@ handle_tde <- function(formula, min_t, max_t, times, status) { type = type, call = sub("^list\\(", "splines::bs\\(times__, ", safe_deparse(new_args)))) - } else if (type == "ms") { - - stop("Bug found: not yet implemented.") - - } else if (type == "pw" || type == "piecewise") { + } else if (type == "pw") { iknots <- get_iknots(tt, df = df, degree = 1, iknots = knots) From 34ee65f9f182572341175f2cdcad4dfa09308c44 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 10 May 2019 18:20:53 +1000 Subject: [PATCH 141/225] stan_surv: small change to tde documentation --- R/stan_surv.R | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 3285528af..4e207a79c 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1227,10 +1227,10 @@ stan_surv <- function(formula, #' @param type The type of function used to model the time-varying coefficient. #' Can currently be one of the following: #' \itemize{ -#' \item \code{"bs"}: A B-spline function. Cubic B-splines by default, but -#' this can be changed by the user via the \code{degree} argument -#' described below. -#' \item \code{"pw"}: A piecewise constant function, with the number of +#' \item \code{"bs"}: A B-spline function (the default). Note that cubic +#' B-splines are used by default, but this can be changed by the user via the +#' \code{degree} argument described below. +#' \item \code{"pw"}: A piecewise constant function with the number of #' "pieces" or "time intervals" determined by either the \code{df} or #' \code{knots} arguments described below. #' } @@ -1282,14 +1282,15 @@ stan_surv <- function(formula, #' #' @examples #' # Exported function just returns the input variable -#' identical(pbcSurv$trt, tde(pbcSurv$trt)) +#' identical(pbcSurv$trt, tde(pbcSurv$trt)) # returns TRUE #' #' # Internally the function returns and stores information -#' # used to form the time-varying coefficient in the model +#' # used to form the time-varying coefficients in the model #' m1 <- stan_surv(Surv(futimeYears, death) ~ tde(trt) + tde(sex, "pw"), #' data = pbcSurv, chains = 1, iter = 50) -#' m1$formula[grep("^tt_", names(m1$formula))] -#' +#' m1$formula[["tt_vars"]] +#' m1$formula[["tt_forms"]] +#' tde <- function(x, type = c("bs", "pw"), df = NULL, From f36e7f69559c8cf8daa0fe41475cf2f04c7a91cb Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 14 May 2019 12:06:59 +1000 Subject: [PATCH 142/225] Rename tde() as tve() --- R/jm_data_block.R | 2 +- R/jm_make_assoc_parts.R | 2 +- R/log_lik.R | 10 +- R/misc.R | 10 +- R/plots.R | 18 +- R/posterior_survfit.R | 2 +- R/pp_data.R | 12 +- R/stan_surv.R | 236 +++++++++--------- R/stanreg-methods.R | 12 +- R/stansurv.R | 6 +- .../functions/hazard_functions.stan | 2 +- src/stan_files/surv.stan | 50 ++-- tests/testthat/helpers/get_tols_surv.R | 2 +- tests/testthat/helpers/recover_pars_surv.R | 6 +- tests/testthat/test_stan_surv.R | 92 +++---- vignettes/surv.Rmd | 66 ++--- 16 files changed, 264 insertions(+), 264 deletions(-) diff --git a/R/jm_data_block.R b/R/jm_data_block.R index 801492009..656e598fe 100644 --- a/R/jm_data_block.R +++ b/R/jm_data_block.R @@ -1039,7 +1039,7 @@ validate_observation_times <-function(data, eventtimes, id_var, time_var) { # model_frame: The model frame for the fitted Cox model, but with the # subject ID variable also included. # tvc: Logical, if TRUE then a counting type Surv() object was used -# in the fitted Cox model (ie. time varying covariates). +# in the fitted Cox model (ie. time-varying covariates). handle_e_mod <- function(formula, data, qnodes, id_var, y_id_list) { if (!requireNamespace("survival")) stop("the 'survival' package must be installed to use this function") diff --git a/R/jm_make_assoc_parts.R b/R/jm_make_assoc_parts.R index 0efecdf2e..cacf90bf8 100644 --- a/R/jm_make_assoc_parts.R +++ b/R/jm_make_assoc_parts.R @@ -79,7 +79,7 @@ make_assoc_parts <- function(use_function = make_assoc_parts_for_stan, # observation time preceeding the quadrature point are carried forward to # represent the covariate value(s) at the quadrature point. (To avoid # missingness there is no limit on how far forwards or how far backwards - # covariate values can be carried). If no time varying covariates are + # covariate values can be carried). If no time-varying covariates are # present in the longitudinal submodel (other than the time variable) # then nothing is carried forward or backward. dataQ <- rolling_merge(data = newdata, ids = ids, times = times, grps = grps) diff --git a/R/log_lik.R b/R/log_lik.R index 6cf8214b6..db863a04a 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -445,7 +445,7 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { draws$aux <- pars$aux draws$alpha <- pars$alpha draws$beta <- pars$beta - draws$beta_tde <- pars$beta_tde + draws$beta_tve <- pars$beta_tve draws$has_quadrature <- pp$has_quadrature draws$qnodes <- pp$qnodes @@ -612,7 +612,7 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { intercept = draws$alpha) eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) - eta <- eta + linear_predictor(draws$beta_tde, .sdata_surv(data_i)) + eta <- eta + linear_predictor(draws$beta_tve, .sdata_surv(data_i)) eta <- switch(get_basehaz_name(draws$basehaz), "exp-aft" = sweep(eta, 1L, -1, `*`), "weibull-aft" = sweep(eta, 1L, -as.vector(draws$aux), `*`), @@ -1099,7 +1099,7 @@ evaluate_log_survival.matrix <- function(log_haz, qnodes, qwts) { # @param basehaz A list with info about the baseline hazard. # @param aux,intercept A vector or matrix of parameter estimates (MCMC draws). # @param x Predictor matrix. -# @param s Predictor matrix for time-dependent effects. +# @param s Predictor matrix for time-varying effects. # @return A vector or matrix, depending on the input type of aux. evaluate_log_basehaz <- function(times, basehaz, aux, intercept = NULL) { switch(get_basehaz_name(basehaz), @@ -1139,11 +1139,11 @@ log_basehaz_pw <- function(x, coefs, knots) { linear_predictor(coefs, dummy_matrix(x, knots = knots)) } -evaluate_log_haz <- function(times, basehaz, betas, betas_tde, aux, +evaluate_log_haz <- function(times, basehaz, betas, betas_tve, aux, intercept = NULL, x, s = NULL) { eta <- linear_predictor(betas, x) if ((!is.null(s)) && ncol(s)) - eta <- eta + linear_predictor(betas_tde, s) + eta <- eta + linear_predictor(betas_tve, s) eta <- switch(get_basehaz_name(basehaz), "exp-aft" = sweep(eta, 1L, -1, `*`), "weibull-aft" = sweep(eta, 1L, -as.vector(aux), `*`), diff --git a/R/misc.R b/R/misc.R index 04c3f6078..1eaf1a0ab 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1191,7 +1191,7 @@ STOP_arg_required_for_stanmvreg <- function(arg) { # @param arg The argument STOP_id_var_required <- function() { stop2("'id_var' must be specified for models with a start-stop response ", - "or with time dependent effects.") + "or with time-varying effects.") } # Error message when a function is not yet implemented for stanmvreg objects @@ -1334,7 +1334,7 @@ validate_newdatas <- function(object, newdataLong = NULL, newdataEvent = NULL, stop("'newdataEvent' cannot contain NAs.", call. = FALSE) if (!duplicate_ok && any(duplicated(newdataEvent[[id_var]]))) stop("'newdataEvent' should only contain one row per individual, since ", - "time varying covariates are not allowed in the prediction data.") + "time-varying covariates are not allowed in the prediction data.") newdatas <- c(newdatas, list(Event = newdataEvent)) } if (length(newdatas)) { @@ -1493,16 +1493,16 @@ extract_pars.stansurv <- function(object, stanmat = NULL, means = FALSE) { if (means) stanmat <- t(colMeans(stanmat)) # return posterior means nms_beta <- colnames(object$x) - nms_tde <- get_smooth_name(object$s_cpts, type = "smooth_coefs") + nms_tve <- get_smooth_name(object$s_cpts, type = "smooth_coefs") nms_smth <- get_smooth_name(object$s_cpts, type = "smooth_sd") nms_int <- get_int_name_basehaz(object$basehaz) nms_aux <- get_aux_name_basehaz(object$basehaz) alpha <- stanmat[, nms_int, drop = FALSE] beta <- stanmat[, nms_beta, drop = FALSE] - beta_tde <- stanmat[, nms_tde, drop = FALSE] + beta_tve <- stanmat[, nms_tve, drop = FALSE] aux <- stanmat[, nms_aux, drop = FALSE] smooth <- stanmat[, nms_smth, drop = FALSE] - nlist(alpha, beta, beta_tde, aux, smooth, stanmat) + nlist(alpha, beta, beta_tve, aux, smooth, stanmat) } extract_pars.stanmvreg <- function(object, stanmat = NULL, means = FALSE) { diff --git a/R/plots.R b/R/plots.R index 1b6b60f50..4cf597d11 100644 --- a/R/plots.R +++ b/R/plots.R @@ -40,8 +40,8 @@ #' available MCMC functions see \code{\link[bayesplot]{available_mcmc}}. #' For the \code{stansurv} method, one can also specify #' \code{plotfun = "basehaz"} for a plot of the estimated baseline hazard -#' function, or \code{plot = "tde"} for a plot of the time-dependent -#' hazard ratio (if time-dependent effects were specified in the model). +#' function, or \code{plot = "tve"} for a plot of the time-varying +#' hazard ratio (if time-varying effects were specified in the model). #' #' @param ... Additional arguments to pass to \code{plotfun} for customizing the #' plot. These are described on the help pages for the individual plotting @@ -192,7 +192,7 @@ plot.stanreg <- function(x, plotfun = "intervals", pars = NULL, #' @param limits A quoted character string specifying the type of limits to #' include in the plot. Can be \code{"ci"} for the Bayesian posterior #' uncertainty interval, or \code{"none"}. This argument is only relevant -#' when \code{plotfun = "basehaz"} or \code{plotfun = "tde"} +#' when \code{plotfun = "basehaz"} or \code{plotfun = "tve"} #' plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, regex_pars = NULL, ..., prob = 0.95, @@ -203,7 +203,7 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, limits <- match.arg(limits) - if (plotfun %in% c("basehaz", "tde")) { + if (plotfun %in% c("basehaz", "tve")) { stanpars <- extract_pars(x) has_intercept <- check_for_intercept(x$basehaz) @@ -232,10 +232,10 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, ylab <- "Baseline hazard rate" xlab <- "Time" - } else if (plotfun == "tde") { + } else if (plotfun == "tve") { - if (!x$has_tde) - stop2("Model does not have time-dependent effects.") + if (!x$has_tve) + stop2("Model does not have time-varying effects.") smooth_map <- get_smooth_name(x$s_cpts, type = "smooth_map") smooth_vars <- get_smooth_name(x$s_cpts, type = "smooth_vars") @@ -246,13 +246,13 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, if (length(pars) > 1L) stop2("Only one variable can be specified in 'pars' .") if (!pars %in% smooth_vars) - stop2("Cannot find variable '", pars, "' amongst the tde terms.") + stop2("Cannot find variable '", pars, "' amongst the tve terms.") sel1 <- which(smooth_vars == pars) sel2 <- smooth_coefs[smooth_map == sel1] betas_tf <- stanpars$beta [, pars, drop = FALSE] - betas_td <- stanpars$beta_tde[, sel2, drop = FALSE] + betas_td <- stanpars$beta_tve[, sel2, drop = FALSE] betas <- cbind(betas_tf, betas_td) tt_varid <- unique(x$formula$tt_map[smooth_map == sel1]) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index bab597901..5fca39148 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -829,7 +829,7 @@ posterior_survfit.stanjm <- function(object, args <- nlist(basehaz = get_basehaz(object), intercept = pars$alpha, betas = pars$beta, - betas_tde = pars$beta_tde, + betas_tve = pars$beta_tve, aux = pars$aux, times = data$pts, x = data$x, diff --git a/R/pp_data.R b/R/pp_data.R index 4f47cec50..e52196a1c 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -257,7 +257,7 @@ pp_data <- newdata <- get_model_data(object) # flags - has_tde <- object$has_tde + has_tve <- object$has_tve has_quadrature <- object$has_quadrature has_bars <- object$has_bars @@ -317,7 +317,7 @@ pp_data <- #----- time-varying predictor matrix - if (has_tde) { + if (has_tve) { if (all(is.na(pts))) { # temporary replacement to avoid error in creating spline basis @@ -327,11 +327,11 @@ pp_data <- pts_tmp <- pts } - # generate a model frame with time transformations for tde effects - mf_tde <- make_model_frame(formula$tt_frame, data.frame(times__ = pts_tmp))$mf + # generate a model frame with time transformations for tve effects + mf_tve <- make_model_frame(formula$tt_frame, data.frame(times__ = pts_tmp))$mf # NB next line avoids dropping terms attribute from 'mf' - mf[, colnames(mf_tde)] <- mf_tde + mf[, colnames(mf_tve)] <- mf_tve # construct time-varying predictor matrix s <- make_s(formula, mf, xlevs = xlevs) @@ -365,7 +365,7 @@ pp_data <- s, z, has_quadrature, - has_tde, + has_tve, has_bars, at_quadpoints, qnodes = object$qnodes)) diff --git a/R/stan_surv.R b/R/stan_surv.R index 4e207a79c..b21a3520b 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -29,10 +29,10 @@ #' either proportional or non-proportional hazards; and #' (iii) standard parametric (exponential, Weibull) accelerated failure time #' models, with covariates included under assumptions of either time-fixed or -#' time-dependent survival time ratios. +#' time-varying survival time ratios. #' Where relevant, the user can choose between either a smooth B-spline -#' function or a piecewise constant function for modelling each time-dependent -#' coefficient (i.e. time-dependent log hazard ratio or time-dependent log +#' function or a piecewise constant function for modelling each time-varying +#' coefficient (i.e. time-varying log hazard ratio or time-varying log #' survival time ratio) in the linear predictor. #' #' @export @@ -50,12 +50,12 @@ #' object. Left censored, right censored, and interval censored data #' are allowed, as well as delayed entry (i.e. left truncation). See #' \code{\link[survival]{Surv}} for how to specify these outcome types. -#' If you wish to include time-dependent effects (i.e. time-dependent +#' If you wish to include time-varying effects (i.e. time-varying #' coefficients, e.g. non-proportional hazards) in the model -#' then any covariate(s) that you wish to estimate a time-dependent -#' coefficient for should be specified as \code{tde(varname)} where +#' then any covariate(s) that you wish to estimate a time-varying +#' coefficient for should be specified as \code{tve(varname)} where #' \code{varname} is the name of the covariate. See the \strong{Details} -#' section for more information on how the time-dependent effects are +#' section for more information on how the time-varying effects are #' formulated, as well as the \strong{Examples} section. #' @param data A data frame containing the variables specified in #' \code{formula}. @@ -70,7 +70,7 @@ #' to time. If the model does \emph{not} include any time-dependendent #' effects then a closed form solution is available for both the hazard #' and cumulative hazard and so this approach should be relatively fast. -#' On the other hand, if the model does include time-dependent effects then +#' On the other hand, if the model does include time-varying effects then #' quadrature is used to evaluate the cumulative hazard at each MCMC #' iteration and, therefore, estimation of the model will be slower. #' \item \code{"bs"}: a flexible parametric model using cubic B-splines to @@ -78,9 +78,9 @@ #' internal knots, as well as the basis terms for the splines, are calculated #' with respect to time. A closed form solution for the cumulative hazard #' is \strong{not} available regardless of whether or not the model includes -#' time-dependent effects; instead, quadrature is used to evaluate +#' time-varying effects; instead, quadrature is used to evaluate #' the cumulative hazard at each MCMC iteration. Therefore, if your model -#' does not include any time-dependent effects, then estimation using the +#' does not include any time-varying effects, then estimation using the #' \code{"ms"} baseline hazard will be faster. #' \item \code{"exp"}: an exponential distribution for the event times #' (i.e. a constant baseline hazard). @@ -114,7 +114,7 @@ #' user. #' @param qnodes The number of nodes to use for the Gauss-Kronrod quadrature #' that is used to evaluate the cumulative hazard when \code{basehaz = "bs"} -#' or when time-dependent effects (i.e. non-proportional hazards) are +#' or when time-varying effects (i.e. non-proportional hazards) are #' specified. Options are 15 (the default), 11 or 7. #' @param prior_intercept The prior distribution for the intercept in the #' linear predictor. All models include an intercept parameter. @@ -180,8 +180,8 @@ #' all prior distributions are allowed with all types of baseline hazard. #' To omit a prior ---i.e., to use a flat (improper) uniform prior--- set #' \code{prior_aux} to \code{NULL}. -#' @param prior_smooth This is only relevant when time-dependent effects are -#' specified in the model (i.e. the \code{tde()} function is used in the +#' @param prior_smooth This is only relevant when time-varying effects are +#' specified in the model (i.e. the \code{tve()} function is used in the #' model formula. When that is the case, \code{prior_smooth} determines the #' prior distribution given to the hyperparameter (standard deviation) #' contained in a random-walk prior for the parameters of the function @@ -190,14 +190,14 @@ #' coefficient, or the deviations in the log hazard ratio specific to each #' time interval when a piecewise constant function is used to model the #' time-varying coefficient). Lower values for the hyperparameter -#' yield a less a flexible function for the time-dependent coefficient. +#' yield a less a flexible function for the time-varying coefficient. #' Specifically, \code{prior_smooth} can be a call to \code{exponential} to #' use an exponential distribution, or \code{normal}, \code{student_t} or #' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy #' prior. See \code{\link{priors}} for details on these functions. To omit a #' prior ---i.e., to use a flat (improper) uniform prior--- set #' \code{prior_smooth} to \code{NULL}. The number of hyperparameters depends -#' on the model specification (i.e. the number of time-dependent effects +#' on the model specification (i.e. the number of time-varying effects #' specified in the model) but a scalar prior will be recylced as necessary #' to the appropriate length. #' @@ -208,15 +208,15 @@ #' a vector of covariates for individual \eqn{i}, \eqn{\beta} a vector of #' coefficients, \eqn{S_i(t)} the survival probability for individual #' \eqn{i} at time \eqn{t}, and \eqn{S_0(t)} the baseline survival -#' probability at time \eqn{t}. Without time-dependent effects in the +#' probability at time \eqn{t}. Without time-varying effects in the #' model formula our linear predictor is \eqn{\eta_i = X_i \beta}, whereas -#' with time-dependent effects in the model formula our linear predictor +#' with time-varying effects in the model formula our linear predictor #' is \eqn{\eta_i(t) = X_i(t) \beta(t)}. Then the following definitions of #' the hazard function and survival function apply: #' #' \tabular{llll}{ #' \strong{Scale } \tab -#' \strong{TDE } \tab +#' \strong{tve } \tab #' \strong{Hazard } \tab #' \strong{Survival } \cr #' \emph{Hazard} \tab @@ -238,13 +238,13 @@ #' } #' #' where \emph{AFT} stands for an accelerated failure time formulation, -#' and \emph{TDE} stands for time dependent effects in the model formula. +#' and \emph{tve} stands for time-varying effects in the model formula. #' -#' For models without time-dependent effects, the value of \eqn{S_i(t)} can +#' For models without time-varying effects, the value of \eqn{S_i(t)} can #' be calculated analytically (with the one exception being when B-splines #' are used to model the log baseline hazard, i.e. \code{basehaz = "bs"}). #' -#' For models with time-dependent effects \eqn{S_i(t)} cannot be calculated +#' For models with time-varying effects \eqn{S_i(t)} cannot be calculated #' analytically and so Gauss-Kronrod quadrature is used to approximate the #' relevant integral. The number of nodes used in the quadrature can be #' controlled via the \code{nodes} argument. @@ -258,37 +258,37 @@ #' provides more extensive details on the model formulations, including the #' parameterisations for each of the parametric distributions. #' } -#' \subsection{Time-dependent effects}{ +#' \subsection{time-varying effects}{ #' By default, any covariate effects specified in the \code{formula} are #' included in the model under a proportional hazards assumption (for models #' estimated using a hazard scale formulation) or under the assumption of #' time-fixed acceleration factors (for models estimated using an accelerated #' failure time formulation). To relax this assumption, it is possible to -#' estimate a time-dependent coefficient for a given covariate. Note the +#' estimate a time-varying coefficient for a given covariate. Note the #' following: #' #' \itemize{ -#' \item Estimating a time-dependent coefficient under a hazard scale model +#' \item Estimating a time-varying coefficient under a hazard scale model #' formulation (i.e. when \code{basehaz} is set equal to \code{"ms"}, #' \code{"bs"}, \code{"exp"}, \code{"weibull"} or \code{"gompertz"}) leads -#' to the estimation of a time-dependent hazard ratio for the relevant +#' to the estimation of a time-varying hazard ratio for the relevant #' covariate (i.e. non-proportional hazards). -#' \item Estimating a time-dependent coefficient under an accelerated failure +#' \item Estimating a time-varying coefficient under an accelerated failure #' time model formulation (i.e. when \code{basehaz} is set equal to #' \code{"exp-aft"}, or \code{"weibull-aft"}) leads to the estimation of a -#' time-dependent acceleration factor -- or equivalently, a -#' time-dependent survival time ratio -- for the relevant covariate. +#' time-varying acceleration factor -- or equivalently, a +#' time-varying survival time ratio -- for the relevant covariate. #' } #' -#' A time-dependent effect can be specified in the model \code{formula} -#' by wrapping the covariate name in the \code{tde()} function (note that +#' A time-varying effect can be specified in the model \code{formula} +#' by wrapping the covariate name in the \code{tve()} function (note that #' this function is not an exported function, rather it is an internal #' function that only has meaning when evaluated within the formula of #' a \code{stan_surv} call). #' -#' For example, if we wish to estimate a time-dependent effect for the -#' covariate \code{sex} then we can specify \code{tde(sex)} in the -#' \code{formula}, e.g. \code{Surv(time, status) ~ tde(sex) + age + trt}. +#' For example, if we wish to estimate a time-varying effect for the +#' covariate \code{sex} then we can specify \code{tve(sex)} in the +#' \code{formula}, e.g. \code{Surv(time, status) ~ tve(sex) + age + trt}. #' The coefficient for \code{sex} will then be modelled #' using a flexible smooth function based on a cubic B-spline expansion of #' time. @@ -296,26 +296,26 @@ #' The flexibility of the smooth function can be controlled in two ways: #' \itemize{ #' \item First, through control of the prior distribution for the cubic B-spline -#' coefficients that are used to model the time-dependent coefficient. +#' coefficients that are used to model the time-varying coefficient. #' Specifically, one can control the flexibility of the prior through #' the hyperparameter (standard deviation) of the random walk prior used #' for the B-spline coefficients; see the \code{prior_smooth} argument. #' \item Second, one can increase or decrease the number of degrees of #' freedom used for the cubic B-spline function that is used to model the -#' time-dependent coefficient. By default the cubic B-spline basis is +#' time-varying coefficient. By default the cubic B-spline basis is #' evaluated using 3 degrees of freedom (that is a cubic spline basis with #' boundary knots at the limits of the time range, but no internal knots). #' If you wish to increase the flexibility of the smooth function by using a #' greater number of degrees of freedom, then you can specify this as part -#' of the \code{tde} function call in the model formula. For example, to +#' of the \code{tve} function call in the model formula. For example, to #' use cubic B-splines with 7 degrees of freedom we could specify -#' \code{tde(sex, df = 7)} in the model formula instead of just -#' \code{tde(sex)}. See the \strong{Examples} section below for more +#' \code{tve(sex, df = 7)} in the model formula instead of just +#' \code{tve(sex)}. See the \strong{Examples} section below for more #' details. #' } -#' In practice, the default \code{tde()} function should provide sufficient -#' flexibility for model most time-dependent effects. However, it is worth -#' noting that the reliable estimation of a time-dependent effect usually +#' In practice, the default \code{tve()} function should provide sufficient +#' flexibility for model most time-varying effects. However, it is worth +#' noting that the reliable estimation of a time-varying effect usually #' requires a relatively large number of events in the data (e.g. >1000). #' } #' @@ -362,14 +362,14 @@ #' d3 <- simsurv(lambdas = 0.1, #' gammas = 1.5, #' betas = c(trt = -0.5), -#' tde = c(trt = 0.2), +#' tve = c(trt = 0.2), #' x = covs, #' maxt = 5) #' d3 <- merge(d3, covs) -#' m3 <- stan_surv(Surv(eventtime, status) ~ tde(trt), +#' m3 <- stan_surv(Surv(eventtime, status) ~ tve(trt), #' data = d3, chains = 1, refresh = 0, iter = 600) #' print(m3, 4) -#' plot(m3, "tde") # time-dependent hazard ratio +#' plot(m3, "tve") # time-varying hazard ratio #' #' #---------- Compare PH and AFT parameterisations #' @@ -516,14 +516,14 @@ stan_surv <- function(formula, #----- define dimensions and times for quadrature - # flag if formula uses time-dependent effects - has_tde <- !is.null(formula$td_form) + # flag if formula uses time-varying effects + has_tve <- !is.null(formula$td_form) # flag if closed form available for cumulative baseline hazard has_closed_form <- check_for_closed_form(basehaz) # flag for quadrature - has_quadrature <- has_tde || !has_closed_form + has_quadrature <- has_tve || !has_closed_form if (has_quadrature) { # model uses quadrature @@ -646,13 +646,13 @@ stan_surv <- function(formula, } - if (has_tde) { + if (has_tve) { - # generate a model frame with time transformations for tde effects - mf_tde <- make_model_frame(formula$tt_frame, data.frame(times__ = cpts))$mf + # generate a model frame with time transformations for tve effects + mf_tve <- make_model_frame(formula$tt_frame, data.frame(times__ = cpts))$mf # NB next line avoids dropping terms attribute from 'mf_cpts' - mf_cpts[, colnames(mf_tde)] <- mf_tde + mf_cpts[, colnames(mf_tve)] <- mf_tve } @@ -691,23 +691,23 @@ stan_surv <- function(formula, #----- time-varying predictor matrices - if (has_tde) { + if (has_tve) { # time-varying predictor matrix s_cpts <- make_s(formula, mf_cpts, xlevs = xlevs) smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") smooth_idx <- get_idx_array(table(smooth_map)) - S <- ncol(s_cpts) # number of tde coefficients + S <- ncol(s_cpts) # number of tve coefficients # store some additional information in model formula # stating how many columns in the predictor matrix - # each tde() term in the model formula corresponds to + # each tve() term in the model formula corresponds to formula$tt_ncol <- attr(s_cpts, "tt_ncol") formula$tt_map <- attr(s_cpts, "tt_map") } else { - # dud entries if no tde() terms in model formula + # dud entries if no tve() terms in model formula s_cpts <- matrix(0,length(cpts),0) smooth_idx <- matrix(0,0,2) smooth_map <- integer(0) @@ -1117,7 +1117,7 @@ stan_surv <- function(formula, # specify parameters for stan to monitor stanpars <- c(if (standata$has_intercept) "alpha", if (standata$K) "beta", - if (standata$S) "beta_tde", + if (standata$S) "beta_tve", if (standata$S) "smooth_sd", if (standata$nvars) "aux", if (standata$t) "b", @@ -1152,7 +1152,7 @@ stan_surv <- function(formula, # define new parameter names nms_beta <- colnames(x_cpts) # may be NULL - nms_tde <- get_smooth_name(s_cpts, type = "smooth_coefs") # may be NULL + nms_tve <- get_smooth_name(s_cpts, type = "smooth_coefs") # may be NULL nms_smooth <- get_smooth_name(s_cpts, type = "smooth_sd") # may be NULL nms_int <- get_int_name_basehaz(basehaz) nms_aux <- get_aux_name_basehaz(basehaz) @@ -1160,7 +1160,7 @@ stan_surv <- function(formula, nms_vc <- get_varcov_names(group) # may be NULL nms_all <- c(nms_int, nms_beta, - nms_tde, + nms_tve, nms_smooth, nms_aux, nms_b, @@ -1173,7 +1173,7 @@ stan_surv <- function(formula, # return an object of class 'stansurv' fit <- nlist(stanfit, formula, - has_tde, + has_tve, has_quadrature, has_bars, data, @@ -1182,7 +1182,7 @@ stan_surv <- function(formula, xlevels = .getXlevels(mt, mf), x, x_cpts, - s_cpts = if (has_tde) s_cpts else NULL, + s_cpts = if (has_tve) s_cpts else NULL, z_cpts = if (has_bars) z_cpts else NULL, cnms = if (has_bars) group_unpadded$cnms else NULL, flist = if (has_bars) group_unpadded$flist else NULL, @@ -1214,10 +1214,10 @@ stan_surv <- function(formula, #' This is a special function that can be used in the formula of a Bayesian #' survival model estimated using \code{\link{stan_surv}}. It specifies that a #' time-varying coefficient should be estimated for the covariate \code{x}. -#' The \code{tde} function only has meaning when evaluated within the formula +#' The \code{tve} function only has meaning when evaluated within the formula #' of a \code{\link{stan_surv}} call and does not have meaning outside of that #' context. The exported function documented here just returns \code{x}. -#' However, when called internally the \code{tde} function returns several +#' However, when called internally the \code{tve} function returns several #' other pieces of useful information used in the model fitting. #' #' @export @@ -1257,8 +1257,8 @@ stan_surv <- function(formula, #' \code{type = "bs"}) and not for the piecewise constant function (when #' \code{type = "pw"}). #' -#' @return The exported \code{tde} function documented here just returns -#' \code{x}. However, when called internally the \code{tde} function returns +#' @return The exported \code{tve} function documented here just returns +#' \code{x}. However, when called internally the \code{tve} function returns #' several other pieces of useful information. For the most part, these are #' added to the formula element of the returned \code{\link{stanreg}} object #' (that is \code{object[["formula"]]} where \code{object} is the fitted @@ -1266,9 +1266,9 @@ stan_surv <- function(formula, #' object includes the following: #' \itemize{ #' \item \code{tt_vars}: A list with the names of variables in the model -#' formula that were wrapped in the \code{tde} function. +#' formula that were wrapped in the \code{tve} function. #' \item \code{tt_types}: A list with the \code{type} (e.g. \code{"bs"}, -#' \code{"pw"}) of \code{tde} function corresponding to each variable in +#' \code{"pw"}) of \code{tve} function corresponding to each variable in #' \code{tt_vars}. #' \item \code{tt_calls}: A list with the call required to construct the #' transformation of time for each variable in \code{tt_vars}. @@ -1282,16 +1282,16 @@ stan_surv <- function(formula, #' #' @examples #' # Exported function just returns the input variable -#' identical(pbcSurv$trt, tde(pbcSurv$trt)) # returns TRUE +#' identical(pbcSurv$trt, tve(pbcSurv$trt)) # returns TRUE #' #' # Internally the function returns and stores information #' # used to form the time-varying coefficients in the model -#' m1 <- stan_surv(Surv(futimeYears, death) ~ tde(trt) + tde(sex, "pw"), +#' m1 <- stan_surv(Surv(futimeYears, death) ~ tve(trt) + tve(sex, "pw"), #' data = pbcSurv, chains = 1, iter = 50) #' m1$formula[["tt_vars"]] #' m1$formula[["tt_forms"]] #' -tde <- function(x, +tve <- function(x, type = c("bs", "pw"), df = NULL, knots = NULL, @@ -1300,10 +1300,10 @@ tde <- function(x, type <- match.arg(type) if (!is.null(df) && !is.null(knots)) - stop("Cannot specify both 'df' and 'knots' in the 'tde' function.") + stop("Cannot specify both 'df' and 'knots' in the 'tve' function.") if (degree < 1) - stop("In 'tde' function, 'degree' must be positive.") + stop("In 'tve' function, 'degree' must be positive.") if (is.null(df) && is.null(knots)) df <- 3L @@ -1517,9 +1517,9 @@ has_intercept <- function(basehaz) { "bs")) } -# Return the name of the tde spline coefs or smoothing parameters. +# Return the name of the tve spline coefs or smoothing parameters. # -# @param x The predictor matrix for the time-dependent effects, with column names. +# @param x The predictor matrix for the time-varying effects, with column names. # @param type The type of information about the smoothing parameters to return. # @return A character or numeric vector, depending on 'type'. get_smooth_name <- function(x, type = "smooth_coefs") { @@ -1528,10 +1528,10 @@ get_smooth_name <- function(x, type = "smooth_coefs") { return(NULL) nms <- colnames(x) - nms <- gsub(":splines::bs\\(times__.*\\)[0-9]*$", ":tde-bs-coef", nms) - nms <- gsub(":base::cut\\(times__.*\\]$", ":tde-pw-coef", nms) + nms <- gsub(":splines::bs\\(times__.*\\)[0-9]*$", ":tve-bs-coef", nms) + nms <- gsub(":base::cut\\(times__.*\\]$", ":tve-pw-coef", nms) - nms_trim <- gsub(":tde-[a-z][a-z]-coef[0-9]*$", "", nms) + nms_trim <- gsub(":tve-[a-z][a-z]-coef[0-9]*$", "", nms) tally <- table(nms_trim) indices <- uapply(tally, seq_len) @@ -1744,19 +1744,19 @@ parse_formula_and_data <- function(formula, data) { if (any(status < 0 || status > 3)) stop2("Invalid status indicator in Surv object.") - # deal with tde(x, ...) - tde_stuff <- handle_tde(formula, + # deal with tve(x, ...) + tve_stuff <- handle_tve(formula, min_t = min_t, max_t = max_t, times = t_end, status = status) - tf_form <- tde_stuff$tf_form - td_form <- tde_stuff$td_form # may be NULL - tt_vars <- tde_stuff$tt_vars # may be NULL - tt_frame <- tde_stuff$tt_frame # may be NULL - tt_types <- tde_stuff$tt_types # may be NULL - tt_calls <- tde_stuff$tt_calls # may be NULL - tt_forms <- tde_stuff$tt_forms # may be NULL + tf_form <- tve_stuff$tf_form + td_form <- tve_stuff$td_form # may be NULL + tt_vars <- tve_stuff$tt_vars # may be NULL + tt_frame <- tve_stuff$tt_frame # may be NULL + tt_types <- tve_stuff$tt_types # may be NULL + tt_calls <- tve_stuff$tt_calls # may be NULL + tt_forms <- tve_stuff$tt_forms # may be NULL # just fixed-effect part of formula fe_form <- lme4::nobars(tf_form) @@ -1793,20 +1793,20 @@ parse_formula_and_data <- function(formula, data) { surv_type = attr(surv, "type")) } -# Handle the 'tde(x, ...)' terms in the model formula +# Handle the 'tve(x, ...)' terms in the model formula # # @param Terms terms object for the fixed effect part of the model formula. # @return A named list with the following elements: # -handle_tde <- function(formula, min_t, max_t, times, status) { +handle_tve <- function(formula, min_t, max_t, times, status) { # extract terms objects for fixed effect part of model formula - Terms <- delete.response(terms(lme4::nobars(formula), specials = "tde")) + Terms <- delete.response(terms(lme4::nobars(formula), specials = "tve")) - # check which fixed effect terms have a tde() wrapper - sel <- attr(Terms, "specials")$tde + # check which fixed effect terms have a tve() wrapper + sel <- attr(Terms, "specials")$tve - # if no tde() terms then just return the fixed effect formula as is + # if no tve() terms then just return the fixed effect formula as is if (!length(sel)) { return(list(tf_form = formula, td_form = NULL, @@ -1818,14 +1818,14 @@ handle_tde <- function(formula, min_t, max_t, times, status) { # otherwise extract rhs of formula all_vars <- rownames(attr(Terms, "factors")) # all variables in fe formula - tde_vars <- all_vars[sel] # variables with a tde() wrapper + tve_vars <- all_vars[sel] # variables with a tve() wrapper - # replace 'tde(x, ...)' in formula with 'x' + # replace 'tve(x, ...)' in formula with 'x' old_vars <- all_vars new_vars <- sapply(old_vars, function(x) { - if (x %in% tde_vars) { - # strip tde() from variable - tde <- function(y, ...) { safe_deparse(substitute(y)) } # define locally + if (x %in% tve_vars) { + # strip tve() from variable + tve <- function(y, ...) { safe_deparse(substitute(y)) } # define locally return(eval(parse(text = x))) } else { # just return variable @@ -1846,7 +1846,7 @@ handle_tde <- function(formula, min_t, max_t, times, status) { } } - # extract 'tde(x, ...)' from formula and return '~ x' and '~ bs(times, ...)' + # extract 'tve(x, ...)' from formula and return '~ x' and '~ bs(times, ...)' idx <- 1 tt_vars <- list() tt_types <- list() @@ -1854,23 +1854,23 @@ handle_tde <- function(formula, min_t, max_t, times, status) { for (i in seq_along(sel)) { - # define tde() function locally; uses objects from the parent environment + # define tve() function locally; uses objects from the parent environment # # @param x The variable the time-varying effect is going to be applied to. # @param type Character string, the type of time-varying effect to use. Can # currently be one of: bs, ms, pw. # @param ... Additional arguments passed by the user that control aspects of # the time-varying effect. - # @return The call used to construct a time-dependent basis. - tde <- function(x, type = c("bs", "pw"), df = NULL, knots = NULL, degree = 3L) { + # @return The call used to construct a time-varying basis. + tve <- function(x, type = c("bs", "pw"), df = NULL, knots = NULL, degree = 3L) { type <- match.arg(type) if (!is.null(df) && !is.null(knots)) - stop("Cannot specify both 'df' and 'knots' in the 'tde' function.") + stop("Cannot specify both 'df' and 'knots' in the 'tve' function.") if (degree < 1) - stop("In 'tde' function, 'degree' must be positive.") + stop("In 'tve' function, 'degree' must be positive.") if (is.null(df) && is.null(knots)) df <- 3L @@ -1879,16 +1879,16 @@ handle_tde <- function(formula, min_t, max_t, times, status) { tt <- times[status == 1] # uncensored event times if (is.null(knots) && !length(tt)) { warning2("No observed events found in the data. Censoring times will ", - "be used to evaluate default knot locations for tde().") + "be used to evaluate default knot locations for tve().") tt <- times } # note that min_t and max_t are taken from the parent environment if (!is.null(knots)) { if (any(knots < min_t)) - stop2("In tde(), 'knots' cannot be placed before the earliest entry time.") + stop2("In tve(), 'knots' cannot be placed before the earliest entry time.") if (any(knots > max_t)) - stop2("In tde(), 'knots' cannot be placed beyond the latest event time.") + stop2("In tve(), 'knots' cannot be placed beyond the latest event time.") } if (type == "bs") { @@ -1936,16 +1936,16 @@ handle_tde <- function(formula, min_t, max_t, times, status) { tf_terms <- c(tf_terms, re_terms) } - # formula with all variables but no 'tde(x, ...)' wrappers + # formula with all variables but no 'tve(x, ...)' wrappers tf_form <- reformulate(tf_terms, response = lhs(formula)) - # formula with only tde variables but no 'tde(x, ...)' wrappers + # formula with only tve variables but no 'tve(x, ...)' wrappers td_form <- reformulate(td_terms, response = lhs(formula)) - # unique set of '~ bs(times__, ...)' calls based on all 'tde(x, ...)' terms + # unique set of '~ bs(times__, ...)' calls based on all 'tve(x, ...)' terms tt_frame <- reformulate(unique(unlist(tt_calls)), intercept = FALSE) - # formula with '~ x' and '~ bs(times__, ...)' from each 'tde(x, ...)' call + # formula with '~ x' and '~ bs(times__, ...)' from each 'tve(x, ...)' call tt_vars <- lapply(tt_vars, reformulate) tt_forms <- lapply(tt_calls, reformulate) @@ -1959,11 +1959,11 @@ handle_tde <- function(formula, min_t, max_t, times, status) { tt_forms) } -# Ensure only valid arguments are passed to the tde() call -validate_tde_args <- function(dots, ok_args) { +# Ensure only valid arguments are passed to the tve() call +validate_tve_args <- function(dots, ok_args) { if (!isTRUE(all(names(dots) %in% ok_args))) - stop2("Invalid argument to 'tde' function. ", + stop2("Invalid argument to 'tve' function. ", "Valid arguments are: ", comma(ok_args)) return(dots) @@ -2234,7 +2234,7 @@ make_x <- function(formula, nlist(x, x_centered, x_bar, N = NROW(x), K = NCOL(x)) } -# Return the tde predictor matrix +# Return the tve predictor matrix # # @param formula The parsed model formula. # @param model_frame The model frame. @@ -2242,18 +2242,18 @@ make_x <- function(formula, # @return A named list with the following elements: # s: model matrix for time-varying terms, not centered and without intercept. # tt_ncol: stored attribute, a numeric vector with the number of columns in -# the model matrix that correspond to each tde() term in the original +# the model matrix that correspond to each tve() term in the original # model formula. # tt_map: stored attribute, a numeric vector with indexing for the columns -# of the model matrix stating which tde() term in the original model +# of the model matrix stating which tve() term in the original model # formula they correspond to. make_s <- function(formula, model_frame, xlevs = NULL) { - # create the design matrix for each tde() term + # create the design matrix for each tve() term s_parts <- xapply( - formula$tt_vars, # names of variables with a tde() wrapper + formula$tt_vars, # names of variables with a tve() wrapper formula$tt_forms, # time-transformation functions to interact them with FUN = function(vn, tt) { m1 <- make_x(vn, model_frame, xlevs = xlevs, check_constant = FALSE)$x @@ -2263,7 +2263,7 @@ make_s <- function(formula, return(m3) }) - # bind columns to form one design matrix for tde() terms + # bind columns to form one design matrix for tve() terms s <- do.call("cbind", s_parts) # store indexing of the columns in the design matrix diff --git a/R/stanreg-methods.R b/R/stanreg-methods.R index 4ae2e8bc9..db6e24805 100644 --- a/R/stanreg-methods.R +++ b/R/stanreg-methods.R @@ -363,8 +363,8 @@ model.matrix.stanreg <- function(object, ...) { #' @param x A stanreg object. #' @param ... Can contain \code{fixed.only} and \code{random.only} arguments #' that both default to \code{FALSE}. Also, for stan_surv models, can contain -#' \code{remove.tde} which defaults to FALSE, but if TRUE then any -#' 'tde(varname)' terms in the model formula are returned as 'varname'. +#' \code{remove.tve} which defaults to FALSE, but if TRUE then any +#' 'tve(varname)' terms in the model formula are returned as 'varname'. #' formula.stanreg <- function(x, ..., m = NULL) { if (is.mer(x) && !isTRUE(x$stan_function == "stan_gamm4")) @@ -392,12 +392,12 @@ terms.stanreg <- function(x, ..., fixed.only = TRUE, random.only = FALSE) { Terms <- attr(fr, "terms") if (fixed.only) { - Terms <- terms.formula(formula(x, fixed.only = TRUE, remove.tde = TRUE)) + Terms <- terms.formula(formula(x, fixed.only = TRUE, remove.tve = TRUE)) attr(Terms, "predvars") <- attr(terms(fr), "predvars.fixed") } if (random.only) { Terms <- terms.formula(lme4::subbars(formula.stanreg(x, random.only = TRUE, - remove.tde = TRUE))) + remove.tve = TRUE))) attr(Terms, "predvars") <- attr(terms(fr), "predvars.random") } @@ -487,13 +487,13 @@ formula_mer <- function (x, fixed.only = FALSE, random.only = FALSE, ...) { formula_surv <- function(x, fixed.only = FALSE, random.only = FALSE, - remove.tde = FALSE, + remove.tve = FALSE, ...) { if (missing(fixed.only) && random.only) fixed.only <- FALSE if (fixed.only && random.only) stop2("'fixed.only' and 'random.only' can't both be TRUE.") - if (remove.tde) { + if (remove.tve) { form <- x$formula$tf_form } else { form <- x$formula$formula diff --git a/R/stansurv.R b/R/stansurv.R index faead9fcb..70c3e1377 100644 --- a/R/stansurv.R +++ b/R/stansurv.R @@ -43,7 +43,7 @@ stansurv <- function(object) { basehaz$nvars nms_beta <- colnames(object$x_cpts) - nms_tde <- get_smooth_name(object$s_cpts, type = "smooth_coefs") + nms_tve <- get_smooth_name(object$s_cpts, type = "smooth_coefs") nms_smooth <- get_smooth_name(object$s_cpts, type = "smooth_sd") nms_int <- get_int_name_basehaz(object$basehaz) nms_aux <- get_aux_name_basehaz(object$basehaz) @@ -51,7 +51,7 @@ stansurv <- function(object) { nms_vc <- get_varcov_names(object$group) nms_coefs <- c(nms_int, nms_beta, - nms_tde, + nms_tve, nms_aux, nms_b) @@ -77,7 +77,7 @@ stansurv <- function(object) { ses = ses, covmat = covmat, formula = object$formula, - has_tde = object$has_tde, + has_tve = object$has_tve, has_quadrature= object$has_quadrature, has_bars = object$has_bars, terms = object$terms, diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan index 226dc3be0..1f0e56524 100644 --- a/src/stan_files/functions/hazard_functions.stan +++ b/src/stan_files/functions/hazard_functions.stan @@ -147,7 +147,7 @@ */ vector quadrature_aft(vector qwts, vector eta, int qnodes, int N) { int M = rows(eta); - vector[M] af = exp(-eta); // time-dependent acceleration factor + vector[M] af = exp(-eta); // time-varying acceleration factor matrix[N,qnodes] qwts_mat = to_matrix(qwts, N, qnodes); matrix[N,qnodes] af_mat = to_matrix(af, N, qnodes); vector[N] caf = rows_dot_product(qwts_mat, af_mat); diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 7e92f5e61..7d3daf285 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -176,9 +176,9 @@ functions { } /** - * Log-prior for tde spline coefficients and their smoothing parameters + * Log-prior for tve spline coefficients and their smoothing parameters * - * @param z_beta_tde Vector of unscaled spline coefficients + * @param z_beta_tve Vector of unscaled spline coefficients * @param smooth_sd_raw Vector (potentially of length 1) of smoothing sds * @param dist Integer specifying the type of prior distribution for the * smoothing sds @@ -186,8 +186,8 @@ functions { * for the smoothing sds * @return Nothing */ - real smooth_lp(vector z_beta_tde, vector smooth_sd_raw, int dist, vector df) { - target += normal_lpdf(z_beta_tde | 0, 1); + real smooth_lp(vector z_beta_tve, vector smooth_sd_raw, int dist, vector df) { + target += normal_lpdf(z_beta_tve | 0, 1); if (dist > 0) { real log_half = -0.693147180559945286; if (dist == 1) @@ -414,7 +414,7 @@ data { int qicens; // num. quadrature points for rows w/ interval censoring int qdelay; // num. quadrature points for rows w/ delayed entry int nvars; // num. aux parameters for baseline hazard - int smooth_map[S]; // indexing of smooth sds for tde spline coefs + int smooth_map[S]; // indexing of smooth sds for tve spline coefs int smooth_idx[S > 0 ? max(smooth_map) : 0, 2]; // dimensions for random efffects structure, see table 3 of @@ -622,7 +622,7 @@ data { vector[nvars] prior_df_for_aux; vector[nvars] prior_conc_for_aux; // dirichlet concentration pars - // hyperparameters (tde smooths), set to 0 if there is no prior + // hyperparameters (tve smooths), set to 0 if there is no prior vector [S > 0 ? max(smooth_map) : 0] prior_mean_for_smooth; vector[S > 0 ? max(smooth_map) : 0] prior_scale_for_smooth; vector[S > 0 ? max(smooth_map) : 0] prior_df_for_smooth; @@ -694,10 +694,10 @@ parameters { vector[type == 4 ? 0 : nvars] z_coefs; simplex[nvars] ms_coefs[type == 4]; // constrained coefs for M-splines - // unscaled tde spline coefficients - vector[S] z_beta_tde; + // unscaled tve spline coefficients + vector[S] z_beta_tve; - // hyperparameter, the prior sd for the tde spline coefs + // hyperparameter, the prior sd for the tve spline coefs vector[S > 0 ? max(smooth_map) : 0] smooth_sd_raw; // parameters for random effects @@ -723,9 +723,9 @@ transformed parameters { // declare basehaz parameters vector[type == 4 ? 0 : nvars] coefs; - // declare tde spline coefficients and their hyperparameters - vector[S] beta_tde; - vector[S > 0 ? max(smooth_map) : 0] smooth_sd; // sd for tde splines + // declare tve spline coefficients and their hyperparameters + vector[S] beta_tve; + vector[S > 0 ? max(smooth_map) : 0] smooth_sd; // sd for tve splines // declare random effects and var-cov parameters vector[q] b; @@ -744,17 +744,17 @@ transformed parameters { coefs = z_coefs .* prior_scale_for_aux; } - // define tde spline coefficients using random walk + // define tve spline coefficients using random walk if (S > 0) { smooth_sd = smooth_sd_raw .* prior_scale_for_smooth + prior_mean_for_smooth; for (i in 1:max(smooth_map)) { int beg = smooth_idx[i,1]; // index of first spline coef int end = smooth_idx[i,2]; // index of last spline coef - beta_tde[beg] = z_beta_tde[beg]; // define first spline coef + beta_tve[beg] = z_beta_tve[beg]; // define first spline coef if (end > beg) { // define subsequent spline coefs for (j in (beg+1):end) { - real tmp = beta_tde[j-1]; - beta_tde[j] = tmp + z_beta_tde[j] * smooth_sd[smooth_map[j]]; + real tmp = beta_tve[j-1]; + beta_tve[j] = tmp + z_beta_tve[j] * smooth_sd[smooth_map[j]]; } } } @@ -964,13 +964,13 @@ model { // add on time-varying part to linear predictor if (S > 0) { - if (Nevent > 0) eta_epts_event += s_epts_event * beta_tde; - if (qevent > 0) eta_qpts_event += s_qpts_event * beta_tde; - if (qlcens > 0) eta_qpts_lcens += s_qpts_lcens * beta_tde; - if (qrcens > 0) eta_qpts_rcens += s_qpts_rcens * beta_tde; - if (qicens > 0) eta_qpts_icenl += s_qpts_icenl * beta_tde; - if (qicens > 0) eta_qpts_icenu += s_qpts_icenu * beta_tde; - if (qdelay > 0) eta_qpts_delay += s_qpts_delay * beta_tde; + if (Nevent > 0) eta_epts_event += s_epts_event * beta_tve; + if (qevent > 0) eta_qpts_event += s_qpts_event * beta_tve; + if (qlcens > 0) eta_qpts_lcens += s_qpts_lcens * beta_tve; + if (qrcens > 0) eta_qpts_rcens += s_qpts_rcens * beta_tve; + if (qicens > 0) eta_qpts_icenl += s_qpts_icenl * beta_tve; + if (qicens > 0) eta_qpts_icenu += s_qpts_icenu * beta_tve; + if (qdelay > 0) eta_qpts_delay += s_qpts_delay * beta_tve; } // add on log crude event rate / time (helps to center intercept) @@ -1168,9 +1168,9 @@ model { real dummy = basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); } - // log priors for tde spline coefficients and their smoothing parameters + // log priors for tve spline coefficients and their smoothing parameters if (S > 0) { - real dummy = smooth_lp(z_beta_tde, smooth_sd_raw, + real dummy = smooth_lp(z_beta_tve, smooth_sd_raw, prior_dist_for_smooth, prior_df_for_smooth); } diff --git a/tests/testthat/helpers/get_tols_surv.R b/tests/testthat/helpers/get_tols_surv.R index da1b2bbde..7c99b208c 100644 --- a/tests/testthat/helpers/get_tols_surv.R +++ b/tests/testthat/helpers/get_tols_surv.R @@ -8,7 +8,7 @@ # # @param mod The "gold standard" longitudinal model. Likely to be # a model estimated using coxph. -# @param toscales A named list with elements 'hr_fixef' and 'tde_fixef'. +# @param toscales A named list with elements 'hr_fixef' and 'tve_fixef'. # get_tols <- function(mod, tolscales) { diff --git a/tests/testthat/helpers/recover_pars_surv.R b/tests/testthat/helpers/recover_pars_surv.R index 24aa5150a..ea93bff2b 100644 --- a/tests/testthat/helpers/recover_pars_surv.R +++ b/tests/testthat/helpers/recover_pars_surv.R @@ -15,11 +15,11 @@ recover_pars <- function(mod) { NULL) if (cl == "stansurv") { - sel <- grep(":tde-[a-z][a-z]-coef[0-9]*$", names(fixef_pars)) - # replace stansurv tde names with coxph tt names + sel <- grep(":tve-[a-z][a-z]-coef[0-9]*$", names(fixef_pars)) + # replace stansurv tve names with coxph tt names if (length(sel)) { nms <- names(fixef_pars)[sel] - nms <- gsub(":tde-[a-z][a-z]-coef[0-9]*$", "", nms) + nms <- gsub(":tve-[a-z][a-z]-coef[0-9]*$", "", nms) nms <- paste0("tt(", nms, ")") names(fixef_pars)[sel] <- nms } diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 5ffb30035..589ea5f1b 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -32,7 +32,7 @@ if (interactive()) TOLSCALES <- list( hr_fixef = 0.5, # how many SEs can stan_surv HRs be from coxph/stpm2 HRs - tde_fixef = 0.5 # how many SEs can stan_surv tde HRs be from coxph/stpm2 tde HRs + tve_fixef = 0.5 # how many SEs can stan_surv tve HRs be from coxph/stpm2 tve HRs ) source(test_path("helpers", "expect_matrix.R")) @@ -164,39 +164,39 @@ test_that("prior arguments work", { ee(up(testmod, prior_smooth = lasso()), "prior distribution") }) -test_that("tde function works", { +test_that("tve function works", { - # single tde call + # single tve call es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1) + x2)) + Surv(eventtime, status) ~ tve(x1) + x2)) - # multiple tde calls + # multiple tve calls es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1) + tde(x2))) + Surv(eventtime, status) ~ tve(x1) + tve(x2))) - # b-spline and piecewise tde in same model + # b-spline and piecewise tve in same model es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "bs") + tde(x2, type = "pw"))) + Surv(eventtime, status) ~ tve(x1, type = "bs") + tve(x2, type = "pw"))) - # b-spline tde optional arguments + # b-spline tve optional arguments es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "bs", knots = c(1,2)) + x2)) + Surv(eventtime, status) ~ tve(x1, type = "bs", knots = c(1,2)) + x2)) es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "bs", df = 4) + x2)) + Surv(eventtime, status) ~ tve(x1, type = "bs", df = 4) + x2)) es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "bs", degree = 2) + x2)) + Surv(eventtime, status) ~ tve(x1, type = "bs", degree = 2) + x2)) ee(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "bs", junk = 2) + x2), - "Invalid argument to 'tde' function.") + Surv(eventtime, status) ~ tve(x1, type = "bs", junk = 2) + x2), + "Invalid argument to 'tve' function.") - # piecewise tde optional arguments + # piecewise tve optional arguments es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "pw", knots = c(1,2)) + x2)) + Surv(eventtime, status) ~ tve(x1, type = "pw", knots = c(1,2)) + x2)) es(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "pw", df = 4) + x2)) + Surv(eventtime, status) ~ tve(x1, type = "pw", df = 4) + x2)) ee(up(testmod, formula. = - Surv(eventtime, status) ~ tde(x1, type = "pw", degree = 2) + x2), - "Invalid argument to 'tde' function.") + Surv(eventtime, status) ~ tve(x1, type = "pw", degree = 2) + x2), + "Invalid argument to 'tve' function.") }) @@ -426,7 +426,7 @@ compare_surv(data = dat, basehaz = "weibull-aft") # coef(v_weib)['sesupper'][[1]], # tol = 0.1), "not equal") -#---- Check tde models against coxph +#---- Check tve models against coxph #---- piecewise constant @@ -438,15 +438,15 @@ dat <- simsurv(dist = "exponential", lambdas = 0.1, betas = c(X1 = 0.3, X2 = -0.3), x = covs, - tde = c(X1 = -0.6), - tdefun = function(t) as.numeric(t > 10), + tve = c(X1 = -0.6), + tvefun = function(t) as.numeric(t > 10), maxt = 30) dat <- merge(dat, covs) fmsurv <- Surv(eventtime, status) ~ X1 + tt(X1) + X2 o<-SW(surv1 <- coxph(fmsurv, dat, tt = function(x, t, ...) { x * as.numeric(t > 10) })) -fmstan <- Surv(eventtime, status) ~ tde(X1, type = "pw", knots = c(10)) + X2 +fmstan <- Surv(eventtime, status) ~ tve(X1, type = "pw", knots = c(10)) + X2 o<-SW(stan1 <- stan_surv(fmstan, dat, chains = 1, refresh = 0L, iter = 1000, basehaz = "exp")) tols <- get_tols(surv1, tolscales = TOLSCALES) @@ -456,7 +456,7 @@ for (i in names(tols$fixef)) expect_equal(pars_surv$fixef[[i]], pars_stan$fixef[[i]], tol = tols$fixef[[i]], - info = "compare_estimates_tde_pw") + info = "compare_estimates_tve_pw") @@ -483,34 +483,34 @@ o<-SW(f5 <- update(f1, basehaz = "gompertz")) o<-SW(f6 <- update(f1, basehaz = "exp-aft")) o<-SW(f7 <- update(f1, basehaz = "weibull-aft")) -# time-dependent effects -o<-SW(f8 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt))) -o<-SW(f9 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt))) -o<-SW(f10 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt))) -o<-SW(f11 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt))) -o<-SW(f12 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt))) -o<-SW(f13 <- update(f6, Surv(futimeYears, death) ~ sex + tde(trt))) -o<-SW(f14 <- update(f7, Surv(futimeYears, death) ~ sex + tde(trt))) - -o<-SW(f15 <- update(f1, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) -o<-SW(f16 <- update(f2, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) -o<-SW(f17 <- update(f3, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) -o<-SW(f18 <- update(f4, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) -o<-SW(f19 <- update(f5, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) -o<-SW(f20 <- update(f6, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) -o<-SW(f21 <- update(f7, Surv(futimeYears, death) ~ sex + tde(trt, type = "pw"))) +# time-varying effects +o<-SW(f8 <- update(f1, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f9 <- update(f2, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f10 <- update(f3, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f11 <- update(f4, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f12 <- update(f5, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f13 <- update(f6, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f14 <- update(f7, Surv(futimeYears, death) ~ sex + tve(trt))) + +o<-SW(f15 <- update(f1, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f16 <- update(f2, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f17 <- update(f3, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f18 <- update(f4, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f19 <- update(f5, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f20 <- update(f6, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f21 <- update(f7, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) # start-stop notation (incl. delayed entry) o<-SW(f22 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) -o<-SW(f23 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tde(trt))) -o<-SW(f24 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) -o<-SW(f25 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tde(trt))) +o<-SW(f23 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tve(trt))) +o<-SW(f24 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tve(trt))) +o<-SW(f25 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tve(trt))) # left and interval censoring o<-SW(f26 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) -o<-SW(f27 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) -o<-SW(f28 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) -o<-SW(f29 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tde(trt))) +o<-SW(f27 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) +o<-SW(f28 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) +o<-SW(f29 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 8c6c3ff3d..0f5ac788b 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -44,7 +44,7 @@ set.seed(989898) This vignette provides an introduction to the `stan_surv` modelling function in the __rstanarm__ package. The `stan_surv` function allows the user to fit survival models (sometimes known as models for time-to-event data) under a Bayesian framework. -Currently, the command fits standard parametric (exponential, Weibull and Gompertz) and flexible parametric (cubic spline-based) survival models on the hazard scale, with covariates included under assumptions of either proportional or non-proportional hazards. Where relevant, non-proportional hazards are modelled using a flexible cubic spline-based function for the time-dependent effect (i.e. the time-dependent hazard ratio). +Currently, the command fits standard parametric (exponential, Weibull and Gompertz) and flexible parametric (cubic spline-based) survival models on the hazard scale, with covariates included under assumptions of either proportional or non-proportional hazards. Where relevant, non-proportional hazards are modelled using a flexible cubic spline-based function for the time-varying effect (i.e. the time-varying hazard ratio). # Introduction @@ -126,7 +126,7 @@ h_i(t) = h_0(t) \exp \left[ \eta_i(t) \right] \end{split} \end{equation} \ -where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-dependent; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying hazard ratio). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity and the definition of the hazard function reduces to: +where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-varying; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying hazard ratio). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity and the definition of the hazard function reduces to: \ \begin{equation} \begin{split} @@ -156,11 +156,11 @@ where $\beta_0$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observe \end{cases} \end{align} \ -such that $\theta_{p,0}$ is a time-fixed log hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent hazard ratio as a smooth function of time. +such that $\theta_{p,0}$ is a time-fixed log hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-varying hazard ratio as a smooth function of time. **Note:** in these expressions, the quantity $\exp \left( \beta_p(t) \right)$ is referred to as a "hazard ratio". The *hazard ratio (HR)* quantifies the relative increase in the hazard that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a hazard ratio of 2 means that a unit-increase in the covariate leads to a doubling in the hazard (i.e. the instantaneous rate) of the event. -**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent hazard ratio for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. +**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-varying hazard ratio for a covariate by wrapping the covariate name in the `tve()` function in the model formula; see the examples in the latter part of this vignette. ### Distributions @@ -196,7 +196,7 @@ For identifiability of the intercept $\beta_0$ in the linear predictor $\eta_i$ h_i(t) = \exp ( B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) + \eta_i(t) ) \end{equation} -**Note:** when the linear predictor *is not* time-dependent (i.e. under proportional hazards), there is a closed form expression for the survival probability; details shown in the appendix. However, when the linear predictor *is* time-dependent (i.e. under non-proportional hazards) there is no closed form expression for the survival probability; instead, quadrature is used to evaluate the survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. +**Note:** when the linear predictor *is not* time-varying (i.e. under proportional hazards), there is a closed form expression for the survival probability; details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under non-proportional hazards) there is no closed form expression for the survival probability; instead, quadrature is used to evaluate the survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. ## Accelerated failure time formulations @@ -210,7 +210,7 @@ S_i(t) = S_0 \left( \int_0^t \exp \left[ - \eta_i(u) \right] du \right) \end{split} \end{equation} \ -where $S_0(t)$ is the baseline survival probability at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-dependent; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying acceleration factor). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity (i.e. $\eta_i(t) = \eta_i$) and the definition of the survival probability reduces to: +where $S_0(t)$ is the baseline survival probability at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-varying; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying acceleration factor). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity (i.e. $\eta_i(t) = \eta_i$) and the definition of the survival probability reduces to: \ \begin{equation} \begin{split} @@ -236,15 +236,15 @@ where $\beta_0^*$ denotes the intercept parameter, $x_{ip}(t)$ denotes the obser \theta_{p,0} & \text{for time-fixed acceleration} \\ \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) - & \text{for time-dependent acceleration} + & \text{for time-varying acceleration} \end{cases} \end{align} \ -such that $\theta_{p,0}$ is a time-fixed log survival time ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-dependent acceleration factor as a smooth function of time. +such that $\theta_{p,0}$ is a time-fixed log survival time ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-varying acceleration factor as a smooth function of time. **Note:** in these expressions, the quantity $\exp \left( - \beta_p^*(t) \right)$ is referred to as an "acceleration factor" and the quantity $\exp \left( \beta_p^*(t) \right)$ is referred to as a "survival time ratio". The *acceleration factor (AF)* quantifies the acceleration (or deceleration) of the event process that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. an acceleration factor of 0.5 means that a unit-increase in the covariate leads to an individual approaching the event at half the speed. If you find that somewhat confusing, then it may be easier to think about the *survival time ratio (STR)* . The *survival time ratio* is the inverse of the acceleration factor (i.e. $STR = 1/AF$). The *survival time ratio* is interpreted as the increase (or decrease) in the expected survival time that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a survival time ratio of 2 (which is equivalent to an acceleration factor of 0.5) means that a unit-increase in the covariate leads to an doubling in the expected survival time. -**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-dependent acceleration factor for a covariate by wrapping the covariate name in the `tde()` function in the model formula; see the examples in the latter part of this vignette. +**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-varying acceleration factor for a covariate by wrapping the covariate name in the `tve()` function in the model formula; see the examples in the latter part of this vignette. ### Distributions @@ -254,7 +254,7 @@ such that $\theta_{p,0}$ is a time-fixed log survival time ratio, and $B(t; \bol S_i(t) = \exp \left( - t \lambda_i \right) \end{equation} \ -or in the case with time-dependent effects +or in the case with time-varying effects \ \begin{equation} S_i(t) = \exp \left( - \int_0^t \exp ( -\eta_i(u) ) du \right) @@ -266,13 +266,13 @@ S_i(t) = \exp \left( - \int_0^t \exp ( -\eta_i(u) ) du \right) S_i(t) = \exp \left( - t^{\gamma} \lambda_i \right) \end{equation} \ -or in the case with time-dependent effects +or in the case with time-varying effects \ \begin{equation} S_i(t) = \exp \left( - \left[ \int_0^t \exp ( -\eta_i(u) ) du \right]^{\gamma} \right) \end{equation} -**Note:** when the linear predictor *is not* time-dependent (i.e. under time-fixed acceleration), there is a closed form expression for both the hazard function and survival function; details shown in the appendix. However, when the linear predictor *is* time-dependent (i.e. under time-dependent acceleration) there is no closed form expression for the hazard function or survival probability; instead, quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate the hazard function and survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. +**Note:** when the linear predictor *is not* time-varying (i.e. under time-fixed acceleration), there is a closed form expression for both the hazard function and survival function; details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under time-varying acceleration) there is no closed form expression for the hazard function or survival probability; instead, quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate the hazard function and survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. ## Likelihood @@ -304,7 +304,7 @@ The prior distribution for the intercept parameter in the linear predictor is sp The choice of prior distribution for the time-fixed coefficients $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. -The B-spline coefficients related to each time-dependent effect, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. +The B-spline coefficients related to each time-varying effect, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. # Usage examples @@ -321,7 +321,7 @@ fm <- Surv(recyrs, status) ~ group mod1 <- stan_surv(fm, data = bcancer, seed = 123321) ``` -The model here is estimated using the default cubic M-splines (with 5 degrees of freedom) for modelling the baseline hazard. Since there are no time-dependent effects in the model (i.e. we did not wrap any covariates in the `tde()` function) there is a closed form expression for the cumulative hazard and survival function and so the model is relatively fast to fit. Specifically, the model takes ~3.5 sec for each MCMC chain based on the default 2000 (1000 warm up, 1000 sampling) MCMC iterations. +The model here is estimated using the default cubic M-splines (with 5 degrees of freedom) for modelling the baseline hazard. Since there are no time-varying effects in the model (i.e. we did not wrap any covariates in the `tve()` function) there is a closed form expression for the cumulative hazard and survival function and so the model is relatively fast to fit. Specifically, the model takes ~3.5 sec for each MCMC chain based on the default 2000 (1000 warm up, 1000 sampling) MCMC iterations. We can easily obtain the estimated hazard ratios for the 3-catgeory group covariate using the generic `print` method for `stansurv` objects, as follows @@ -427,7 +427,7 @@ We can quite clearly see in the plot the assumption of proportional hazards. We ## Example: a model with non-proportional hazards -To demonstrate the implementation of time-dependent effects in `stan_surv` we will use a simulated dataset, generated using the **simsurv** package (Brilleman, 2018). +To demonstrate the implementation of time-varying effects in `stan_surv` we will use a simulated dataset, generated using the **simsurv** package (Brilleman, 2018). We will simulate a dataset with $N = 200$ individuals with event times generated under the following Weibull hazard function \ @@ -435,7 +435,7 @@ We will simulate a dataset with $N = 200$ individuals with event times generated h_i(t) = \gamma t^{\gamma-1} \lambda exp( \beta(t) x_i ) \end{align} \ -with scale parameter $\lambda = 0.1$, shape parameter $\gamma = 1.5$, binary baseline covariate $X_i \sim \text{Bern}(0.5)$, and time-dependent hazard ratio $\beta(t) = -0.5 + 0.2 t$. We will enforce administrative censoring at 5 years if an individual's simulated event time is >5 years. +with scale parameter $\lambda = 0.1$, shape parameter $\gamma = 1.5$, binary baseline covariate $X_i \sim \text{Bern}(0.5)$, and time-varying hazard ratio $\beta(t) = -0.5 + 0.2 t$. We will enforce administrative censoring at 5 years if an individual's simulated event time is >5 years. ```{r simsurv-simdata} # load package @@ -452,7 +452,7 @@ covs <- data.frame(id = 1:100, dat <- simsurv(lambdas = 0.1, gammas = 1.5, betas = c(trt = -0.5), - tde = c(trt = 0.2), + tve = c(trt = 0.2), x = covs, maxt = 5) @@ -463,30 +463,30 @@ dat <- merge(dat, covs) head(dat) ``` -Now that we have our simulated dataset, let us fit a model with time-dependent hazard ratio for `trt` +Now that we have our simulated dataset, let us fit a model with time-varying hazard ratio for `trt` ```{r, warning = FALSE, message = FALSE, results='hide'} -fm <- Surv(eventtime, status) ~ tde(trt) +fm <- Surv(eventtime, status) ~ tve(trt) mod2 <- stan_surv(formula = fm, data = dat, seed = 5544, iter = 500) ``` -By default the cubic B-spline basis used for modelling the time-dependent hazard ratio is evaluated with 3 degrees of freedom (i.e. two boundary knots placed at the limits of the range of event times, but no internal knots). For a more or less flexible spline function we can specify the `df` arugment to `tde()` function. For example, we could specify the model formula as +By default the cubic B-spline basis used for modelling the time-varying hazard ratio is evaluated with 3 degrees of freedom (i.e. two boundary knots placed at the limits of the range of event times, but no internal knots). For a more or less flexible spline function we can specify the `df` arugment to `tve()` function. For example, we could specify the model formula as ```{r, warning = FALSE, message = FALSE, results='hide', eval=FALSE} -fm <- Surv(eventtime, status) ~ tde(trt, df = 5) +fm <- Surv(eventtime, status) ~ tve(trt, df = 5) ``` -so that we use 5 degrees of freedom for modelling the time-dependent effect (i.e. two boundary knots placed at the limits of the range of event times, as well as two internal knots placed - by default - at the 33.3rd and 66.6th percentiles of the distribution of uncensored event times). +so that we use 5 degrees of freedom for modelling the time-varying effect (i.e. two boundary knots placed at the limits of the range of event times, as well as two internal knots placed - by default - at the 33.3rd and 66.6th percentiles of the distribution of uncensored event times). -Let us now plot the estimated time-dependent hazard ratio from the fitted model. We can do this using the generic `plot` method for `stansurv` objects, for which we can specify the `plotfun = "tde"` argument. (Note that in this case, there is only one covariate in the model with a time-dependent effect, but if there were others, we could specify which covariate(s) we want to plot the time-dependent effect for by specifying the `pars` argument to the `plot` call). +Let us now plot the estimated time-varying hazard ratio from the fitted model. We can do this using the generic `plot` method for `stansurv` objects, for which we can specify the `plotfun = "tve"` argument. (Note that in this case, there is only one covariate in the model with a time-varying effect, but if there were others, we could specify which covariate(s) we want to plot the time-varying effect for by specifying the `pars` argument to the `plot` call). ```{r, fig.height=5} -plot(mod2, plotfun = "tde") +plot(mod2, plotfun = "tve") ``` From the plot, we can see how the hazard ratio (i.e. the effect of treatment on the hazard of the event) changes as a function of time. The treatment appears to be protective during the first few years following baseline (i.e. HR < 1), and then the treatment appears to become harmful after about 4 years post-baseline (of course, this is the model we simulated under!). -The plot shows a large amount of uncertainty around the estimated time-dependent hazard ratio. This is to be expected, since we only simulated a dataset of 100 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-dependent hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-dependent hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-dependent hazard ratio equals 1 at around ~3 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. +The plot shows a large amount of uncertainty around the estimated time-varying hazard ratio. This is to be expected, since we only simulated a dataset of 100 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-varying hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-varying hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-varying hazard ratio equals 1 at around ~3 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. # References @@ -752,9 +752,9 @@ The cumulative hazard, survival function, and CDF for the B-spline model cannot \end{align} -### Extension to time-dependent coefficients (i.e. non-proportional hazards) +### Extension to time-varying coefficients (i.e. non-proportional hazards) -We can extend the previous model formulations to allow for time-dependent coefficients (i.e. non-proportional hazards). The time-dependent linear predictor is introduced on the hazard scale. That is, $\eta_i$ in our previous model definitions is instead replaced by $\eta_i(t)$. This leads to an analytical form for the hazard and log hazard. However, in general, there is no longer a closed form expression for the cumulative hazard, survival function, or CDF. Therefore, when the linear predictor includes time-dependent coefficients, quadrature is used to evaluate the following: +We can extend the previous model formulations to allow for time-varying coefficients (i.e. non-proportional hazards). The time-varying linear predictor is introduced on the hazard scale. That is, $\eta_i$ in our previous model definitions is instead replaced by $\eta_i(t)$. This leads to an analytical form for the hazard and log hazard. However, in general, there is no longer a closed form expression for the cumulative hazard, survival function, or CDF. Therefore, when the linear predictor includes time-varying coefficients, quadrature is used to evaluate the following: \begin{align} \begin{split} @@ -950,13 +950,13 @@ Lastly, the general form for the hazard function and survival function under an \end{align} -### Extension to time-dependent coefficients (i.e. time-dependent acceleration factors) +### Extension to time-varying coefficients (i.e. time-varying acceleration factors) -We can extend the previous model formulations to allow for time-dependent coefficients (i.e. time-dependent acceleration factors). +We can extend the previous model formulations to allow for time-varying coefficients (i.e. time-varying acceleration factors). The so-called "unmoderated" survival probability for an individual at time $t$ is defined as the baseline survival probability at time $t$, i.e. $S_i(t) = S_0(t)$. With a time-fixed acceleration factor, the survival probability for a so-called "moderated" individual is defined as the baseline survival probability but evaluated at "time $t$ multiplied by the acceleration factor $\exp(-\eta_i)$". That is, the survival probability for the moderated individual is $S_i(t) = S_0(t \exp(-\eta_i))$. -However, with time-dependent acceleration we cannot simply multiply time by a fixed (acceleration) constant. Instead, we must integrate the function for the time-dependent acceleration factor over the interval $0$ to $t$. In other words, we must evaluate: +However, with time-varying acceleration we cannot simply multiply time by a fixed (acceleration) constant. Instead, we must integrate the function for the time-varying acceleration factor over the interval $0$ to $t$. In other words, we must evaluate: \ \begin{align} \begin{split} @@ -966,7 +966,7 @@ However, with time-dependent acceleration we cannot simply multiply time by a fi \ as described by Hougaard (1999). -Hougaard also gives a general expression for the hazard function under time-dependent acceleration, as follows: +Hougaard also gives a general expression for the hazard function under time-varying acceleration, as follows: \ \begin{align} \begin{split} @@ -974,7 +974,7 @@ Hougaard also gives a general expression for the hazard function under time-depe \end{split} \end{align} -**Note:** It is interesting to note here that the *hazard* at time $t$ is in fact a function of the full history of covariates and parameters (i.e. the linear predictor) from time $0$ up until time $t$. This is different to the hazard scale formulation of time-dependent effects (i.e. non-proportional hazards). Under the hazard scale formulation with time-dependent effects, the *survival* probability is a function of the full history between times $0$ and $t$, but the *hazard* is **not**; instead, the hazard is only a function of covariates and parameters as defined at the current time. This is particularly important to consider when fitting accelerated failure time models with time-dependent effects in the presence of delayed entry (i.e. left truncation). +**Note:** It is interesting to note here that the *hazard* at time $t$ is in fact a function of the full history of covariates and parameters (i.e. the linear predictor) from time $0$ up until time $t$. This is different to the hazard scale formulation of time-varying effects (i.e. non-proportional hazards). Under the hazard scale formulation with time-varying effects, the *survival* probability is a function of the full history between times $0$ and $t$, but the *hazard* is **not**; instead, the hazard is only a function of covariates and parameters as defined at the current time. This is particularly important to consider when fitting accelerated failure time models with time-varying effects in the presence of delayed entry (i.e. left truncation). For the exponential distribution, this leads to: @@ -1012,4 +1012,4 @@ and for the Weibull distribution, this leads to: \end{split} \end{align} -The general expressions for the hazard and survival function under an AFT model with a time-dependent linear predictor are used to evaluate the likelihood for the accelerated failure time model in `stan_surv` when time-dependent effects are specified in the model formula. Specifically, quadrature is used to evaluate the cumulative acceleration factor $\int_0^t \exp(-\eta_i(u)) du$ and this is then substituted into the relevant expressions for the hazard and survival. +The general expressions for the hazard and survival function under an AFT model with a time-varying linear predictor are used to evaluate the likelihood for the accelerated failure time model in `stan_surv` when time-varying effects are specified in the model formula. Specifically, quadrature is used to evaluate the cumulative acceleration factor $\int_0^t \exp(-\eta_i(u)) du$ and this is then substituted into the relevant expressions for the hazard and survival. From 3def4d22d053316cafd8d70a1166cd51429c794a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 14 May 2019 14:01:46 +1000 Subject: [PATCH 143/225] Update stan_surv documentation for tve() --- R/stan_surv.R | 98 ++++++++++++++++++++++++++++----------------------- 1 file changed, 54 insertions(+), 44 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index b21a3520b..413fb5993 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -54,9 +54,10 @@ #' coefficients, e.g. non-proportional hazards) in the model #' then any covariate(s) that you wish to estimate a time-varying #' coefficient for should be specified as \code{tve(varname)} where -#' \code{varname} is the name of the covariate. See the \strong{Details} -#' section for more information on how the time-varying effects are -#' formulated, as well as the \strong{Examples} section. +#' \code{varname} is the name of the covariate. For more information on +#' how time-varying effects are formulated see the documentation +#' for the \code{\link{tve}} function as well as the \strong{Details} +#' and \strong{Examples} sections below. #' @param data A data frame containing the variables specified in #' \code{formula}. #' @param basehaz A character string indicating which baseline hazard or @@ -86,7 +87,7 @@ #' (i.e. a constant baseline hazard). #' \item \code{"weibull"}: a Weibull distribution for the event times. #' \item \code{"gompertz"}: a Gompertz distribution for the event times. -#' } +#' } #' #' The following are available under an accelerated failure time (AFT) #' formulation: @@ -114,8 +115,8 @@ #' user. #' @param qnodes The number of nodes to use for the Gauss-Kronrod quadrature #' that is used to evaluate the cumulative hazard when \code{basehaz = "bs"} -#' or when time-varying effects (i.e. non-proportional hazards) are -#' specified. Options are 15 (the default), 11 or 7. +#' or when time-varying effects are specified in the linear predictor. +#' Options are 15 (the default), 11 or 7. #' @param prior_intercept The prior distribution for the intercept in the #' linear predictor. All models include an intercept parameter. #' \code{prior_intercept} can be a call to \code{normal}, @@ -190,7 +191,7 @@ #' coefficient, or the deviations in the log hazard ratio specific to each #' time interval when a piecewise constant function is used to model the #' time-varying coefficient). Lower values for the hyperparameter -#' yield a less a flexible function for the time-varying coefficient. +#' yield a less flexible function for the time-varying coefficient. #' Specifically, \code{prior_smooth} can be a call to \code{exponential} to #' use an exponential distribution, or \code{normal}, \code{student_t} or #' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy @@ -198,7 +199,7 @@ #' prior ---i.e., to use a flat (improper) uniform prior--- set #' \code{prior_smooth} to \code{NULL}. The number of hyperparameters depends #' on the model specification (i.e. the number of time-varying effects -#' specified in the model) but a scalar prior will be recylced as necessary +#' specified in the model) but a scalar prior will be recycled as necessary #' to the appropriate length. #' #' @details @@ -216,7 +217,7 @@ #' #' \tabular{llll}{ #' \strong{Scale } \tab -#' \strong{tve } \tab +#' \strong{TVE } \tab #' \strong{Hazard } \tab #' \strong{Survival } \cr #' \emph{Hazard} \tab @@ -238,7 +239,7 @@ #' } #' #' where \emph{AFT} stands for an accelerated failure time formulation, -#' and \emph{tve} stands for time-varying effects in the model formula. +#' and \emph{TVE} stands for time-varying effects in the model formula. #' #' For models without time-varying effects, the value of \eqn{S_i(t)} can #' be calculated analytically (with the one exception being when B-splines @@ -258,65 +259,74 @@ #' provides more extensive details on the model formulations, including the #' parameterisations for each of the parametric distributions. #' } -#' \subsection{time-varying effects}{ +#' \subsection{Time-varying effects (see \code{\link{tve}})}{ #' By default, any covariate effects specified in the \code{formula} are #' included in the model under a proportional hazards assumption (for models #' estimated using a hazard scale formulation) or under the assumption of #' time-fixed acceleration factors (for models estimated using an accelerated -#' failure time formulation). To relax this assumption, it is possible to -#' estimate a time-varying coefficient for a given covariate. Note the -#' following: +#' failure time formulation). +#' +#' To relax this assumption, it is possible to +#' estimate a time-varying effect (i.e. a time-varying coefficient) for a +#' given covariate. A time-varying effect is specified in the model +#' \code{formula} by wrapping the covariate name in the \code{\link{tve}} +#' function. +#' +#' The following applies: #' #' \itemize{ -#' \item Estimating a time-varying coefficient under a hazard scale model +#' \item Estimating a time-varying effect within a hazard scale model #' formulation (i.e. when \code{basehaz} is set equal to \code{"ms"}, #' \code{"bs"}, \code{"exp"}, \code{"weibull"} or \code{"gompertz"}) leads #' to the estimation of a time-varying hazard ratio for the relevant -#' covariate (i.e. non-proportional hazards). -#' \item Estimating a time-varying coefficient under an accelerated failure +#' covariate (i.e. non-proportional hazards). +#' \item Estimating a time-varying effect within an accelerated failure #' time model formulation (i.e. when \code{basehaz} is set equal to #' \code{"exp-aft"}, or \code{"weibull-aft"}) leads to the estimation of a -#' time-varying acceleration factor -- or equivalently, a -#' time-varying survival time ratio -- for the relevant covariate. +#' time-varying survival time ratio -- or equivalently, a time-varying +#' acceleration factor -- for the relevant covariate. #' } #' -#' A time-varying effect can be specified in the model \code{formula} -#' by wrapping the covariate name in the \code{tve()} function (note that -#' this function is not an exported function, rather it is an internal -#' function that only has meaning when evaluated within the formula of -#' a \code{stan_surv} call). -#' #' For example, if we wish to estimate a time-varying effect for the #' covariate \code{sex} then we can specify \code{tve(sex)} in the #' \code{formula}, e.g. \code{Surv(time, status) ~ tve(sex) + age + trt}. -#' The coefficient for \code{sex} will then be modelled -#' using a flexible smooth function based on a cubic B-spline expansion of -#' time. +#' The coefficient for \code{sex} will then be modelled using a flexible +#' smooth function based on a cubic B-spline expansion of time. +#' Alternatively we can use a piecewise constant function to model the +#' time-varying coefficient by specifying \code{tve(sex, type = "pw")}. #' -#' The flexibility of the smooth function can be controlled in two ways: -#' \itemize{ -#' \item First, through control of the prior distribution for the cubic B-spline -#' coefficients that are used to model the time-varying coefficient. -#' Specifically, one can control the flexibility of the prior through -#' the hyperparameter (standard deviation) of the random walk prior used -#' for the B-spline coefficients; see the \code{prior_smooth} argument. -#' \item Second, one can increase or decrease the number of degrees of -#' freedom used for the cubic B-spline function that is used to model the -#' time-varying coefficient. By default the cubic B-spline basis is -#' evaluated using 3 degrees of freedom (that is a cubic spline basis with -#' boundary knots at the limits of the time range, but no internal knots). -#' If you wish to increase the flexibility of the smooth function by using a +#' This argument, as well as additional arguments used to control the +#' modelling of the time-varying effect are explained in the +#' \code{\link{tve}} documentation. The flexibility of the function used +#' to model the time-varying effect is primarily controlled by increasing +#' or decreasing the degrees of freedom used to model the time-varying +#' coefficient (i.e. the number of B-spline basis terms or the number of +#' time intervals in the piecewise constant function). For instance, +#' if you wished to increase the flexibility of the function by using a #' greater number of degrees of freedom, then you can specify this as part #' of the \code{tve} function call in the model formula. For example, to #' use cubic B-splines with 7 degrees of freedom we could specify #' \code{tve(sex, df = 7)} in the model formula instead of just #' \code{tve(sex)}. See the \strong{Examples} section below for more #' details. -#' } +#' +#' It is worth noting however that an additional way to control the +#' flexibility of the function used to model the time-varying effect +#' is through the priors. A random walk prior is used for the piecewise +#' constant or B-spline coefficients, and the hyperparameter (standard +#' deviation) of the random walk prior can be controlled via the +#' \code{prior_smooth} argument. This is a much more indirect way to +#' control the "smoothness" of the function used to model the time-varying +#' effect, but it nonetheless might be useful in some settings. The +#' \emph{stan_surv: Survival (Time-to-Event) Models} vignette provides +#' more explicity details on the formulation of the time-varying effects +#' and the prior distributions used for their coefficients. +#' #' In practice, the default \code{tve()} function should provide sufficient #' flexibility for model most time-varying effects. However, it is worth -#' noting that the reliable estimation of a time-varying effect usually -#' requires a relatively large number of events in the data (e.g. >1000). +#' noting that reliable estimation of a time-varying effect usually +#' requires a relatively large number of events in the data (e.g. say >1000, +#' depending on the setting). #' } #' #' @examples From 1fbf27765620c2c9416f02e1cc962b6ad61c785f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 14 May 2019 14:38:51 +1000 Subject: [PATCH 144/225] Rename tde() to tve() in NAMESPACE --- NAMESPACE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 44028f756..b75e3ab10 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -166,7 +166,7 @@ export(stanjm_list) export(stanmvreg_list) export(stanreg_list) export(student_t) -export(tde) +export(tve) export(waic) if(getRversion()>='3.3.0') importFrom(stats, sigma) else importFrom(lme4,sigma) From 0a005d8212f8d9448eea9230fa3cd230f304ca43 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 15 May 2019 14:08:04 +1000 Subject: [PATCH 145/225] Add another stan_surv tve() example --- R/stan_surv.R | 60 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 37 insertions(+), 23 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 413fb5993..263b0fb40 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -259,7 +259,7 @@ #' provides more extensive details on the model formulations, including the #' parameterisations for each of the parametric distributions. #' } -#' \subsection{Time-varying effects (see \code{\link{tve}})}{ +#' \subsection{Time-varying effects}{ #' By default, any covariate effects specified in the \code{formula} are #' included in the model under a proportional hazards assumption (for models #' estimated using a hazard scale formulation) or under the assumption of @@ -295,35 +295,30 @@ #' Alternatively we can use a piecewise constant function to model the #' time-varying coefficient by specifying \code{tve(sex, type = "pw")}. #' -#' This argument, as well as additional arguments used to control the -#' modelling of the time-varying effect are explained in the -#' \code{\link{tve}} documentation. The flexibility of the function used -#' to model the time-varying effect is primarily controlled by increasing -#' or decreasing the degrees of freedom used to model the time-varying -#' coefficient (i.e. the number of B-spline basis terms or the number of -#' time intervals in the piecewise constant function). For instance, -#' if you wished to increase the flexibility of the function by using a -#' greater number of degrees of freedom, then you can specify this as part -#' of the \code{tve} function call in the model formula. For example, to +#' Additional arguments used to control the modelling of the time-varying +#' effect are explained in the \code{\link{tve}} documentation. +#' In particular, the flexibility of the function can primarily be +#' controlled by increasing or decreasing the degrees of freedom +#' (i.e. the number of B-spline basis terms or the number of +#' time intervals in the piecewise constant function). For example, to #' use cubic B-splines with 7 degrees of freedom we could specify #' \code{tve(sex, df = 7)} in the model formula instead of just -#' \code{tve(sex)}. See the \strong{Examples} section below for more -#' details. +#' \code{tve(sex)}. #' #' It is worth noting however that an additional way to control the #' flexibility of the function used to model the time-varying effect #' is through the priors. A random walk prior is used for the piecewise #' constant or B-spline coefficients, and the hyperparameter (standard #' deviation) of the random walk prior can be controlled via the -#' \code{prior_smooth} argument. This is a much more indirect way to +#' \code{prior_smooth} argument. This is a more indirect way to #' control the "smoothness" of the function used to model the time-varying #' effect, but it nonetheless might be useful in some settings. The #' \emph{stan_surv: Survival (Time-to-Event) Models} vignette provides -#' more explicity details on the formulation of the time-varying effects +#' more explicit details on the formulation of the time-varying effects #' and the prior distributions used for their coefficients. #' #' In practice, the default \code{tve()} function should provide sufficient -#' flexibility for model most time-varying effects. However, it is worth +#' flexibility for modelling most time-varying effects. However, it is worth #' noting that reliable estimation of a time-varying effect usually #' requires a relatively large number of events in the data (e.g. say >1000, #' depending on the setting). @@ -331,7 +326,7 @@ #' #' @examples #' \donttest{ -#' #---------- Proportional hazards +#' #----- Proportional hazards #' #' # Simulated data #' library(simsurv) @@ -356,14 +351,14 @@ #' plot(m1d), #' ylim = c(0, 0.8)) #' -#' #---------- Left and right censored data +#' #----- Left and right censored data #' #' # Mice tumor data #' m2 <- stan_surv(Surv(l, u, type = "interval2") ~ grp, #' data = mice, chains = 1, refresh = 0, iter = 600) #' print(m2, 4) #' -#' #---------- Non-proportional hazards +#' #----- Non-proportional hazards - B-spline tve() #' #' # Simulated data #' library(simsurv) @@ -381,6 +376,26 @@ #' print(m3, 4) #' plot(m3, "tve") # time-varying hazard ratio #' +#' #----- Non-proportional hazards - piecewise constant tve() +#' +#' # Simulated data +#' library(simsurv) +#' covs <- data.frame(id = 1:250, +#' trt = stats::rbinom(250, 1L, 0.5)) +#' d4 <- simsurv(lambdas = 0.1, +#' gammas = 1.5, +#' betas = c(trt = -0.5), +#' tde = c(trt = 0.4), +#' tdefun = function(t) { (t > 2.5) } +#' x = covs, +#' maxt = 5) +#' d4 <- merge(d4, covs) +#' m4 <- stan_surv(Surv(eventtime, status) ~ +#' tve(trt, type = "pw", knots = c(2.5)), +#' data = d4, chains = 1, refresh = 0, iter = 600) +#' print(m4, 4) +#' plot(m4, "tve") # time-varying hazard ratio +#' #' #---------- Compare PH and AFT parameterisations #' #' # Breast cancer data @@ -1245,11 +1260,10 @@ stan_surv <- function(formula, #' \code{knots} arguments described below. #' } #' @param df A positive integer specifying the degrees of freedom -#' for the B-splines (when \code{type = "bs"}) or the number of time -#' intervals for the piecewise constant function (when \code{type = "pw"}). +#' for the piecewise constant or B-spline function. #' When \code{type = "bs"} two boundary knots and \code{df - degree} #' internal knots are used to generate the B-spline function. -#' When \code{type = "pw"} two boundary knots and \code{df - 1} +#' When \code{type = "pw"} two boundary knots and \code{df} #' internal knots are used to generate the piecewise constant function. #' The internal knots are placed at equally spaced percentiles of the #' distribution of the uncensored event times. @@ -1916,7 +1930,7 @@ handle_tve <- function(formula, min_t, max_t, times, status) { } else if (type == "pw") { - iknots <- get_iknots(tt, df = df, degree = 1, iknots = knots) + iknots <- get_iknots(tt, df = df, degree = 0, iknots = knots) new_args <- list(breaks = c(min_t, iknots, max_t), include.lowest = TRUE) From dcfc6205a6e9df73dff1e160181e1efe5ae4b795 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 15 May 2019 14:08:21 +1000 Subject: [PATCH 146/225] Updates to stan_surv vignette --- vignettes/surv.Rmd | 158 ++++++++++++++++++++++++--------------------- 1 file changed, 86 insertions(+), 72 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 0f5ac788b..f6dc72a63 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -37,48 +37,48 @@ h1 { /* Header 1 */ knitr::opts_chunk$set(fig.width=10, fig.height=4) library(rstanarm) set.seed(989898) +ITER <- 50 ``` # Preamble -This vignette provides an introduction to the `stan_surv` modelling function in the __rstanarm__ package. The `stan_surv` function allows the user to fit survival models (sometimes known as models for time-to-event data) under a Bayesian framework. - -Currently, the command fits standard parametric (exponential, Weibull and Gompertz) and flexible parametric (cubic spline-based) survival models on the hazard scale, with covariates included under assumptions of either proportional or non-proportional hazards. Where relevant, non-proportional hazards are modelled using a flexible cubic spline-based function for the time-varying effect (i.e. the time-varying hazard ratio). +This vignette provides an introduction to the `stan_surv` modelling function in the __rstanarm__ package. The `stan_surv` function allows the user to fit survival models (sometimes known as time-to-event models) under a Bayesian framework. # Introduction -Survival (a.k.a. time-to-event) analysis is generally concerned with the time from some defined baseline (e.g. diagnosis of a disease) until an event of interest occurs (e.g. death or disease progression). In standard survival analysis, one event time is measured for each observational unit. In practice however, that event time may be unobserved due to left, right, or interval censoring, in which case the event time is only known to have occurred within the relevant censoring interval. A number of extensions to standard survival analysis have also been proposed, for example, multiple (recurrent) events, competing events, clustered survival data, cure models, and more. +Survival (a.k.a. time-to-event) analysis is generally concerned with the time from some defined baseline (e.g. diagnosis of a disease) until an event of interest occurs (e.g. death or disease progression). -In general, there are two common approaches to modelling time-to-event data. The first is to model the time-to-event outcome directly (e.g. the class of models known as accelerated failure time models). The second is to model the *rate* of the event (e.g. the class of models known as proportional and non-proportional hazards regression models). Currently, the `stan_surv` modelling function focusses on the latter. +In standard survival analysis, one event time is measured for each observational unit. In practice however that event time may be unobserved due to left, right, or interval censoring, in which case the event time is only known to have occurred within the relevant censoring interval. -The intention is for the `stan_surv` modelling function in the **rstanarm** package to provide functionality for fitting a wide range of Bayesian survival models. The current implementation allows for a hazard-scale regression model with +There are two common approaches to modelling survival data. The first is to model the *rate* of the event (known as the *hazard*) as a function of time -- the class of models known as proportional and non-proportional hazards regression models. The second is to model the event time directly -- the class of models known as accelerated failure time (AFT) models. In addition, a number of extensions to standard survival analysis have been proposed. These include the handling of multiple (recurrent) events, competing events, clustered survival data, cure models, and more. -- a standard parametric or flexible parametric baseline hazard -- covariates included under proportional or non-proportional hazards -- time-varying covariates -- left, right or interval censoring -- delayed entry (i.e. left truncation) +The intention is for the `stan_surv` modelling function in the **rstanarm** package to provide functionality for fitting a wide range of Bayesian survival models. The current implementation allows for the following model formulations: + +- standard parametric (exponential, Weibull and Gompertz) hazard models +- flexible parametric (cubic spline-based) hazard models +- standard parametric (exponential and Weibull) AFT models. -Future plans include extensions to allow for +Under each of those model formulations the following are allowed: -- group-specific parameters (i.e. random/frailty effects) -- shared frailty models -- accelerated failure time (AFT) specification +- left, right, and interval censored survival data +- delayed entry (i.e. left truncation) +- covariates can be time-fixed or time-varying (with the latter specified using a "start-stop" data structure) +- coefficients for covariates can be either time-fixed (e.g. proportional hazards) or time-varying (e.g. non-proportional hazards) -- when coefficients are specified as time-varying they can be modelled using either a smooth (cubic) B-spline function or a piecewise constant function. # Technical details ## Data and notation -We assume that a true event time for individual $i$ ($i = 1,...,N$) exists, denoted $T_i^*$, but that in practice may or may not observed due to left, right, or interval censoring. Therefore, in practice we observe outcome data $\mathcal{D}_i = \{T_i, T_i^U, T_i^E, d_i\}$ for individual $i$ where +We assume that a true event time for individual $i$ ($i = 1,...,N$) exists, denoted $T_i^*$, but that in practice it may or may not observed due to left, right, or interval censoring. Therefore, in practice we observe outcome data $\mathcal{D}_i = \{T_i, T_i^U, T_i^E, d_i\}$ for individual $i$ where: - $T_i$: the observed event or censoring time - $T_i^U$: the observed upper limit for interval censored individuals - $T_i^E$: the observed entry time (i.e. the time at which an individual became at risk for the event) -and $d_i \in \{0,1,2,3\}$ denotes an event indicator taking value +and $d_i \in \{0,1,2,3\}$ denotes an event indicator taking value: - 0 if individual $i$ was right censored (i.e. $T_i^* > T_i$) - 1 if individual $i$ was uncensored (i.e. $T_i^* = T_i$) @@ -87,7 +87,7 @@ and $d_i \in \{0,1,2,3\}$ denotes an event indicator taking value ## The hazard rate, cumulative hazard, and survival probability -The hazard of the event at time $t$ is the instantaneous rate of occurrence for the event at time $t$. Mathematically, it is defined as +The hazard of the event at time $t$ is the instantaneous rate of occurrence for the event at time $t$. Mathematically, it is defined as: \ \begin{equation} \begin{split} @@ -96,17 +96,17 @@ h_i(t) = \lim_{\Delta t \to 0} \end{split} \end{equation} \ -where $\Delta t$ is the width of some small time interval. The numerator in is the conditional probability of the individual experiencing the event during the time interval $[t, t + \Delta t)$, given that they were still at risk of the event at time $t$. The denominator in the equation converts the conditional probability to a rate per unit of time. As $\Delta t$ approaches the limit, the width of the interval approaches zero and the instantaneous event rate is obtained. +where $\Delta t$ is the width of some small time interval. The numerator is the conditional probability of the individual experiencing the event during the time interval $[t, t + \Delta t)$, given that they were still at risk of the event at time $t$. The denominator converts the conditional probability to a rate per unit of time. As $\Delta t$ approaches the limit, the width of the interval approaches zero and the instantaneous event rate is obtained. -The cumulative hazard is defined as +The cumulative hazard is defined as: \ \begin{equation} \begin{split} H_i(t) = \int_{s=0}^t h_i(s) ds \end{split} \end{equation} - -The survival probability is defined as +\ +and the survival probability is defined as: \ \begin{equation} \begin{split} @@ -114,6 +114,8 @@ S_i(t) = \exp \left[ -H_i(t) \right] = \exp \left[ -\int_{s=0}^t h_i(s) ds \righ \end{split} \end{equation} +It can be seen here that in the standard survival analysis setting there is a one-to-one relationship between each of the hazard, the cumulative hazard, and the survival probability. These quantities are also used to form the likelihood for the survival model described in the later sections. + ## Hazard scale formulations When `basehaz` is set equal to `"exp"`, `"weibull"`, `"gompertz"`, `"ms"` (the default), or `"bs"` then the model is defined on the hazard scale as described by the following parameterisations. @@ -134,8 +136,6 @@ h_i(t) = h_0(t) \exp \left[ \eta_i \right] \end{split} \end{equation} -### Linear predictor - Our linear predictor is defined as: \ \begin{equation} @@ -144,45 +144,31 @@ Our linear predictor is defined as: \end{split} \end{equation} \ -where $\beta_0$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p(t)$ denotes a coefficient defined as: -\ -\begin{align} -\beta_p(t) = - \begin{cases} - \theta_{p,0} - & \text{for proportional hazards} \\ - \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) - & \text{for non-proportional hazards} - \end{cases} -\end{align} -\ -such that $\theta_{p,0}$ is a time-fixed log hazard ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-varying hazard ratio as a smooth function of time. +where $\beta_0$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p(t)$ denotes the coefficient for the $p^{th}$ covariate. -**Note:** in these expressions, the quantity $\exp \left( \beta_p(t) \right)$ is referred to as a "hazard ratio". The *hazard ratio (HR)* quantifies the relative increase in the hazard that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a hazard ratio of 2 means that a unit-increase in the covariate leads to a doubling in the hazard (i.e. the instantaneous rate) of the event. - -**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-varying hazard ratio for a covariate by wrapping the covariate name in the `tve()` function in the model formula; see the examples in the latter part of this vignette. +The quantity $\exp \left( \beta_p(t) \right)$ is referred to as a "hazard ratio". The *hazard ratio (HR)* quantifies the relative increase in the hazard that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a hazard ratio of 2 means that a unit-increase in the covariate leads to a doubling in the hazard (i.e. the instantaneous rate) of the event. The hazard ratio can be treated as a time-fixed quantity (i.e. proportional hazards) or time-varying quantity (i.e. non-proportional hazards), as described in later sections. ### Distributions -- **Exponential model** (`basehaz = "exp"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ we have +- **Exponential model** (`basehaz = "exp"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ we have: \ \begin{equation} h_i(t) = \lambda_i(t) \end{equation} -- **Weibull model** (`basehaz = "weibull"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and shape parameter $\gamma > 0$ we have +- **Weibull model** (`basehaz = "weibull"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and shape parameter $\gamma > 0$ we have: \ \begin{equation} h_i(t) = \gamma t^{\gamma-1} \lambda_i(t) \end{equation} -- **Gompertz model** (`basehaz = "gompertz"`): for shape parameter $\lambda = \exp ( \eta_i(t) )$ and scale parameter $\gamma > 0$ we have +- **Gompertz model** (`basehaz = "gompertz"`): for shape parameter $\lambda = \exp ( \eta_i(t) )$ and scale parameter $\gamma > 0$ we have: \ \begin{equation} h_i(t) = \exp(\gamma t) \lambda_i(t) \end{equation} -- **M-splines model** (`basehaz = "ms"`, the default): letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have +- **M-splines model** (`basehaz = "ms"`, the default): letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have: \ \begin{equation} h_i(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) \exp ( \eta_i(t) ) @@ -190,13 +176,13 @@ h_i(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) \exp ( \eta_i(t) ) \ For identifiability of the intercept $\beta_0$ in the linear predictor $\eta_i$ we constrain the M-spline coefficients to a simplex, that is, $\sum_{j=1}^J{\gamma_j} = 1$. -- **B-splines model** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have +- **B-splines model** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have: \ \begin{equation} h_i(t) = \exp ( B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) + \eta_i(t) ) \end{equation} -**Note:** when the linear predictor *is not* time-varying (i.e. under proportional hazards), there is a closed form expression for the survival probability; details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under non-proportional hazards) there is no closed form expression for the survival probability; instead, quadrature is used to evaluate the survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. +**Note:** When the linear predictor *is not* time-varying (i.e. under proportional hazards) there is a closed form expression for the survival probability (except for the B-splines model); details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under non-proportional hazards) there is no closed form expression for the survival probability; instead, quadrature is used to evaluate the survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. ## Accelerated failure time formulations @@ -218,8 +204,6 @@ S_i(t) = S_0 \left( t \exp \left[ - \eta_i \right] \right) \end{split} \end{equation} -### Linear predictor - Our linear predictor is defined as: \ \begin{equation} @@ -228,55 +212,85 @@ Our linear predictor is defined as: \end{split} \end{equation} \ -where $\beta_0^*$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p^*(t)$ denotes a coefficient defined as: -\ -\begin{align} -\beta_p^*(t) = - \begin{cases} - \theta_{p,0} - & \text{for time-fixed acceleration} \\ - \theta_{p,0} + B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p}) - & \text{for time-varying acceleration} - \end{cases} -\end{align} -\ -such that $\theta_{p,0}$ is a time-fixed log survival time ratio, and $B(t; \boldsymbol{\theta_p}, \boldsymbol{k_p})$ is a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_p}$ and parameter vector $\boldsymbol{\theta_p}$. Where relevant, the cubic B-spline function is used to model the time-varying acceleration factor as a smooth function of time. +where $\beta_0^*$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p^*(t)$ denotes the coefficient for the $p^{th}$ covariate. -**Note:** in these expressions, the quantity $\exp \left( - \beta_p^*(t) \right)$ is referred to as an "acceleration factor" and the quantity $\exp \left( \beta_p^*(t) \right)$ is referred to as a "survival time ratio". The *acceleration factor (AF)* quantifies the acceleration (or deceleration) of the event process that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. an acceleration factor of 0.5 means that a unit-increase in the covariate leads to an individual approaching the event at half the speed. If you find that somewhat confusing, then it may be easier to think about the *survival time ratio (STR)* . The *survival time ratio* is the inverse of the acceleration factor (i.e. $STR = 1/AF$). The *survival time ratio* is interpreted as the increase (or decrease) in the expected survival time that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a survival time ratio of 2 (which is equivalent to an acceleration factor of 0.5) means that a unit-increase in the covariate leads to an doubling in the expected survival time. - -**Note:** in the `stan_surv` modelling function the user specifies that they wish to estimate a time-varying acceleration factor for a covariate by wrapping the covariate name in the `tve()` function in the model formula; see the examples in the latter part of this vignette. +The quantity $\exp \left( - \beta_p^*(t) \right)$ is referred to as an "acceleration factor" and the quantity $\exp \left( \beta_p^*(t) \right)$ is referred to as a "survival time ratio". The *acceleration factor* (AF) quantifies the acceleration (or deceleration) of the event process that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. an acceleration factor of 0.5 means that a unit-increase in the covariate leads to an individual approaching the event at half the speed. If you find that somewhat confusing, then it may be easier to think about the survival time ratio. The *survival time ratio* (STR) is interpreted as the increase (or decrease) in the expected survival time that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a survival time ratio of 2 (which is equivalent to an acceleration factor of 0.5) means that a unit-increase in the covariate leads to an doubling in the expected survival time. The survival time ratio is equal to the inverse of the acceleration factor (i.e. $\text{STR} = 1/\text{AF}$). ### Distributions -- **Exponential model** (`basehaz = "exp-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\eta_i(t) )$ we have +- **Exponential model** (`basehaz = "exp-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\eta_i(t) )$ we have: \ \begin{equation} S_i(t) = \exp \left( - t \lambda_i \right) \end{equation} \ -or in the case with time-varying effects +or in the case with a time-varying linear predictor: \ \begin{equation} S_i(t) = \exp \left( - \int_0^t \exp ( -\eta_i(u) ) du \right) \end{equation} -- **Weibull model** (`basehaz = "weibull-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\gamma \eta_i(t) )$ and shape parameter $\gamma > 0$ we have +- **Weibull model** (`basehaz = "weibull-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\gamma \eta_i(t) )$ and shape parameter $\gamma > 0$ we have: \ \begin{equation} S_i(t) = \exp \left( - t^{\gamma} \lambda_i \right) \end{equation} \ -or in the case with time-varying effects +or in the case with a time-varying linear predictor: \ \begin{equation} S_i(t) = \exp \left( - \left[ \int_0^t \exp ( -\eta_i(u) ) du \right]^{\gamma} \right) \end{equation} -**Note:** when the linear predictor *is not* time-varying (i.e. under time-fixed acceleration), there is a closed form expression for both the hazard function and survival function; details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under time-varying acceleration) there is no closed form expression for the hazard function or survival probability; instead, quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate the hazard function and survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. +**Note:** When the linear predictor *is not* time-varying (i.e. under time-fixed acceleration), there is a closed form expression for both the hazard function and survival function; details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under time-varying acceleration) there is no closed form expression for the hazard function or survival probability; instead, quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate the hazard function and survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. + +## Time-fixed and time-varying effects of covariates + +The coefficient $\beta_p(t)$ (i.e. the log hazard ratio) or $\beta_p^*(t)$ (i.e. log survival time ratio) can be treated as a time-fixed quantity (e.g. $\beta_p(t) = \beta_p$) or as a time-varying quantity. We refer to the latter as *time-varying effects* because the effect of the covariate is allowed to change as a function of time. In `stan_surv` time-varying effects are specified by using the `tde` function in the model formula. Note that in the following definitions we only refer to $\beta_p(t)$ (i.e. the log hazard ratio) but the same methodology applies to $\beta_p^*(t)$ (i.e. the log survival time ratio). + +Without time-varying effects we have: +\ +\begin{equation} +\begin{split} +\beta_p(t) = \theta_{p0} +\end{split} +\end{equation} +\ +such that $\theta_{p0}$ is a time-fixed log hazard ratio (or log survival time ratio). + +With **time-varying effects modelled using B-splines** we have: +\ +\begin{equation} +\begin{split} +\beta_p(t) = \theta_{p0} + \sum_{m=1}^{M} \theta_{pm} B_{m}(t; \boldsymbol{k}, \delta) +\end{split} +\end{equation} +\ +where $\theta_{p0}$ is a constant, $B_{m}(t; \boldsymbol{k}, \delta)$ is the $m^{\text{th}}$ $(m = 1,...,M)$ basis term for a degree $\delta$ B-spline function evaluated at a vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$, and $\theta_{pm}$ is the $m^{\text{th}}$ B-spline coefficient. By default cubic B-splines are used (i.e. $\delta = 3$). These allow the time-varying log hazard ratio (or log survival time ratio) to be modelled as a smooth function of time. + +The degrees of freedom is equal to the number of additional parameters required to estimate a time-varying coefficient relative to a time-fixed coefficient. When a B-spline function is used to model the time-varying coefficient the degrees of freedom are $M = J + \delta - 2$ where $J$ is the total number of knots (including boundary knots). + +The vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ includes a lower boundary knot $k_{1}$ at the earliest entry time (equal to zero if there isn't delayed entry) and an upper boundary knot $k_{J}$ at the latest event or censoring time. Internal knot locations (that is $k_{2},...,k_{(J-1)}$ when $J \geq 3$) can be explicitly specified by the user (see the `knots` argument to the `tve` function) or are determined by default. The default is to place the internal knots at equally spaced percentiles of the distribution of uncensored event times. However the `tve` function uses default values $\delta = 3$ and $M = 3$ which in fact corresponds to a cubic B-spline function with no internal knots. + +With **time-varying effects modelled using a piecewise constant function** we have: +\ +\begin{equation} +\begin{split} +\beta_p(t) = \theta_{p0} + \sum_{m=1}^{M} \theta_{pm} I(k_{m} < t \leq k_{m+1}) +\end{split} +\end{equation} +\ +where $I(x)$ is an indicator function taking value 1 if $x$ is true and 0 otherwise, $\theta_{p0}$ is a constant corresponding to the log hazard ratio (or log survival time ratio for AFT models) in the first time interval, $\theta_{pm}$ is the deviation in the log hazard ratio (or log survival time ratio) between the first and $(m+1)^\text{th}$ $(m = 1,...,M)$ time interval, and $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ is a sequence of knot locations (i.e. break points) defining the upper limit of each of the $J$ time intervals where $k_{J}$ is set equal to the maximum event or censoring time. This allows the hazard ratio (or survival time ratio) to be modelled as a piecewise constant function of time. + +The degrees of freedom is equal to the number of additional parameters required to estimate a time-varying coefficient relative to a time-fixed coefficient. When a piecewise constant function is used to model the time-varying coefficient the degrees of freedom are $M = J - 1$ where $J$ is the total number of time intervals. + +The *internal* knot locations $k_{1},...,k_{J-1}$ can be explicitly specified by the user (see the `knots` argument to the `tve` function) or determined by default. The default is to place the internal knots at equally spaced percentiles of the distribution of uncensored event times. The boundary knot $k_{J}$ is always placed at the uppermost event or censoring time and cannot be changed by the user. The `tve` function uses $M = 3$ by default which corresponds to internal knots at the $25^{\text{th}}$, $50^{\text{th}}$, and $75^{\text{th}}$ percentiles of the distribution of the uncensored event times. + +**Note:** We have dropped the subscript $p$ from the knot locations $\boldsymbol{k}$ and degree of the B-splines $\delta$ discussed above. This is just for simplicity of the notation. In fact, if a model has time-varying effects estimated for more than one covariate, then each these can be modelled using different knot locations and/or degree if the user desires. ## Likelihood -Allowing for the three forms of censoring, and potential delayed entry (i.e. left truncation), the likelihood takes the form +Allowing for the three forms of censoring and potential delayed entry (i.e. left truncation) the likelihood for the survival model takes the form: \ \begin{align} \begin{split} @@ -302,9 +316,9 @@ These choices are described in greater detail in the `stan_surv` or `priors` hel The prior distribution for the intercept parameter in the linear predictor is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. The default is a normal distribution with mean zero and scale 20. Note that -- internally (but not in the reported parameter estimates) -- the prior is placed on the intercept *after* centering the predictors at their sample means and *after* applying a constant shift of $\log \left( \frac{E}{T} \right)$ where $E$ is the total number of events and $T$ is the total follow up time. For example, a prior specified by the user as `prior_intercept = normal(0,20)` is in fact not centered on an intercept of zero when all predictors are at their sample means, but rather, it is centered on the log crude event rate when all predictors are at their means. This is intended to help with numerical stability and sampling, but does not impact on the reported estimates (i.e. the intercept is back-transformed before being returned to the user). -The choice of prior distribution for the time-fixed coefficients $\theta_{p,0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. +The choice of prior distribution for the time-fixed coefficients $\theta_{p0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. -The B-spline coefficients related to each time-varying effect, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. +The B-spline coefficients or the interval-specific deviations in the piecewise constant function, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. # Usage examples From 08d75aa9370fcc50b44a8a9e8e3a527919b1125a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 15 May 2019 14:29:38 +1000 Subject: [PATCH 147/225] More additions to stan_surv vigenette (technical details) --- vignettes/surv.Rmd | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index f6dc72a63..3dc81ce34 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -266,27 +266,25 @@ With **time-varying effects modelled using B-splines** we have: \end{split} \end{equation} \ -where $\theta_{p0}$ is a constant, $B_{m}(t; \boldsymbol{k}, \delta)$ is the $m^{\text{th}}$ $(m = 1,...,M)$ basis term for a degree $\delta$ B-spline function evaluated at a vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$, and $\theta_{pm}$ is the $m^{\text{th}}$ B-spline coefficient. By default cubic B-splines are used (i.e. $\delta = 3$). These allow the time-varying log hazard ratio (or log survival time ratio) to be modelled as a smooth function of time. +where $\theta_{p0}$ is a constant, $B_{m}(t; \boldsymbol{k}, \delta)$ is the $m^{\text{th}}$ $(m = 1,...,M)$ basis term for a degree $\delta$ B-spline function evaluated at a vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$, and $\theta_{pm}$ is the $m^{\text{th}}$ B-spline coefficient. By default cubic B-splines are used (i.e. $\delta = 3$). These allow the log hazard ratio (or log survival time ratio) to be modelled as a smooth function of time. The degrees of freedom is equal to the number of additional parameters required to estimate a time-varying coefficient relative to a time-fixed coefficient. When a B-spline function is used to model the time-varying coefficient the degrees of freedom are $M = J + \delta - 2$ where $J$ is the total number of knots (including boundary knots). -The vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ includes a lower boundary knot $k_{1}$ at the earliest entry time (equal to zero if there isn't delayed entry) and an upper boundary knot $k_{J}$ at the latest event or censoring time. Internal knot locations (that is $k_{2},...,k_{(J-1)}$ when $J \geq 3$) can be explicitly specified by the user (see the `knots` argument to the `tve` function) or are determined by default. The default is to place the internal knots at equally spaced percentiles of the distribution of uncensored event times. However the `tve` function uses default values $\delta = 3$ and $M = 3$ which in fact corresponds to a cubic B-spline function with no internal knots. - With **time-varying effects modelled using a piecewise constant function** we have: \ \begin{equation} \begin{split} -\beta_p(t) = \theta_{p0} + \sum_{m=1}^{M} \theta_{pm} I(k_{m} < t \leq k_{m+1}) +\beta_p(t) = \theta_{p0} + \sum_{m=1}^{M} \theta_{pm} I(k_{m+1} < t \leq k_{m+2}) \end{split} \end{equation} \ -where $I(x)$ is an indicator function taking value 1 if $x$ is true and 0 otherwise, $\theta_{p0}$ is a constant corresponding to the log hazard ratio (or log survival time ratio for AFT models) in the first time interval, $\theta_{pm}$ is the deviation in the log hazard ratio (or log survival time ratio) between the first and $(m+1)^\text{th}$ $(m = 1,...,M)$ time interval, and $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ is a sequence of knot locations (i.e. break points) defining the upper limit of each of the $J$ time intervals where $k_{J}$ is set equal to the maximum event or censoring time. This allows the hazard ratio (or survival time ratio) to be modelled as a piecewise constant function of time. +where $I(x)$ is an indicator function taking value 1 if $x$ is true and 0 otherwise, $\theta_{p0}$ is a constant corresponding to the log hazard ratio (or log survival time ratio for AFT models) in the first time interval, $\theta_{pm}$ is the deviation in the log hazard ratio (or log survival time ratio) between the first and $(m+1)^\text{th}$ $(m = 1,...,M)$ time interval, and $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ is a sequence of knot locations (i.e. break points) that includes the lower and upper boundary knots. This allows the log hazard ratio (or log survival time ratio) to be modelled as a piecewise constant function of time. -The degrees of freedom is equal to the number of additional parameters required to estimate a time-varying coefficient relative to a time-fixed coefficient. When a piecewise constant function is used to model the time-varying coefficient the degrees of freedom are $M = J - 1$ where $J$ is the total number of time intervals. +The degrees of freedom is equal to the number of additional parameters required to estimate a time-varying coefficient relative to a time-fixed coefficient. When a piecewise constant function is used to model the time-varying coefficient the degrees of freedom are $M = J - 2$ where $J$ is the total number of knots (including boundary knots). -The *internal* knot locations $k_{1},...,k_{J-1}$ can be explicitly specified by the user (see the `knots` argument to the `tve` function) or determined by default. The default is to place the internal knots at equally spaced percentiles of the distribution of uncensored event times. The boundary knot $k_{J}$ is always placed at the uppermost event or censoring time and cannot be changed by the user. The `tve` function uses $M = 3$ by default which corresponds to internal knots at the $25^{\text{th}}$, $50^{\text{th}}$, and $75^{\text{th}}$ percentiles of the distribution of the uncensored event times. +**Default knot locations:** The vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ includes a lower boundary knot $k_{1}$ at the earliest entry time (equal to zero if there isn't delayed entry) and an upper boundary knot $k_{J}$ at the latest event or censoring time. The boundary knots cannot be changed by the user. Internal knot locations -- that is $k_{2},...,k_{(J-1)}$ when $J \geq 3$ -- can be explicitly specified by the user (see the `knots` argument to the `tve` function) or are determined by default. The default is to place the internal knots at equally spaced percentiles of the distribution of uncensored event times. When a B-spline function is specified, the `tve` function uses default values $M = 3$ (degrees of freedom) and $\delta = 3$ (cubic splines) which in fact corresponds to a cubic B-spline function with no internal knots. When a piecewise constant function is specified, the `tve` function uses a default value of $M = 3$ (degrees of freedom) which corresponds to internal knots at the $25^{\text{th}}$, $50^{\text{th}}$, and $75^{\text{th}}$ percentiles of the distribution of the uncensored event times. -**Note:** We have dropped the subscript $p$ from the knot locations $\boldsymbol{k}$ and degree of the B-splines $\delta$ discussed above. This is just for simplicity of the notation. In fact, if a model has time-varying effects estimated for more than one covariate, then each these can be modelled using different knot locations and/or degree if the user desires. +**Note on subscripts:** We have dropped the subscript $p$ from the knot locations $\boldsymbol{k}$ and degree of the B-splines $\delta$ discussed above. This is just for simplicity of the notation. In fact, if a model has time-varying effects estimated for more than one covariate, then each these can be modelled using different knot locations and/or degree if the user desires. ## Likelihood @@ -318,7 +316,7 @@ The prior distribution for the intercept parameter in the linear predictor is sp The choice of prior distribution for the time-fixed coefficients $\theta_{p0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. -The B-spline coefficients or the interval-specific deviations in the piecewise constant function, that is $\boldsymbol{\theta_p}$, are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. +The additional coefficients required for estimating time-varying effects (i.e. the B-spline coefficients or the interval-specific deviations in the piecewise constant function) are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. # Usage examples From c5c0c978f8c1951ea4acf164d62cba27bf98734e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 15 May 2019 15:44:31 +1000 Subject: [PATCH 148/225] More changes to stan_surv vignette --- vignettes/surv.Rmd | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 3dc81ce34..a9f5fb07e 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -162,7 +162,7 @@ h_i(t) = \lambda_i(t) h_i(t) = \gamma t^{\gamma-1} \lambda_i(t) \end{equation} -- **Gompertz model** (`basehaz = "gompertz"`): for shape parameter $\lambda = \exp ( \eta_i(t) )$ and scale parameter $\gamma > 0$ we have: +- **Gompertz model** (`basehaz = "gompertz"`): for shape parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and scale parameter $\gamma > 0$ we have: \ \begin{equation} h_i(t) = \exp(\gamma t) \lambda_i(t) @@ -218,29 +218,33 @@ The quantity $\exp \left( - \beta_p^*(t) \right)$ is referred to as an "accelera ### Distributions -- **Exponential model** (`basehaz = "exp-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\eta_i(t) )$ we have: +- **Exponential model** (`basehaz = "exp-aft"`): When the linear predictor is time-varying we have: \ \begin{equation} -S_i(t) = \exp \left( - t \lambda_i \right) +S_i(t) = \exp \left( - \int_0^t \exp ( -\eta_i(u) ) du \right) \end{equation} \ -or in the case with a time-varying linear predictor: +and when the linear predictor is time-fixed we have: \ \begin{equation} -S_i(t) = \exp \left( - \int_0^t \exp ( -\eta_i(u) ) du \right) +S_i(t) = \exp \left( - t \lambda_i \right) \end{equation} +\ +for scale parameter $\lambda_i = \exp ( -\eta_i )$. -- **Weibull model** (`basehaz = "weibull-aft"`): for scale parameter $\lambda_i(t) = \exp ( -\gamma \eta_i(t) )$ and shape parameter $\gamma > 0$ we have: +- **Weibull model** (`basehaz = "weibull-aft"`): When the linear predictor is time-varying we have: \ \begin{equation} -S_i(t) = \exp \left( - t^{\gamma} \lambda_i \right) +S_i(t) = \exp \left( - \left[ \int_0^t \exp ( -\eta_i(u) ) du \right]^{\gamma} \right) \end{equation} \ -or in the case with a time-varying linear predictor: +for shape parameter $\gamma > 0$ and when the linear predictor is time-fixed we have: \ \begin{equation} -S_i(t) = \exp \left( - \left[ \int_0^t \exp ( -\eta_i(u) ) du \right]^{\gamma} \right) +S_i(t) = \exp \left( - t^{\gamma} \lambda_i \right) \end{equation} +\ +for scale parameter $\lambda_i = \exp ( -\gamma \eta_i )$ and shape parameter $\gamma > 0$. **Note:** When the linear predictor *is not* time-varying (i.e. under time-fixed acceleration), there is a closed form expression for both the hazard function and survival function; details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under time-varying acceleration) there is no closed form expression for the hazard function or survival probability; instead, quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate the hazard function and survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. From ac67a475e20665b9fdb7feba387c1ad248655080 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 15 May 2019 17:58:19 +1000 Subject: [PATCH 149/225] Update examples in stan_surv vignette --- vignettes/surv.Rmd | 109 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 85 insertions(+), 24 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index a9f5fb07e..3c2eca180 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -37,7 +37,6 @@ h1 { /* Header 1 */ knitr::opts_chunk$set(fig.width=10, fig.height=4) library(rstanarm) set.seed(989898) -ITER <- 50 ``` @@ -333,8 +332,12 @@ $N = 686$ patients with primary node positive breast cancer recruited between 19 First, let us load the data and fit the proportional hazards model ```{r, warning = FALSE, message = FALSE, results='hide'} -fm <- Surv(recyrs, status) ~ group -mod1 <- stan_surv(fm, data = bcancer, seed = 123321) +mod1 <- stan_surv(formula = Surv(recyrs, status) ~ group, + data = bcancer, + chains = CHAINS, + cores = CORES, + seed = SEED, + iter = ITER) ``` The model here is estimated using the default cubic M-splines (with 5 degrees of freedom) for modelling the baseline hazard. Since there are no time-varying effects in the model (i.e. we did not wrap any covariates in the `tve()` function) there is a closed form expression for the cumulative hazard and survival function and so the model is relatively fast to fit. Specifically, the model takes ~3.5 sec for each MCMC chain based on the default 2000 (1000 warm up, 1000 sampling) MCMC iterations. @@ -350,13 +353,12 @@ We see from this output we see that individuals in the groups with `Poor` or `Me It may also be of interest to compare the different types of the baseline hazard we could potentially use. Here, we will fit a series of models, each with a different baseline hazard specification ```{r, warning = FALSE, message = FALSE, results='hide'} -mod1_exp <- stan_surv(fm, data = bcancer, basehaz = "exp") -mod1_weibull <- stan_surv(fm, data = bcancer, basehaz = "weibull") -mod1_gompertz <- stan_surv(fm, data = bcancer, basehaz = "gompertz") -mod1_bspline <- stan_surv(fm, data = bcancer, basehaz = "bs") -mod1_mspline1 <- stan_surv(fm, data = bcancer, basehaz = "ms") -mod1_mspline2 <- stan_surv(fm, data = bcancer, basehaz = "ms", - basehaz_ops = list(df = 10)) +mod1_exp <- update(mod1, basehaz = "exp") +mod1_weibull <- update(mod1, basehaz = "weibull") +mod1_gompertz <- update(mod1, basehaz = "gompertz") +mod1_bspline <- update(mod1, basehaz = "bs") +mod1_mspline1 <- update(mod1, basehaz = "ms") +mod1_mspline2 <- update(mod1, basehaz = "ms", basehaz_ops = list(df = 10)) ``` and then plot the baseline hazards with 95% posterior uncertainty limits using the generic `plot` method for `stansurv` objects (note that the default `plot` for `stansurv` objects is the estimated baseline hazard). We will write a little helper function to adjust the y-axis limits, add a title, and centre the title, on each plot, as follows @@ -441,14 +443,14 @@ plot(ph) + We can quite clearly see in the plot the assumption of proportional hazards. We can also see that the hazard is highest in the `Poor` prognosis group (i.e. worst survival) and the hazard is lowest in the `Good` prognosis group (i.e. best survival). This corresponds to what we saw in the plot of the survival functions previously. -## Example: a model with non-proportional hazards +## Example: non-proportional hazards modelled using B-splines To demonstrate the implementation of time-varying effects in `stan_surv` we will use a simulated dataset, generated using the **simsurv** package (Brilleman, 2018). We will simulate a dataset with $N = 200$ individuals with event times generated under the following Weibull hazard function \ \begin{align} -h_i(t) = \gamma t^{\gamma-1} \lambda exp( \beta(t) x_i ) +h_i(t) = \gamma t^{\gamma-1} \lambda \exp( \beta(t) x_i ) \end{align} \ with scale parameter $\lambda = 0.1$, shape parameter $\gamma = 1.5$, binary baseline covariate $X_i \sim \text{Bern}(0.5)$, and time-varying hazard ratio $\beta(t) = -0.5 + 0.2 t$. We will enforce administrative censoring at 5 years if an individual's simulated event time is >5 years. @@ -461,14 +463,14 @@ library(simsurv) set.seed(999111) # simulate covariate data -covs <- data.frame(id = 1:100, - trt = rbinom(100, 1L, 0.5)) +covs <- data.frame(id = 1:200, + trt = rbinom(200, 1L, 0.5)) # simulate event times dat <- simsurv(lambdas = 0.1, gammas = 1.5, betas = c(trt = -0.5), - tve = c(trt = 0.2), + tde = c(trt = 0.2), x = covs, maxt = 5) @@ -481,29 +483,88 @@ head(dat) Now that we have our simulated dataset, let us fit a model with time-varying hazard ratio for `trt` -```{r, warning = FALSE, message = FALSE, results='hide'} -fm <- Surv(eventtime, status) ~ tve(trt) -mod2 <- stan_surv(formula = fm, data = dat, seed = 5544, iter = 500) +```{r tve_fit1, warning = FALSE, message = FALSE, results='hide'} +mod2 <- stan_surv(formula = Surv(eventtime, status) ~ tve(trt), + data = dat, + chains = CHAINS, + cores = CORES, + seed = SEED, + iter = ITER) ``` -By default the cubic B-spline basis used for modelling the time-varying hazard ratio is evaluated with 3 degrees of freedom (i.e. two boundary knots placed at the limits of the range of event times, but no internal knots). For a more or less flexible spline function we can specify the `df` arugment to `tve()` function. For example, we could specify the model formula as +The `tve` function is used in the model formula to state that we want a time-varying effect (i.e. a time-varying coefficient) to be estimated for the variable `trt`. By default, a cubic B-spline basis with 3 degrees of freedom (i.e. two boundary knots placed at the limits of the range of event times, but no internal knots) is used for modelling the time-varying log hazard ratio. If we wanted to change the degree, knot locations, or degrees of freedom for the B-spline function we can specify additional arguments to the `tve` function. + +For example, to model the time-varying log hazard ratio using quadratic B-splines with 4 degrees of freedom (i.e. two boundary knots placed at the limits of the range of event times, as well as two internal knots placed -- by default -- at the 33.3rd and 66.6th percentiles of the distribution of uncensored event times) we could specify the model formula as ```{r, warning = FALSE, message = FALSE, results='hide', eval=FALSE} -fm <- Surv(eventtime, status) ~ tve(trt, df = 5) +Surv(eventtime, status) ~ tve(trt, df = 4, degree = 2) ``` -so that we use 5 degrees of freedom for modelling the time-varying effect (i.e. two boundary knots placed at the limits of the range of event times, as well as two internal knots placed - by default - at the 33.3rd and 66.6th percentiles of the distribution of uncensored event times). - Let us now plot the estimated time-varying hazard ratio from the fitted model. We can do this using the generic `plot` method for `stansurv` objects, for which we can specify the `plotfun = "tve"` argument. (Note that in this case, there is only one covariate in the model with a time-varying effect, but if there were others, we could specify which covariate(s) we want to plot the time-varying effect for by specifying the `pars` argument to the `plot` call). ```{r, fig.height=5} plot(mod2, plotfun = "tve") ``` -From the plot, we can see how the hazard ratio (i.e. the effect of treatment on the hazard of the event) changes as a function of time. The treatment appears to be protective during the first few years following baseline (i.e. HR < 1), and then the treatment appears to become harmful after about 4 years post-baseline (of course, this is the model we simulated under!). +From the plot, we can see how the hazard ratio (i.e. the effect of treatment on the hazard of the event) changes as a function of time. The treatment appears to be protective during the first few years following baseline (i.e. HR < 1), and then the treatment appears to become harmful after about 4 years post-baseline. Thankfully, this is a reflection of the model we simulated under! + +The plot shows a large amount of uncertainty around the estimated time-varying hazard ratio. This is to be expected, since we only simulated a dataset of 200 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-varying hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-varying hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-varying hazard ratio equals 1 at around ~3 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. + +## Example: non-proportional hazards modelled using a piecewise constant function + +In the previous example we showed how non-proportional hazards can be modelled by using a smooth B-spline function for the time-varying log hazard ratio. This is the default approach when the `tve` function is used to estimate a time-varying effect for a covariate in the model formula. However, another approach for modelling a time-varying log hazard ratio is to use a piecewise constant function. If we want to use a piecewise constant for the time-varying log hazard ratio (instead of the smooth B-spline function) then we just have to specify the `type` argument to the `tve` function. + +We will again simulate some survival data using the **simsurv** package (Brilleman, 2018) to show how a piecewise constant hazard ratio can be estimated using `stan_surv`. +Similar to the previous example, we will simulate a dataset with $N = 500$ individuals with event times generated under a Weibull hazard function with scale parameter $\lambda = 0.1$, shape parameter $\gamma = 1.5$, and binary baseline covariate $X_i \sim \text{Bern}(0.5)$. However, in this example our time-varying hazard ratio will be defined as $\beta(t) = -0.5 + 0.7 \times I(t > 2.5)$ where $I(X)$ is the indicator function taking the value 1 if $X$ is true and 0 otherwise. This corresponds to a piecewise constant log hazard ratio with just two "pieces" or time intervals. The first time interval is $[0,2.5]$ during which the true hazard ratio is $\exp(-0.5) = 0.61$. The second time interval is $(2.5,\infty]$ during which the true log hazard ratio is $\exp(-0.5 + 0.7) = 1.22$. Our example uses only two time intervals for simplicity, but in general we could easily have considered more (although it would have required couple of additional lines of code to simulate the data). We will again enforce administrative censoring at 5 years if an individual's simulated event time is >5 years. + +```{r simsurv-simdata2} +# load package +library(simsurv) + +# set seed for reproducibility +set.seed(888222) + +# simulate covariate data +covs <- data.frame(id = 1:500, + trt = rbinom(500, 1L, 0.5)) -The plot shows a large amount of uncertainty around the estimated time-varying hazard ratio. This is to be expected, since we only simulated a dataset of 100 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-varying hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-varying hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-varying hazard ratio equals 1 at around ~3 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. +# simulate event times +dat <- simsurv(lambdas = 0.1, + gammas = 1.5, + betas = c(trt = -0.5), + tde = c(trt = 0.7), + tdefun = function(t) (t > 2.5), + x = covs, + maxt = 5) + +# merge covariate data and event times +dat <- merge(dat, covs) + +# examine first few rows of data +head(dat) +``` + +We know estimate a model with a piecewise constant time-varying effect for the covariate `trt` as + +```{r tve_fit2, warning = FALSE, message = FALSE, results='hide'} +mod3 <- stan_surv(formula = Surv(eventtime, status) ~ + tve(trt, type = "pw", knots = 2.5), + data = dat, + chains = CHAINS, + cores = CORES, + seed = SEED, + iter = ITER) +``` + +This time we specify some additional arguments to the `tve` function, so that our time-varying effect corresponds to the true data generating model used to simulate our event times. Specifically, we specify `type = "pw"` to say that we want the time-varying effect (i.e. the time-varying log hazard ratio) to be estimated using a piecewise constant function and `knots = 2.5` says that we only want one internal knot placed at the time $t = 2.5$. + +We can again use the generic `plot` function with argument `plotfun = "tve"` to examine our estimated hazard ratio for treatment + +```{r, fig.height=5} +plot(mod3, plotfun = "tve") +``` +Here we see that the estimated hazard ratio reasonably reflects our true data generating model (i.e. a hazard ratio of $\approx 0.6$ during the first time interval and a hazard ratio of $\approx 1.2$ during the second time interval) although there is a slight discrepancy due to the sampling variation in the simulated event times. # References From 12d752d6c7336cd52410939ff9365c066c908b0f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 16 May 2019 14:25:31 +1000 Subject: [PATCH 150/225] Fix up capitalisation for pbcLong dataset documentation --- R/doc-datasets.R | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/R/doc-datasets.R b/R/doc-datasets.R index 599dc177a..4cf5b0365 100644 --- a/R/doc-datasets.R +++ b/R/doc-datasets.R @@ -140,21 +140,20 @@ #' #' 304 obs. of 8 variables (\code{pbcLong}) and 40 obs. of 7 variables (\code{pbcSurv}) #' \itemize{ -#' \item \code{age} {in years} -#' \item \code{albumin} {serum albumin (g/dl)} -#' \item \code{logBili} {logarithm of serum bilirubin} -#' \item \code{death} {indicator of death at endpoint} -#' \item \code{futimeYears} {time (in years) between baseline and -#' the earliest of death, transplantion or censoring} -#' \item \code{id} {numeric ID unique to each individual} -#' \item \code{platelet} {platelet count} -#' \item \code{sex} {gender (m = male, f = female)} -#' \item \code{status} {status at endpoint (0 = censored, -#' 1 = transplant, 2 = dead)} -#' \item \code{trt} {binary treatment code (0 = placebo, 1 = -#' D-penicillamine)} -#' \item \code{year} {time (in years) of the longitudinal measurements, -#' taken as time since baseline)} +#' \item \code{age} Age (in years) +#' \item \code{albumin} Serum albumin (g/dl) +#' \item \code{logBili} Logarithm of serum bilirubin +#' \item \code{death} Indicator of death at endpoint +#' \item \code{futimeYears} Time (in years) between baseline and +#' the earliest of death, transplantion or censoring +#' \item \code{id} Numeric ID unique to each individual +#' \item \code{platelet} Platelet count +#' \item \code{sex} Gender (m = male, f = female) +#' \item \code{status} Status at endpoint (0 = censored, 1 = transplant, +#' 2 = dead) +#' \item \code{trt} Binary treatment code (0 = placebo, 1 = D-penicillamine) +#' \item \code{year} Time (in years) of the longitudinal measurements, +#' taken as time since baseline #' } #' } #' From 8d4d23d585cbb8af5a3519b4550477465e9de243 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 16 May 2019 17:41:16 +1000 Subject: [PATCH 151/225] pp_data.R & log_lik.R: add stan_surv frailty models --- R/log_lik.R | 59 +++++++++++++++++++++++++-------- R/misc.R | 4 ++- R/pp_data.R | 55 ++++++++++++++++++++++++------ R/stan_surv.R | 14 +++++--- tests/testthat/test_stan_surv.R | 15 ++++++--- 5 files changed, 114 insertions(+), 33 deletions(-) diff --git a/R/log_lik.R b/R/log_lik.R index db863a04a..08731d4b3 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -438,6 +438,19 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { data <- cbind(data, x) } + # also evaluate random effects structure if relevant + if (object$has_bars) { + z <- t(pp$z$Zt) + if (object$has_quadrature) { + z <- rbind(z, + t(pp_qpts_beg$z$Zt), + t(pp_qpts_end$z$Zt), + t(pp_qpts_upp$z$Zt)) + } + z <- append_prefix_to_colnames(as.matrix(z), "z__") + data <- cbind(data, z) + } + # parameter draws draws <- list() pars <- extract_pars(object) @@ -446,7 +459,10 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { draws$alpha <- pars$alpha draws$beta <- pars$beta draws$beta_tve <- pars$beta_tve + draws$b <- if (object$has_bars) pp_b_ord(pars$b, pp$z$Z_names) else NULL draws$has_quadrature <- pp$has_quadrature + draws$has_tve <- pp$has_tve + draws$has_bars <- pp$has_bars draws$qnodes <- pp$qnodes out <- nlist(data, draws, S = NROW(draws$beta), N = n_distinct(cids)) @@ -515,6 +531,11 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { sel <- grep("^s__", nms) data[, sel] } +.zdata_surv <- function(data) { + nms <- colnames(data) + sel <- grep("^z__", nms) + data[, sel] +} # log-likelihood functions ------------------------------------------------ .ll_gaussian_i <- function(data_i, draws) { @@ -594,6 +615,25 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { .ll_surv_i <- function(data_i, draws) { + # fixed effects (time-fixed) part of linear predictor + eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) + + # fixed effects (time-varying) part of linear predictor + if (draws$has_tve) { + eta <- eta + linear_predictor(draws$beta_tve, .sdata_surv(data_i)) + } + + # random effects part of linear predictor + if (draws$has_bars) { + eta <- eta + linear_predictor(draws$b, .zdata_surv(data_i)) + } + + # convert linear predictor to log acceleration factor for AFT + eta <- switch(get_basehaz_name(draws$basehaz), + "exp-aft" = sweep(eta, 1L, -1, `*`), + "weibull-aft" = sweep(eta, 1L, -as.vector(draws$aux), `*`), + eta) + if (draws$has_quadrature) { qnodes <- draws$qnodes @@ -606,19 +646,16 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { idx_qpts_end <- 1 + (qnodes * 1) + (1:qnodes) idx_qpts_upp <- 1 + (qnodes * 2) + (1:qnodes) + # arguments to be used later in evaluating log baseline hazard args <- list(times = data_i$cpts, basehaz = draws$basehaz, aux = draws$aux, intercept = draws$alpha) - - eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) - eta <- eta + linear_predictor(draws$beta_tve, .sdata_surv(data_i)) - eta <- switch(get_basehaz_name(draws$basehaz), - "exp-aft" = sweep(eta, 1L, -1, `*`), - "weibull-aft" = sweep(eta, 1L, -as.vector(draws$aux), `*`), - eta) + + # evaluate log hazard lhaz <- eta + do.call(evaluate_log_basehaz, args) + # evaluate log likelihood if (status == 1) { # uncensored lhaz_epts <- lhaz[, idx_epts, drop = FALSE] @@ -667,16 +704,12 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { status <- data_i$status delayed <- data_i$delayed + # arguments to be used later in evaluating log baseline hazard args <- list(basehaz = draws$basehaz, aux = draws$aux, intercept = draws$alpha) - eta <- linear_predictor(draws$beta, .xdata_surv(data_i)) - eta <- switch(get_basehaz_name(draws$basehaz), - "exp-aft" = sweep(eta, 1L, -1, `*`), - "weibull-aft" = sweep(eta, 1L, -as.vector(draws$aux), `*`), - eta) - + # evaluate log likelihood if (status == 1) { # uncensored args$times <- data_i$t_end diff --git a/R/misc.R b/R/misc.R index 1eaf1a0ab..2ee0dd37d 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1497,12 +1497,14 @@ extract_pars.stansurv <- function(object, stanmat = NULL, means = FALSE) { nms_smth <- get_smooth_name(object$s_cpts, type = "smooth_sd") nms_int <- get_int_name_basehaz(object$basehaz) nms_aux <- get_aux_name_basehaz(object$basehaz) + nms_b <- b_names(colnames(stanmat)) alpha <- stanmat[, nms_int, drop = FALSE] beta <- stanmat[, nms_beta, drop = FALSE] beta_tve <- stanmat[, nms_tve, drop = FALSE] aux <- stanmat[, nms_aux, drop = FALSE] smooth <- stanmat[, nms_smth, drop = FALSE] - nlist(alpha, beta, beta_tve, aux, smooth, stanmat) + b <- stanmat[, nms_b, drop = FALSE] + nlist(alpha, beta, beta_tve, aux, smooth, b, stanmat) } extract_pars.stanmvreg <- function(object, stanmat = NULL, means = FALSE) { diff --git a/R/pp_data.R b/R/pp_data.R index e52196a1c..3f625a0b2 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -295,10 +295,16 @@ pp_data <- } - #----- model frame for generating predictor matrices + #----- time-fixed predictor matrix + + # check all vars are in newdata + vars <- all.vars(delete.response(terms(object, fixed.only = FALSE))) + miss <- which(!vars %in% colnames(newdata)) + if (length(miss)) + stop2("The following variables are missing from the data: ", comma(vars[miss])) - # drop response from model terms - tt <- delete.response(terms(object, fixed.only = FALSE)) + # drop response from fixed effect formula + tt <- delete.response(terms(object, fixed.only = TRUE)) # make model frame based on time-fixed part of model formula mf <- make_model_frame(tt, newdata, xlevs = object$xlevs)$mf @@ -310,9 +316,12 @@ pp_data <- # check data classes in the model frame match those used in model fitting if (!is.null(cl <- attr(tt, "dataClasses"))) .checkMFClasses(cl, mf) + + # check model frame dimensions are correct (may be errors due to NAs?) + if (!length(pts) == nrow(mf)) + stop("Bug found: length of 'pts' should equal number rows in model frame.") - #----- time-fixed predictor matrix - + # construct time-fixed predictor matrix x <- make_x(tt, mf, check_constant = FALSE)$x #----- time-varying predictor matrix @@ -328,11 +337,15 @@ pp_data <- } # generate a model frame with time transformations for tve effects - mf_tve <- make_model_frame(formula$tt_frame, data.frame(times__ = pts_tmp))$mf + mf_s <- make_model_frame(formula$tt_frame, data.frame(times__ = pts_tmp))$mf - # NB next line avoids dropping terms attribute from 'mf' - mf[, colnames(mf_tve)] <- mf_tve + # check model frame dimensions are correct + if (!length(pts) == nrow(mf_s)) + stop("Bug found: length of 'pts' should equal number rows in model frame.") + # NB next line avoids dropping terms attribute from 'mf' + mf[, colnames(mf_s)] <- mf_s + # construct time-varying predictor matrix s <- make_s(formula, mf, xlevs = xlevs) @@ -348,13 +361,35 @@ pp_data <- } - #----- random effects predictor matrices + #----- random effects predictor matrix if (has_bars) { - ReTrms <- lme4::mkReTrms(formula$bars, mf) + + # drop response from random effects part of model formula + tt_z <- delete.response(terms(object, random.only = TRUE)) + + # make model frame based on random effects part of model formula + mf_z <- make_model_frame(formula = tt_z, + data = newdata, + xlevs = object$xlevs, + na.action = na.pass)$mf + + # if using quadrature then expand rows + if (has_quadrature && at_quadpoints) + mf_z <- rep_rows(mf_z, times = qnodes) + + # check model frame dimensions are correct + if (!length(pts) == nrow(mf_z)) + stop("Bug found: length of 'pts' should equal number rows in model frame.") + + # construct random effects predictor matrix + ReTrms <- lme4::mkReTrms(formula$bars, mf_z) z <- nlist(Zt = ReTrms$Zt, Z_names = make_b_nms(ReTrms)) + } else { + z <- list() + } # return object diff --git a/R/stan_surv.R b/R/stan_surv.R index 263b0fb40..892264657 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -2174,23 +2174,26 @@ make_model_data <- function(formula, data) { # mt: the model terms associated with the returned model frame. make_model_frame <- function(formula, data, - xlevs = NULL, + xlevs = NULL, drop.unused.levels = FALSE, - check_constant = FALSE) { + check_constant = FALSE, + na.action = na.fail) { # construct model frame Terms <- terms(lme4::subbars(formula)) mf <- stats::model.frame(Terms, data, xlev = xlevs, - drop.unused.levels = drop.unused.levels) + drop.unused.levels = drop.unused.levels, + na.action = na.action) # get predvars for fixed part of formula TermsF <- terms(lme4::nobars(formula)) mfF <- stats::model.frame(TermsF, data, xlev = xlevs, - drop.unused.levels = drop.unused.levels) + drop.unused.levels = drop.unused.levels, + na.action = na.action) attr(attr(mf, "terms"), "predvars.fixed") <- attr(attr(mfF, "terms"), "predvars") # get predvars for random part of formula @@ -2200,7 +2203,8 @@ make_model_frame <- function(formula, mfR <- stats::model.frame(TermsR, data, xlev = xlevs, - drop.unused.levels = drop.unused.levels) + drop.unused.levels = drop.unused.levels, + na.action = na.action) attr(attr(mf, "terms"), "predvars.random") <- attr(attr(mfR, "terms"), "predvars") } else { attr(attr(mf, "terms"), "predvars.random") <- NULL diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 589ea5f1b..708fe2e4f 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -459,7 +459,6 @@ for (i in names(tols$fixef)) info = "compare_estimates_tve_pw") - #-------- Check post-estimation functions work pbcSurv$t0 <- 0 @@ -468,12 +467,14 @@ pbcSurv$t0[pbcSurv$futimeYears > 2] <- 1 # delayed entry pbcSurv$t1 <- pbcSurv$futimeYears - 1 # lower limit for interval censoring pbcSurv$t1[pbcSurv$t1 <= 0] <- -Inf # left censoring +pbcSurv$clinic <- cut(pbcSurv$id, breaks = c(0,10,20,30,40), labels = FALSE) + # different baseline hazards o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, data = pbcSurv, basehaz = "ms", chains = 1, - iter = 60, + iter = 100, refresh = REFRESH, seed = SEED)) o<-SW(f2 <- update(f1, basehaz = "bs")) @@ -509,15 +510,21 @@ o<-SW(f25 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tve(trt))) # left and interval censoring o<-SW(f26 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) o<-SW(f27 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) -o<-SW(f28 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) +o<-SW(f28 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) o<-SW(f29 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) +# frailty models +o<-SW(f30 <- update(f1, Surv(futimeYears, death) ~ trt + (trt | clinic))) +o<-SW(f31 <- update(f1, Surv(futimeYears, death) ~ tve(trt) + (1 | clinic))) +o<-SW(f32 <- update(f1, Surv(t0, futimeYears, death) ~ trt + (trt | clinic))) +o<-SW(f33 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ trt + (trt | clinic))) + # new data for predictions nd1 <- pbcSurv[pbcSurv$id == 2,] nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] # test the models -for (j in c(15:21)) { +for (j in c(30:33)) { mod <- try(get(paste0("f", j)), silent = TRUE) From 2232c858133b058edab222fa2c73759f4c46c89a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 17 May 2019 18:26:02 +1000 Subject: [PATCH 152/225] posterior_survfit: handle fraily models & don't condition by default --- R/log_lik.R | 17 ++++- R/posterior_survfit.R | 164 +++++++++++++++++++++++++++--------------- 2 files changed, 119 insertions(+), 62 deletions(-) diff --git a/R/log_lik.R b/R/log_lik.R index 08731d4b3..6396ec8ad 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -1172,11 +1172,16 @@ log_basehaz_pw <- function(x, coefs, knots) { linear_predictor(coefs, dummy_matrix(x, knots = knots)) } -evaluate_log_haz <- function(times, basehaz, betas, betas_tve, aux, - intercept = NULL, x, s = NULL) { +evaluate_log_haz <- function(times, basehaz, betas, betas_tve, b = NULL, aux, + intercept = NULL, x, s = NULL, z = NULL) { eta <- linear_predictor(betas, x) if ((!is.null(s)) && ncol(s)) eta <- eta + linear_predictor(betas_tve, s) + if (!is.null(z$Zt) && ncol(z$Zt)) { + b <- pp_b_ord(b, z$Z_names) + z <- as.matrix(t(z$Zt)) + eta <- eta + linear_predictor(b, z) + } eta <- switch(get_basehaz_name(basehaz), "exp-aft" = sweep(eta, 1L, -1, `*`), "weibull-aft" = sweep(eta, 1L, -as.vector(aux), `*`), @@ -1230,8 +1235,14 @@ log_basesurv_ms <- function(x, coefs, basis, intercept) { linear_predictor(coefs, basis_matrix(x, basis = basis, integrate = TRUE)) } -evaluate_log_surv <- function(times, basehaz, betas, aux, intercept = NULL, x, ...) { +evaluate_log_surv <- function(times, basehaz, betas, b = NULL, aux, + intercept = NULL, x, z = NULL, ...) { eta <- linear_predictor(betas, x) + if (!is.null(z$Zt) && ncol(z$Zt)) { + b <- pp_b_ord(b, z$Z_names) + z <- as.matrix(t(z$Zt)) + eta <- eta + linear_predictor(b, z) + } eta <- switch(get_basehaz_name(basehaz), "exp-aft" = sweep(eta, 1L, -1, `*`), "weibull-aft" = sweep(eta, 1L, -as.vector(aux), `*`), diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 5fca39148..313331776 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -19,11 +19,16 @@ #' Posterior predictions for survival models #' #' This function allows us to generate predicted quantities for survival -#' models at specified times. These quantities include the -#' hazard rate, the cumulative hazard, or the survival probability. -#' Predictions are obtained using unique draws from the posterior distribution -#' of each of the model parameters and then summarised into a median and -#' posterior uncertainty interval. +#' models at specified times. These quantities include the hazard rate, +#' cumulative hazard, survival probability, or failure probability (i.e. CDF). +#' Note that the cumulative hazard, survival probability, or failure +#' probability may be conditional on a last known survival time (see the +#' \code{condition} argument discussed below). Predictions are obtained +#' using unique draws from the posterior distribution of each of the model +#' parameters and then summarised into a median and posterior uncertainty +#' interval. For \code{stan_jm} models "dynamic" predictions are also allowed +#' (see the \code{dynamic} argument discussed below). +#' #' #' @export #' @import splines2 @@ -45,10 +50,10 @@ #' is of course assumed that all individuals in \code{newdata} have not #' yet experienced the event (that is, any variable in \code{newdataEvent} #' that corresponds to the event indicator will be ignored). -#' @param newdataLong,newdataEvent Optionally, a data frame (or in the case of +#' @param newdataLong,newdataEvent An optional data frame (or in the case of #' \code{newdataLong} this can be a list of data frames) in which to look -#' for variables with which to predict. If omitted, the model matrices are used. -#' If new data is provided, then it should also contain the longitudinal +#' for variables with which to predict. If omitted, the model matrices are +#' used. If new data is provided, then it should also contain the longitudinal #' outcome data on which to condition when drawing the new group-specific #' coefficients for individuals in the new data. Note that there is only #' allowed to be one row of data for each individual in \code{newdataEvent}, @@ -58,14 +63,19 @@ #' individuals -- see the description for the \code{last_time} argument below #' -- however also note that when generating the survival probabilities it #' is of course assumed that all individuals in \code{newdataEvent} have not -#' yet experienced the event (that is, any variable in \code{newdataEvent} that -#' corresponds to the event indicator will be ignored). +#' yet experienced the event (that is, any variable in \code{newdataEvent} +#' that corresponds to the event indicator will be ignored). #' @param type The type of prediction to return. The following are currently #' allowed: #' \itemize{ #' \item \code{"surv"}: the estimated survival probability. #' \item \code{"cumhaz"}: the estimated cumulative hazard. #' \item \code{"haz"}: the estimated hazard rate. +#' \item \code{"cdf"}: the estimated failure probability. +#' \item \code{"logsurv"}: the estimated log survival probability. +#' \item \code{"logcumhaz"}: the estimated log cumulative hazard. +#' \item \code{"loghaz"}: the estimated log hazard rate. +#' \item \code{"logcdf"}: the estimated log failure probability. #' } #' @param extrapolate A logical specifying whether to extrapolate the estimated #' survival probabilities beyond the times specified in the \code{times} argument. @@ -80,13 +90,14 @@ #' probabilities. The default is 10. #' \item \code{edist}: a positive scalar specifying the amount of time #' across which to forecast the estimated survival function, represented -#' in units of the time variable \code{time_var} (from fitting the model). -#' The default is to extrapolate between the times specified in the -#' \code{times} argument and the maximum event or censoring time in the -#' original data. If \code{edist} leads to times that are beyond -#' the maximum event or censoring time in the original data then the -#' estimated survival probabilities will be truncated at that point, since -#' the estimate for the baseline hazard is not available beyond that time. +#' in the same units of time as were used for the event times in the fitted +#' model. The default is to extrapolate between the times specified in the +#' \code{times} argument and the maximum event or censoring time found in +#' the original data used to fit the model. If \code{edist} leads to times +#' that are beyond the maximum event or censoring time in the original data +#' then the estimated survival probabilities will be truncated at that +#' point, since an estimate for the baseline hazard is not available +#' beyond that time. #' } #' @param condition A logical specifying whether the estimated #' subject-specific survival probabilities at time \code{t} should be @@ -117,8 +128,9 @@ #' If standardised survival probabilities are requested (i.e. #' \code{standardise = TRUE}) then conditional survival probabilities are #' not allowed and therefore the \code{last_time} argument is ignored. -#' @param ids An optional vector specifying a subset of IDs for whom the -#' predictions should be obtained. The default is to predict for all individuals +#' @param ids For \code{stan_jm} models. An optional vector specifying +#' a subset of IDs for whom the predictions should be obtained. +#' The default is to predict for all individuals #' who were used in estimating the model or, if \code{newdataLong} and #' \code{newdataEvent} are specified, then all individuals contained in #' the new data. @@ -146,10 +158,10 @@ #' then the \code{times} argument must be specified and it must be constant across #' individuals, that is, the survival probabilities must be calculated at the #' same time for all individuals. -#' @param dynamic A logical that is only relevant if new data is provided -#' via the \code{newdataLong} and \code{newdataEvent} arguments. If -#' \code{dynamic = TRUE}, then new group-specific parameters are drawn for -#' the individuals in the new data, conditional on their longitudinal +#' @param dynamic A logical that is only relevant for \code{stan_jm} models +#' when new data is provided via the \code{newdataLong} and \code{newdataEvent} +#' arguments. If \code{dynamic = TRUE}, then new group-specific parameters are +#' drawn for the individuals in the new data, conditional on their longitudinal #' biomarker data contained in \code{newdataLong}. These group-specific #' parameters are then used to generate individual-specific survival probabilities #' for these individuals. These are often referred to as "dynamic predictions" @@ -160,16 +172,21 @@ #' coefficients; this will mean that the predictions will incorporate all #' uncertainty due to between-individual variation so there will likely be #' very wide credible intervals on the predicted survival probabilities. -#' @param scale A scalar, specifying how much to multiply the asymptotic +#' @param scale Only relevant for \code{stan_jm} models when new data +#' is supplied and \code{dynamic = TRUE}, in which case new random effects +#' are simulated for the individuals in the new data using a +#' Metropolis-Hastings algorithm. The \code{scale} argument should be a +#' scalar. It specifies how much to multiply the asymptotic #' variance-covariance matrix for the random effects by, which is then #' used as the "width" (ie. variance-covariance matrix) of the multivariate -#' Student-t proposal distribution in the Metropolis-Hastings algorithm. This -#' is only relevant when \code{newdataEvent} is supplied and -#' \code{dynamic = TRUE}, in which case new random effects are simulated -#' for the individuals in the new data using the Metropolis-Hastings algorithm. -#' @param draws An integer indicating the number of MCMC draws to return. -#' The default is to set the number of draws equal to 200, or equal to the -#' size of the posterior sample if that is less than 200. +#' Student-t proposal distribution in the Metropolis-Hastings algorithm. +#' @param draws An integer specifying the number of MCMC draws to use when +#' evaluating the predicted quantities. For \code{stan_surv} models, the +#' default number of draws is the size of the posterior sample. +#' For \code{stan_jm} models, the default number of draws is 200 (or the +#' size of the posterior sample if that is less than 200). The smaller +#' default number of draws for \code{stan_jm} models is because dynamic +#' predictions (when \code{dynamic = TRUE}) can be slow. #' @param seed An optional \code{\link[=set.seed]{seed}} to use. #' @param ... Currently unused. #' @@ -229,7 +246,9 @@ #' (iii) an observation identifier (for \code{stan_surv} models) or an #' individual identifier (for \code{stan_jm} models), unless standardised #' predictions were requested; -#' (iv) the time that the prediction corresponds to. +#' (iv) the time that the prediction corresponds to (\code{time}). +#' (v) the last known survival time on which the prediction is conditional +#' (\code{cond_time}); this will be set to NA if not relevant. #' The returned object also includes a number of additional attributes. #' #' @seealso @@ -316,7 +335,7 @@ posterior_survfit.stansurv <- function(object, type = "surv", extrapolate = TRUE, control = list(), - condition = NULL, + condition = FALSE, last_time = NULL, prob = 0.95, times = NULL, @@ -351,6 +370,14 @@ posterior_survfit.stansurv <- function(object, id_list <- seq(nrow(newdata)) } + # Error checks for conditional predictions + if (condition) { + if (standardise) + stop("'condition' cannot be TRUE for standardised predictions.") + if (type %in% c("haz", "loghaz")) + stop("'condition' cannot be TRUE when 'type = \"", type, "\"'.") + } + # Last known survival time for each individual if (is.null(newdata)) { # user did not specify newdata if (!is.null(last_time)) @@ -429,13 +456,6 @@ posterior_survfit.stansurv <- function(object, time_seq <- list(times) # no extrapolation } - # Conditional survival times - if (is.null(condition)) { - condition <- ifelse(type == "surv", !standardise, FALSE) - } else if (condition && standardise) { - stop("'condition' cannot be TRUE for standardised survival probabilities.") - } - # Get stanmat parameter matrix for specified number of draws stanmat <- sample_stanmat(object, draws = draws, default_draws = NA) pars <- extract_pars(object, stanmat) @@ -451,16 +471,21 @@ posterior_survfit.stansurv <- function(object, # Calculate survival probability at last known survival time and then # use that to calculate conditional survival probabilities if (condition) { - if (!type == "surv") - stop("'condition' can only be set to TRUE for survival probabilities.") cond_surv <- .pp_calculate_surv(last_time, object = object, newdata = newdata, pars = pars, type = type) - surv <- lapply(surv, function(x) truncate(x / cond_surv, upper = 1)) + surv <- lapply(surv, function(x) truncate(x / cond_surv, upper = 1)) } + # Store the conditioning time (if relevant) + if (condition) { + attr(surv, "last_time") <- last_time + } else { + attr(surv, "last_time") <- rep(NA, length(time_seq[[1]])) + } + # Summarise posterior draws to get median and CI out <- .pp_summarise_surv(surv = surv, prob = prob, @@ -475,9 +500,9 @@ posterior_survfit.stansurv <- function(object, control = control, condition = condition, standardise = standardise, - last_time = last_time, + last_time = if (condition) last_time else NULL, ids = id_list, - draws = draws, + draws = NROW(stanmat), seed = seed, class = c("survfit.stansurv", "data.frame")) } @@ -684,10 +709,17 @@ posterior_survfit.stanjm <- function(object, pars = pars, type = type, id_list = id_list) - surv <- lapply(surv_t, function(x) truncate(x / cond_surv, upper = 1)) + surv <- lapply(surv_t, function(x) truncate(x / cond_surv, upper = 1)) } else { surv <- surv_t } + + # Store the conditioning time (if relevant) + if (condition) { + attr(surv, "last_time") <- last_time + } else { + attr(surv, "last_time") <- rep(NA, length(time_seq[[1]])) + } # Summarise posterior draws to get median and CI out <- .pp_summarise_surv(surv = surv, @@ -728,9 +760,9 @@ posterior_survfit.stanjm <- function(object, control = control, standardise = standardise, condition = condition, - last_time = last_time, + last_time = if (condition) last_time else NULL, ids = id_list, - draws = draws, + draws = NROW(stanmat), seed = seed, offset = offset, class = c("survfit.stanjm", "data.frame")) @@ -830,10 +862,12 @@ posterior_survfit.stanjm <- function(object, intercept = pars$alpha, betas = pars$beta, betas_tve = pars$beta_tve, + b = pars$b, aux = pars$aux, times = data$pts, x = data$x, - s = data$s) + s = data$s, + z = data$z) if (type %in% c("loghaz", "haz")) { # evaluate hazard; quadrature not relevant @@ -870,7 +904,7 @@ posterior_survfit.stanjm <- function(object, .pp_summarise_surv <- function(surv, prob = NULL, id_var = NULL, - time_var = NULL, + time_var = NULL, standardise = FALSE, colnames = NULL) { @@ -880,34 +914,44 @@ posterior_survfit.stanjm <- function(object, if (is.null(time_var)) time_var <- "time" + # Define variable name for conditioning time + cond_var <- paste0("cond_", time_var) + # Extract ids and times for the predictions - ids <- uapply(surv, attr, "ids") - times <- uapply(surv, attr, "times") + ids <- uapply(surv, attr, "ids") + times <- uapply(surv, attr, "times") + # Extract conditioning time that was used for predictions + last_time <- attr(surv, "last_time") + # Determine the quantiles corresponding to the median and CI limits if (is.null(prob)) { probs <- 0.5 # median only - nms <- c(id_var, time_var, "median") + nms <- c(id_var, cond_var, time_var, "median") } else { probs <- c(0.5, (1 - prob)/2, (1 + prob)/2) # median and CI - nms <- c(id_var, time_var, "median", "ci_lb", "ci_ub") + nms <- c(id_var, cond_var, time_var, "median", "ci_lb", "ci_ub") } # Possibly overide default variable names for the returned data frame if (!is.null(colnames)) { - nms <- c(id_var, time_var, colnames) + nms <- c(id_var, cond_var, time_var, colnames) } # Calculate mean and CI at each prediction time out <- data.frame(do.call("rbind", lapply(surv, col_quantiles_, probs))) - out <- mutate_(out, id_var = ids, time_var = times) + out <- mutate_(out, id_var = ids, cond_var = last_time, time_var = times) out <- row_sort(out, id_var, time_var) - out <- col_sort(out, id_var, time_var) + out <- col_sort(out, id_var, cond_var, time_var) out <- set_rownames(out, NULL) out <- set_colnames(out, nms) # Drop excess info if standardised predictions were calculated - if (standardise) { out[[id_var]] <- NULL; id_var <- NULL } + if (standardise) { + out[[cond_var]] <- NULL + out[[id_var]] <- NULL + id_var <- NULL + } structure(out, id_var = id_var, @@ -941,6 +985,7 @@ print.survfit.stansurv <- function(x, digits = 4, ...) { cat(" num. individuals:", length(attr(x, "ids")), "\n") cat(" prediction type: ", tolower(get_survpred_name(attr(x, "type"))), "\n") cat(" standardised?: ", yes_no_string(attr(x, "standardise")), "\n\n") + cat(" conditional?: ", yes_no_string(attr(x, "condition")), "\n\n") print(x, quote = FALSE) invisible(x) } @@ -959,7 +1004,8 @@ print.survfit.stanjm <- function(x, digits = 4, ...) { cat("stan_jm predictions\n") cat(" num. individuals:", length(attr(x, "ids")), "\n") cat(" prediction type: ", tolower(get_survpred_name(attr(x, "type"))), "\n") - cat(" standardised?: ", yes_no_string(attr(x, "standardise")), "\n\n") + cat(" standardised?: ", yes_no_string(attr(x, "standardise")), "\n") + cat(" conditional?: ", yes_no_string(attr(x, "condition")), "\n\n") print(x, quote = FALSE) invisible(x) } From 0ae397a32b1809b46f0de5efcbf5a8fbb299f4ae Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 17 May 2019 18:26:34 +1000 Subject: [PATCH 153/225] stan_surv.R: remove unnecessary code from parse_formula --- R/stan_surv.R | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 892264657..6066e1a3c 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1729,33 +1729,21 @@ parse_formula_and_data <- function(formula, data) { type <- attr(surv, "type") if (type == "right") { - tvar_beg <- NULL - tvar_end <- as.character(lhs[[2L]]) - dvar <- as.character(lhs[[3L]]) min_t <- 0 max_t <- max(surv[, "time"]) status <- as.vector(surv[, "status"]) t_end <- as.vector(surv[, "time"]) } else if (type == "counting") { - tvar_beg <- as.character(lhs[[2L]]) - tvar_end <- as.character(lhs[[3L]]) - dvar <- as.character(lhs[[4L]]) min_t <- min(surv[, "start"]) max_t <- max(surv[, "stop"]) status <- as.vector(surv[, "status"]) t_end <- as.vector(surv[, "stop"]) } else if (type == "interval") { - tvar_beg <- NULL - tvar_end <- as.character(lhs[[2L]]) - dvar <- as.character(lhs[[4L]]) min_t <- 0 max_t <- max(surv[, c("time1", "time2")]) status <- as.vector(surv[, "status"]) t_end <- as.vector(surv[, "time1"]) } else if (type == "interval2") { - tvar_beg <- NULL - tvar_end <- as.character(lhs[[2L]]) - dvar <- as.character(lhs[[3L]]) min_t <- 0 max_t <- max(surv[, c("time1", "time2")]) status <- as.vector(surv[, "status"]) @@ -1811,9 +1799,6 @@ parse_formula_and_data <- function(formula, data) { bars, re_parts, re_forms, - tvar_beg, - tvar_end, - dvar, surv_type = attr(surv, "type")) } From 5316d5ae9bf593a2cc41e57c152cba3d4baa26f4 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 17 May 2019 18:26:55 +1000 Subject: [PATCH 154/225] Tidy up stan_surv tests --- tests/testthat/test_stan_surv.R | 599 ++++++++++++++++++-------------- 1 file changed, 343 insertions(+), 256 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 708fe2e4f..166bad92d 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -24,15 +24,14 @@ library(survival) library(simsurv) ITER <- 1000 CHAINS <- 1 -SEED <- 12345 REFRESH <- 0L -set.seed(SEED) +SEED <- 12345; set.seed(SEED) if (interactive()) - options(mc.cores = parallel::detectCores()) + options(mc.cores = parallel::detectCores(), + loo.cores = parallel::detectCores()) TOLSCALES <- list( - hr_fixef = 0.5, # how many SEs can stan_surv HRs be from coxph/stpm2 HRs - tve_fixef = 0.5 # how many SEs can stan_surv tve HRs be from coxph/stpm2 tve HRs + hr_fixef = 0.5 # how many SEs can stan_surv HRs be from coxph/stpm2 HRs ) source(test_path("helpers", "expect_matrix.R")) @@ -41,9 +40,9 @@ source(test_path("helpers", "expect_stanmvreg.R")) source(test_path("helpers", "expect_survfit_surv.R")) source(test_path("helpers", "expect_ppd.R")) source(test_path("helpers", "expect_equivalent_loo.R")) -source(test_path("helpers", "SW.R")) source(test_path("helpers", "get_tols_surv.R")) source(test_path("helpers", "recover_pars_surv.R")) +source(test_path("helpers", "SW.R")) eo <- function(...) { expect_output (...) } ee <- function(...) { expect_error (...) } @@ -53,30 +52,28 @@ up <- function(...) { update(...) } run_sims <- FALSE # if TRUE then long running simulations are run -#----------------------------- Models ----------------------------------- -#--- Time fixed covariates, time fixed coefficients +#----------------- Check model fitting arguments work ----------------------- cov1 <- data.frame(id = 1:50, x1 = stats::rbinom(50, 1, 0.5), x2 = stats::rnorm (50, -1, 0.5)) + dat1 <- simsurv(lambdas = 0.1, gammas = 1.5, betas = c(x1 = -0.5, x2 = -0.3), x = cov1, maxt = 5) -dat1 <- merge(dat1, cov1) -fm1 <- Surv(eventtime, status) ~ x1 + x2 -o<-SW(testmod <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 50, basehaz = "ms")) -# mod1a <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "ms") -# mod1b <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "bs") -# mod1c <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "exp") -# mod1d <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "weibull") -# mod1e <- stan_surv(fm1, dat1, chains = 1, refresh = 0L, iter = 1000, basehaz = "gompertz") +dat1$s <- Surv(dat1$eventtime, dat1$status) # abbreviated Surv object - -#-------------------------- Arguments ----------------------------------- +o<-SW(testmod <- stan_surv(formula = s ~ x1 + x2, + data = merge(dat1, cov1), + basehaz = "ms", + iter = 20, + chains = CHAINS, + refresh = REFRESH, + seed = SEED)) test_that("prior_PD argument works", { es(up(testmod, prior_PD = TRUE)) @@ -111,7 +108,6 @@ test_that("qnodes argument works", { }) test_that("basehaz argument works", { - es(up(testmod, basehaz = "exp")) es(up(testmod, basehaz = "weibull")) es(up(testmod, basehaz = "gompertz")) @@ -132,7 +128,6 @@ test_that("basehaz argument works", { ee(up(testmod, basehaz_ops = list(df = 1)), "cannot be negative") ee(up(testmod, basehaz_ops = list(knots = -1)), "earliest entry time") ee(up(testmod, basehaz_ops = list(knots = c(1,2,50))), "latest event time") - }) test_that("prior arguments work", { @@ -165,42 +160,245 @@ test_that("prior arguments work", { }) test_that("tve function works", { - - # single tve call - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1) + x2)) - - # multiple tve calls - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1) + tve(x2))) - - # b-spline and piecewise tve in same model - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "bs") + tve(x2, type = "pw"))) - - # b-spline tve optional arguments - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "bs", knots = c(1,2)) + x2)) - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "bs", df = 4) + x2)) - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "bs", degree = 2) + x2)) - ee(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "bs", junk = 2) + x2), - "Invalid argument to 'tve' function.") - - # piecewise tve optional arguments - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "pw", knots = c(1,2)) + x2)) - es(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "pw", df = 4) + x2)) - ee(up(testmod, formula. = - Surv(eventtime, status) ~ tve(x1, type = "pw", degree = 2) + x2), - "Invalid argument to 'tve' function.") + es(up(testmod, formula. = s ~ tve(x1) + x2)) + es(up(testmod, formula. = s ~ tve(x1) + tve(x2))) + es(up(testmod, formula. = s ~ tve(x1, type = "bs") + tve(x2, type = "pw"))) +}) + +test_that("tve function works: b-spline optional arguments", { + es(up(testmod, formula. = s ~ tve(x1, type = "bs", knots = c(1,2)) + x2)) + es(up(testmod, formula. = s ~ tve(x1, type = "bs", df = 4) + x2)) + es(up(testmod, formula. = s ~ tve(x1, type = "bs", degree = 2) + x2)) + ee(up(testmod, formula. = s ~ tve(x1, type = "bs", junk = 2) + x2), "unused") }) +test_that("tve function works: piecewise optional arguments", { + es(up(testmod, formula. = s ~ tve(x1, type = "pw", knots = c(1,2)) + x2)) + es(up(testmod, formula. = s ~ tve(x1, type = "pw", df = 4) + x2)) + ee(up(testmod, formula. = s ~ tve(x1, type = "pw", junk = 2) + x2), "unused") +}) + + +#---------------- Check post-estimation functions work ---------------------- + +# use PBC data +pbcSurv$t0 <- 0 +pbcSurv$t0[pbcSurv$futimeYears > 2] <- 1 # fake delayed entry +pbcSurv$t1 <- pbcSurv$futimeYears - 1 # fake lower limit for interval censoring +pbcSurv$t1[pbcSurv$t1 <= 0] <- -Inf # fake left censoring +pbcSurv$site <- cut(pbcSurv$id, # fake group for frailty models + breaks = c(0,10,20,30,40), + labels = FALSE) -#---- Compare parameter estimates: stan_surv vs coxph +# different baseline hazards +o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, + data = pbcSurv, + basehaz = "ms", + chains = 1, + iter = 20, + refresh = REFRESH, + seed = SEED)) +o<-SW(f2 <- up(f1, basehaz = "bs")) +o<-SW(f3 <- up(f1, basehaz = "exp")) +o<-SW(f4 <- up(f1, basehaz = "weibull")) +o<-SW(f5 <- up(f1, basehaz = "gompertz")) +o<-SW(f6 <- up(f1, basehaz = "exp-aft")) +o<-SW(f7 <- up(f1, basehaz = "weibull-aft")) + +# time-varying effects +o<-SW(f8 <- up(f1, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f9 <- up(f2, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f10 <- up(f3, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f11 <- up(f4, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f12 <- up(f5, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f13 <- up(f6, Surv(futimeYears, death) ~ sex + tve(trt))) +o<-SW(f14 <- up(f7, Surv(futimeYears, death) ~ sex + tve(trt))) + +o<-SW(f15 <- up(f1, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f16 <- up(f2, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f17 <- up(f3, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f18 <- up(f4, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f19 <- up(f5, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f20 <- up(f6, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f21 <- up(f7, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) + +# start-stop notation (incl. delayed entry) +o<-SW(f22 <- up(f1, Surv(t0, futimeYears, death) ~ sex + trt)) +o<-SW(f23 <- up(f1, Surv(t0, futimeYears, death) ~ sex + tve(trt))) +o<-SW(f24 <- up(f6, Surv(t0, futimeYears, death) ~ sex + tve(trt))) +o<-SW(f25 <- up(f6, Surv(t0, futimeYears, death) ~ sex + tve(trt))) + +# left and interval censoring +o<-SW(f26 <- up(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) +o<-SW(f27 <- up(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) +o<-SW(f28 <- up(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) +o<-SW(f29 <- up(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) + +# frailty models +o<-SW(f30 <- up(f1, Surv(futimeYears, death) ~ trt + (trt | site))) +o<-SW(f31 <- up(f1, Surv(futimeYears, death) ~ tve(trt) + (1 | site))) +o<-SW(f32 <- up(f1, Surv(t0, futimeYears, death) ~ trt + (trt | site))) +o<-SW(f33 <- up(f1, Surv(t1, futimeYears, type = "interval2") ~ trt + (trt | site))) + +# new data for predictions +nd1 <- pbcSurv[pbcSurv$id == 2,] +nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] + +# test the models +for (j in c(1:33)) { + + mod <- try(get(paste0("f", j)), silent = TRUE) + + if (class(mod)[1L] == "try-error") { + + cat("Model not found:", paste0("f", j), "\n") + + } else { + + cat("Checking model:", paste0("f", j), "\n") + + test_that("log_lik works with estimation data", { + ll <- log_lik(mod) + expect_matrix(ll) + }) + + test_that("log_lik works with new data (one individual)", { + ll <- log_lik(mod, newdata = nd1) + expect_matrix(ll) + }) + + test_that("log_lik works with new data (multiple individuals)", { + ll <- log_lik(mod, newdata = nd2) + expect_matrix(ll) + }) + + if (mod$ndelayed == 0) # only test if no delayed entry + test_that("posterior_survfit works with estimation data", { + SW(ps <- posterior_survfit(mod)) + expect_survfit(ps) + }) + + test_that("posterior_survfit works with new data (one individual)", { + SW(ps <- posterior_survfit(mod, newdata = nd1)) + expect_survfit(ps) + }) + + test_that("posterior_survfit works with new data (multiple individuals)", { + SW(ps <- posterior_survfit(mod, newdata = nd2)) + expect_survfit(ps) + }) + + } +} + +# test loo for a few models only (too slow to test them all) +for (j in c(1,2,8,26,30)) { + + mod <- try(get(paste0("f", j)), silent = TRUE) + + if (class(mod)[1L] == "try-error") { + + cat("Model not found:", paste0("f", j), "\n") + + } else { + + cat("Checking loo for model:", paste0("f", j), "\n") + + test_that("loo and waic work", { + loo_try <- try(expect_equivalent_loo(mod), silent = TRUE) + if (class(loo_try)[1L] == "try-error") { + # sometimes loo fails with a small number of draws so refit with more + expect_equivalent_loo(up(mod, iter = 80)) + } + }) + + } +} + + +#---- Check accuracy of log_lik and posterior_survfit: for frailty models --- + +fake_data <- + data.frame(id = c(1,2,3,4), + trt = c(1,0,1,0), + age = c(5,8,2,4), + site = c(1,1,2,2), + eventtime = c(2,4,6,8), + status = c(1,1,1,1)) + +o<-SW(stan1 <- stan_surv(formula = Surv(eventtime, status) ~ trt + age + (1 | site), + data = fake_data, + basehaz = "weibull", + chains = 1, + refresh = 0L, + iter = 100, + warmup = 95)) + +stanmat <- as.matrix(stan1) + +stanpars <- list(int = stanmat[, "(Intercept)"], + trt = stanmat[, "trt"], + age = stanmat[, "age"], + shape = stanmat[, "weibull-shape"], + site = list(stanmat[, "b[(Intercept) site:1]"], + stanmat[, "b[(Intercept) site:2]"])) + +N <- nrow(fake_data) +S <- nrow(stanmat) + +# define function to calculate log likelihood manually +llfun <- function(i, j, data, pars) { + exp_eta_ij <- exp(pars$int[j] + + pars$trt[j] * data$trt[i] + + pars$age[j] * data$age[i] + + pars$site[[data$site[i]]][[j]]) + h_ij <- pars$shape[j] * data$eventtime[i] ^ (pars$shape[j] - 1) * exp_eta_ij + H_ij <- data$eventtime[i] ^ (pars$shape[j]) * exp_eta_ij + return(data$status[i] * log(h_ij) - H_ij) +} + +# define function to calculate survival probability manually +survfun <- function(i, j, t, data, pars) { + exp_eta_ij <- exp(pars$int[j] + + pars$trt[j] * data$trt[i] + + pars$age[j] * data$age[i] + + pars$site[[data$site[i]]][[j]]) + H_ij <- t ^ (pars$shape[j]) * exp_eta_ij + return(exp(- H_ij)) +} + +# check log likelihood +L1 <- log_lik(stan1) +L2 <- log_lik(stan1, newdata = fake_data) +L3 <- matrix(NA, S, N) # manually evaluated log likelihood +for (i in 1:N) { + for (j in 1:S) { + L3[j,i] <- llfun(i, j, data = fake_data, pars = stanpars) + } +} +for (i in 1:N) { + for (j in 1:S) { + expect_equal(as.vector(L3[j,i]), as.vector(L1[j,i])) + expect_equal(as.vector(L3[j,i]), as.vector(L2[j,i])) + } +} + +# check survival probability +P1 <- posterior_survfit(stan1, times = 5, extrapolate = FALSE) +P2 <- posterior_survfit(stan1, newdata = fake_data, times = 5, extrapolate = FALSE) +P3 <- matrix(NA, S, N) # manually evaluated survival probability +for (i in 1:N) { + for (j in 1:S) { + P3[j,i] <- survfun(i, j, t = 5, data = fake_data, pars = stanpars) + } +} +for (i in 1:N) { + expect_equal(median(P3[,i]), P1[i, "median"]) + expect_equal(median(P3[,i]), P2[i, "median"]) +} + + +#---------------- Check parameter estimates: stan vs coxph ----------------- compare_surv <- function(data, basehaz = "weibull", ...) { require(survival) @@ -271,7 +469,7 @@ dat <- merge(dat, covs) compare_surv(data = dat, basehaz = "gompertz") -#---- Compare parameter estimates: stan_surv vs survreg +#----------- Check parameter estimates: stan (AFT) vs survreg --------------- compare_surv <- function(data, basehaz = "weibull-aft", ...) { require(survival) @@ -284,7 +482,8 @@ compare_surv <- function(data, basehaz = "weibull-aft", ...) { iter = ITER, refresh = REFRESH, chains = CHAINS, - seed = SEED, ...) + seed = SEED, + ...) tols <- get_tols(surv1, tolscales = TOLSCALES) pars_surv <- recover_pars(surv1) pars_stan <- recover_pars(stan1) @@ -326,9 +525,55 @@ dat <- merge(dat, covs) compare_surv(data = dat, basehaz = "weibull-aft") +#-------- Check parameter estimates: stan (tve) vs coxph (tt) --------------- + +# NB: this only checks piecewise constant hazard ratio (not B-spline) + +set.seed(SEED) + +N <- 1000 # number of individuals to simulate + +covs <- data.frame(id = 1:N, + X1 = rbinom(N, 1, 0.3), + X2 = rnorm (N, 2, 2.0)) + +dat <- simsurv(dist = "exponential", + x = covs, + lambdas = c(0.1), + betas = c(X1 = 0.3, X2 = -0.3), + tve = c(X1 = -0.6), + tvefun = function(t) as.numeric(t > 10), + maxt = 30) + +o<-SW(surv1 <- coxph( + formula = Surv(eventtime, status) ~ X1 + tt(X1) + X2, + data = merge(dat, covs), + tt = function(x, t, ...) { x * as.numeric(t > 10) })) + +o<-SW(stan1 <- stan_surv( + formula = Surv(eventtime, status) ~ tve(X1, type = "pw", knots = c(10)) + X2, + data = merge(dat, covs), + basehaz = "exp", + chains = CHAINS, + cores = CORES, + refresh = REFRESH, + iter = ITER)) + +tols <- get_tols(surv1, tolscales = TOLSCALES) + +pars_surv <- recover_pars(surv1) +pars_stan <- recover_pars(stan1) + +for (i in names(tols$fixef)) + expect_equal(pars_surv$fixef[[i]], + pars_stan$fixef[[i]], + tol = tols$fixef[[i]], + info = "compare_estimates_tve_pw") + + # COMMENTED OUT TO AVOID ADDING PACKAGES TO SUGGESTS # -# #---- Compare parameter estimates: stan_surv vs icenReg (interval censored) +# #------- Compare parameter estimates: stan (icens) vs icenReg ------------- # # #---- simulated interval censored weibull data # @@ -383,7 +628,7 @@ compare_surv(data = dat, basehaz = "weibull-aft") # info = "compare log lik with icenReg") # # -# #---- Compare parameter estimates: stan_surv vs phreg (tvc & delayed entry) +# #---- Compare parameter estimates: stan (tvc & delayed entry) vs phreg ---- # # #---- mortality data: contains a time-varying covariate # @@ -426,158 +671,8 @@ compare_surv(data = dat, basehaz = "weibull-aft") # coef(v_weib)['sesupper'][[1]], # tol = 0.1), "not equal") -#---- Check tve models against coxph - -#---- piecewise constant - -set.seed(1919002) -covs <- data.frame(id = 1:1000, - X1 = rbinom(1000, 1, 0.3), - X2 = rnorm (1000, 2, 2.0)) -dat <- simsurv(dist = "exponential", - lambdas = 0.1, - betas = c(X1 = 0.3, X2 = -0.3), - x = covs, - tve = c(X1 = -0.6), - tvefun = function(t) as.numeric(t > 10), - maxt = 30) -dat <- merge(dat, covs) - -fmsurv <- Surv(eventtime, status) ~ X1 + tt(X1) + X2 -o<-SW(surv1 <- coxph(fmsurv, dat, tt = function(x, t, ...) { x * as.numeric(t > 10) })) - -fmstan <- Surv(eventtime, status) ~ tve(X1, type = "pw", knots = c(10)) + X2 -o<-SW(stan1 <- stan_surv(fmstan, dat, chains = 1, refresh = 0L, iter = 1000, basehaz = "exp")) - -tols <- get_tols(surv1, tolscales = TOLSCALES) -pars_surv <- recover_pars(surv1) -pars_stan <- recover_pars(stan1) -for (i in names(tols$fixef)) - expect_equal(pars_surv$fixef[[i]], - pars_stan$fixef[[i]], - tol = tols$fixef[[i]], - info = "compare_estimates_tve_pw") - - -#-------- Check post-estimation functions work - -pbcSurv$t0 <- 0 -pbcSurv$t0[pbcSurv$futimeYears > 2] <- 1 # delayed entry - -pbcSurv$t1 <- pbcSurv$futimeYears - 1 # lower limit for interval censoring -pbcSurv$t1[pbcSurv$t1 <= 0] <- -Inf # left censoring - -pbcSurv$clinic <- cut(pbcSurv$id, breaks = c(0,10,20,30,40), labels = FALSE) - -# different baseline hazards -o<-SW(f1 <- stan_surv(Surv(futimeYears, death) ~ sex + trt, - data = pbcSurv, - basehaz = "ms", - chains = 1, - iter = 100, - refresh = REFRESH, - seed = SEED)) -o<-SW(f2 <- update(f1, basehaz = "bs")) -o<-SW(f3 <- update(f1, basehaz = "exp")) -o<-SW(f4 <- update(f1, basehaz = "weibull")) -o<-SW(f5 <- update(f1, basehaz = "gompertz")) -o<-SW(f6 <- update(f1, basehaz = "exp-aft")) -o<-SW(f7 <- update(f1, basehaz = "weibull-aft")) - -# time-varying effects -o<-SW(f8 <- update(f1, Surv(futimeYears, death) ~ sex + tve(trt))) -o<-SW(f9 <- update(f2, Surv(futimeYears, death) ~ sex + tve(trt))) -o<-SW(f10 <- update(f3, Surv(futimeYears, death) ~ sex + tve(trt))) -o<-SW(f11 <- update(f4, Surv(futimeYears, death) ~ sex + tve(trt))) -o<-SW(f12 <- update(f5, Surv(futimeYears, death) ~ sex + tve(trt))) -o<-SW(f13 <- update(f6, Surv(futimeYears, death) ~ sex + tve(trt))) -o<-SW(f14 <- update(f7, Surv(futimeYears, death) ~ sex + tve(trt))) - -o<-SW(f15 <- update(f1, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f16 <- update(f2, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f17 <- update(f3, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f18 <- update(f4, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f19 <- update(f5, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f20 <- update(f6, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f21 <- update(f7, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) - -# start-stop notation (incl. delayed entry) -o<-SW(f22 <- update(f1, Surv(t0, futimeYears, death) ~ sex + trt)) -o<-SW(f23 <- update(f1, Surv(t0, futimeYears, death) ~ sex + tve(trt))) -o<-SW(f24 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tve(trt))) -o<-SW(f25 <- update(f6, Surv(t0, futimeYears, death) ~ sex + tve(trt))) - -# left and interval censoring -o<-SW(f26 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) -o<-SW(f27 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) -o<-SW(f28 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + trt)) -o<-SW(f29 <- update(f6, Surv(t1, futimeYears, type = "interval2") ~ sex + tve(trt))) - -# frailty models -o<-SW(f30 <- update(f1, Surv(futimeYears, death) ~ trt + (trt | clinic))) -o<-SW(f31 <- update(f1, Surv(futimeYears, death) ~ tve(trt) + (1 | clinic))) -o<-SW(f32 <- update(f1, Surv(t0, futimeYears, death) ~ trt + (trt | clinic))) -o<-SW(f33 <- update(f1, Surv(t1, futimeYears, type = "interval2") ~ trt + (trt | clinic))) - -# new data for predictions -nd1 <- pbcSurv[pbcSurv$id == 2,] -nd2 <- pbcSurv[pbcSurv$id %in% c(1,2),] - -# test the models -for (j in c(30:33)) { - - mod <- try(get(paste0("f", j)), silent = TRUE) - - if (class(mod)[1L] == "try-error") { - - cat("Model not found:", paste0("f", j), "\n") - - } else { - - cat("Checking model:", paste0("f", j), "\n") - - test_that("log_lik works with estimation data", { - ll <- log_lik(mod) - expect_matrix(ll) - }) - - test_that("log_lik works with new data (one individual)", { - ll <- log_lik(mod, newdata = nd1) - expect_matrix(ll) - }) - - test_that("log_lik works with new data (multiple individuals)", { - ll <- log_lik(mod, newdata = nd2) - expect_matrix(ll) - }) - - test_that("loo and waic work", { - expect_equivalent_loo(mod) - }) - - if (mod$ndelayed == 0) # only test if no delayed entry - test_that("posterior_survfit works with estimation data", { - SW(ps <- posterior_survfit(mod)) - expect_survfit(ps) - }) - - test_that("posterior_survfit works with new data (one individual)", { - SW(ps <- posterior_survfit(mod, newdata = nd1)) - expect_survfit(ps) - }) - - test_that("posterior_survfit works with new data (multiple individuals)", { - SW(ps <- posterior_survfit(mod, newdata = nd2)) - expect_survfit(ps) - }) - - } -} - -#-------- Check hazard models with group-specific terms - -#--- test estimates for each model type using one simulated dataset +#-------- Check parameter estimates: stan (frailty) vs simulated ----------- # define a function to simulate a survival dataset make_data <- function(n = 10, # number of patients per site @@ -658,55 +753,47 @@ get_ests <- function(mod) { } # fit right censored models -set.seed(5434) -dat <- make_data(n = 20, K = 50) -ff <- Surv(eventtime, status) ~ trt + (1 | site) -m1 <- stan_surv(ff, data = dat, chains = 1, basehaz = "exp") -m2 <- stan_surv(ff, data = dat, chains = 1, basehaz = "weibull") -m3 <- stan_surv(ff, data = dat, chains = 1, basehaz = "gompertz") -m4 <- stan_surv(ff, data = dat, chains = 1, basehaz = "ms") -for (i in 1:3) - expect_equal(get_ests(m1)[[i]], true[[i]], tol = tols[[i]]) -for (i in 1:3) - expect_equal(get_ests(m2)[[i]], true[[i]], tol = tols[[i]]) -for (i in 1:3) - expect_equal(get_ests(m3)[[i]], true[[i]], tol = tols[[i]]) -for (i in 2:3) - expect_equal(get_ests(m4)[[i]], true[[i]], tol = tols[[i]]) - -# fit delayed entry models -set.seed(8765) + +# simulate datasets +set.seed(SEED) +dat <- make_data(n = 20, K = 50) dat_delay <- make_data(n = 20, K = 50, delay = TRUE) -ffd <- Surv(start, stop, status) ~ trt + (1 | site) -m5 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "exp") -m6 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "weibull") -m7 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "gompertz") -m8 <- stan_surv(ffd, data = dat_delay, chains = 1, refresh = 0, basehaz = "ms") -for (i in 1:3) - expect_equal(get_ests(m5)[[i]], true[[i]], tol = tols[[i]]) -for (i in 1:3) - expect_equal(get_ests(m6)[[i]], true[[i]], tol = tols[[i]]) -for (i in 1:3) - expect_equal(get_ests(m7)[[i]], true[[i]], tol = tols[[i]]) -for (i in 2:3) - expect_equal(get_ests(m8)[[i]], true[[i]], tol = tols[[i]]) - -# fit interval censored models -set.seed(3254) dat_icens <- make_data(n = 20, K = 50, icens = TRUE) -ffi <- Surv(lower, upper, type = "interval2") ~ trt + (1 | site) -m9 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "exp") -m10 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "weibull") -m11 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "gompertz") -m12 <- stan_surv(ffi, data = dat_icens, chains = 1, refresh = 0, iter = 1000, basehaz = "ms") -for (i in 1:3) - expect_equal(get_ests(m9)[[i]], true[[i]], tol = tols[[i]]) -for (i in 1:3) - expect_equal(get_ests(m10)[[i]], true[[i]], tol = tols[[i]]) -for (i in 1:3) - expect_equal(get_ests(m11)[[i]], true[[i]], tol = tols[[i]]) -for (i in 2:3) - expect_equal(get_ests(m12)[[i]], true[[i]], tol = tols[[i]]) + +# formulas +ff <- Surv(eventtime, status) ~ trt + (1 | site) # right cens +ffd <- Surv(start, stop, status) ~ trt + (1 | site) # delayed entry +ffi <- Surv(lower, upper, type = "interval2") ~ trt + (1 | site) # interval cens + +# fit the starting model +o<-SW(m1 <- stan_surv(formula = ff, + data = dat, + basehaz = "exp", + iter = ITER, + refresh = REFRESH, + chains = CHAINS, + seed = SEED)) + +# fit the additional models +o<-SW(m2 <- up(m1, formula. = ff, data = dat, basehaz = "weibull")) +o<-SW(m3 <- up(m1, formula. = ff, data = dat, basehaz = "gompertz")) +o<-SW(m4 <- up(m1, formula. = ff, data = dat, basehaz = "ms")) +o<-SW(m5 <- up(m1, formula. = ffd, data = dat_delay, basehaz = "exp")) +o<-SW(m6 <- up(m1, formula. = ffd, data = dat_delay, basehaz = "weibull")) +o<-SW(m7 <- up(m1, formula. = ffd, data = dat_delay, basehaz = "gompertz")) +o<-SW(m8 <- up(m1, formula. = ffd, data = dat_delay, basehaz = "ms")) +o<-SW(m9 <- up(m1, formula. = ffi, data = dat_icens, basehaz = "exp")) +o<-SW(m10 <- up(m1, formula. = ffi, data = dat_icens, basehaz = "weibull")) +o<-SW(m11 <- up(m1, formula. = ffi, data = dat_icens, basehaz = "gompertz")) +o<-SW(m12 <- up(m1, formula. = ffi, data = dat_icens, basehaz = "ms")) + +# check the estimates against the true parameters +for (j in c(1:12)) { + modfrail <- get(paste0("f", j)) + for (i in 1:3) + expect_equal(get_ests(modfrail)[[i]], true[[i]], tol = tols[[i]]) +} + #--- previous tests use really weak tolerances to check the # parameter estimates; therefore the next part conducts a full @@ -716,7 +803,7 @@ for (i in 2:3) if (run_sims) { # number of simulations (for each model specification) - n_sims <- 2 + n_sims <- 200 # define a function to fit the model to one simulated dataset sim_run <- function(n = 10, # number of patients per site From 16171da41bd7644f1d94efd7608ae401beeb3603 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 4 Jun 2019 10:23:07 +1000 Subject: [PATCH 155/225] plot.stansurv: allow user to specify number of points at which to interpolate function --- R/plots.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/plots.R b/R/plots.R index 4cf597d11..271ab4055 100644 --- a/R/plots.R +++ b/R/plots.R @@ -193,11 +193,13 @@ plot.stanreg <- function(x, plotfun = "intervals", pars = NULL, #' include in the plot. Can be \code{"ci"} for the Bayesian posterior #' uncertainty interval, or \code{"none"}. This argument is only relevant #' when \code{plotfun = "basehaz"} or \code{plotfun = "tve"} +#' @param n Integer, the number of time points at which to interpolate the +#' function when plotting the baseline hazard or time-varying hazard ratio. #' plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, regex_pars = NULL, ..., prob = 0.95, limits = c("ci", "none"), - ci_geom_args = NULL) { + ci_geom_args = NULL, n = 1000) { validate_stansurv_object(x) @@ -210,7 +212,7 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, t_min <- min(x$entrytime) t_max <- max(x$eventtime) - times <- seq(t_min, t_max, by = (t_max - t_min) / 1000) + times <- seq(t_min, t_max, by = (t_max - t_min) / n) if (plotfun == "basehaz") { From d465a97f6c53deefec915c3a1f45b6eb683ce27f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 4 Jun 2019 11:25:14 +1000 Subject: [PATCH 156/225] posterior_survfit: tidy print method --- R/posterior_survfit.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 313331776..735723830 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -984,7 +984,7 @@ print.survfit.stansurv <- function(x, digits = 4, ...) { cat("stan_surv predictions\n") cat(" num. individuals:", length(attr(x, "ids")), "\n") cat(" prediction type: ", tolower(get_survpred_name(attr(x, "type"))), "\n") - cat(" standardised?: ", yes_no_string(attr(x, "standardise")), "\n\n") + cat(" standardised?: ", yes_no_string(attr(x, "standardise")), "\n") cat(" conditional?: ", yes_no_string(attr(x, "condition")), "\n\n") print(x, quote = FALSE) invisible(x) From 8193e58ea577365fbaefc518087df21e1f2c2b4a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 4 Jun 2019 12:51:45 +1000 Subject: [PATCH 157/225] plot.stansurv: don't use geom_smooth --- R/plots.R | 29 ++++++++++------------------- 1 file changed, 10 insertions(+), 19 deletions(-) diff --git a/R/plots.R b/R/plots.R index 271ab4055..f19ac7096 100644 --- a/R/plots.R +++ b/R/plots.R @@ -229,7 +229,7 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, basehaz <- median_and_bounds(basehaz, prob, na.rm = TRUE) plotdat <- data.frame(times, basehaz) - requires_smooth <- !(get_basehaz_name(x) %in% c("piecewise")) + uses_step_stair <- (get_basehaz_name(x) %in% c("piecewise")) ylab <- "Baseline hazard rate" xlab <- "Time" @@ -270,7 +270,7 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, plotdat <- median_and_bounds(exp(coef), prob, na.rm = TRUE) plotdat <- data.frame(times, plotdat) - requires_smooth <- !(tt_type %in% c("pw", "piecewise")) + uses_step_stair <- (tt_type %in% c("pw", "piecewise")) xlab <- "Time" ylab <- ifelse(is_aft, @@ -278,32 +278,23 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, paste0("Hazard ratio\n(", pars, ")")) } - geom_defs <- list(color = "black") # default plot args + geom_defs <- list(color = "black") # default plot args geom_args <- set_geom_args(geom_defs, ...) + geom_maps <- list(aes_string(x = "times", y = "med")) geom_ylab <- ggplot2::ylab(ylab) geom_xlab <- ggplot2::xlab(xlab) geom_base <- ggplot(plotdat) + geom_ylab + geom_xlab + ggplot2::theme_bw() - if (requires_smooth) { - geom_maps <- list(aes_string(x = "times", y = "med"), method = "loess", se = FALSE) - geom_plot <- geom_base + do.call(ggplot2::geom_smooth, c(geom_maps, geom_args)) - } else { - geom_maps <- list(aes_string(x = "times", y = "med")) - geom_plot <- geom_base + do.call(ggplot2::geom_step, c(geom_maps, geom_args)) - } + geom_fun <- if (uses_step_stair) ggplot2::geom_step else ggplot2::geom_line + geom_plot <- geom_base + do.call(geom_fun, c(geom_maps, geom_args)) + if (limits == "ci") { lim_defs <- list(alpha = 0.3) # default plot args for ci lim_args <- c(defaults = list(lim_defs), ci_geom_args) lim_args <- do.call("set_geom_args", lim_args) lim_maps <- list(mapping = aes_string(x = "times", ymin = "lb", ymax = "ub")) - if (requires_smooth) { - lim_tmp <- geom_base + - ggplot2::stat_smooth(aes_string(x = "times", y = "lb"), method = "loess") + - ggplot2::stat_smooth(aes_string(x = "times", y = "ub"), method = "loess") - } else { - lim_tmp <- geom_base + - ggplot2::geom_step(aes_string(x = "times", y = "lb")) + - ggplot2::geom_step(aes_string(x = "times", y = "ub")) - } + lim_tmp <- geom_base + + geom_fun(aes_string(x = "times", y = "lb")) + + geom_fun(aes_string(x = "times", y = "ub")) lim_build<- ggplot2::ggplot_build(lim_tmp) lim_data <- list(data = data.frame(times = lim_build$data[[1]]$x, lb = lim_build$data[[1]]$y, From 13a9952c5cea06042a5bb5042ab60cc50ac2ade2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 4 Jun 2019 14:40:32 +1000 Subject: [PATCH 158/225] posterior_survfit: fix up last_time when not conditioning --- R/posterior_survfit.R | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 735723830..5bb66aae7 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -477,13 +477,7 @@ posterior_survfit.stansurv <- function(object, pars = pars, type = type) surv <- lapply(surv, function(x) truncate(x / cond_surv, upper = 1)) - } - - # Store the conditioning time (if relevant) - if (condition) { attr(surv, "last_time") <- last_time - } else { - attr(surv, "last_time") <- rep(NA, length(time_seq[[1]])) } # Summarise posterior draws to get median and CI @@ -710,17 +704,11 @@ posterior_survfit.stanjm <- function(object, type = type, id_list = id_list) surv <- lapply(surv_t, function(x) truncate(x / cond_surv, upper = 1)) + attr(surv, "last_time") <- last_time } else { surv <- surv_t } - # Store the conditioning time (if relevant) - if (condition) { - attr(surv, "last_time") <- last_time - } else { - attr(surv, "last_time") <- rep(NA, length(time_seq[[1]])) - } - # Summarise posterior draws to get median and CI out <- .pp_summarise_surv(surv = surv, prob = prob, @@ -923,6 +911,9 @@ posterior_survfit.stanjm <- function(object, # Extract conditioning time that was used for predictions last_time <- attr(surv, "last_time") + if (is.null(last_time)) { # if not using conditional survival + last_time <- rep(NA, length(ids)) + } # Determine the quantiles corresponding to the median and CI limits if (is.null(prob)) { From 5712ffdc147e00a5ebe6b5a04e2e4fa87eb0622c Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 4 Jun 2019 19:15:14 +1000 Subject: [PATCH 159/225] stan_surv: allow user to specify degree for MS and BS baseline hazards --- R/stan_surv.R | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 6066e1a3c..89f642879 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1341,7 +1341,7 @@ tve <- function(x, # Construct a list with information about the baseline hazard # # @param basehaz A string specifying the type of baseline hazard -# @param basehaz_ops A named list with elements df, knots +# @param basehaz_ops A named list with elements: df, knots, degree # @param ok_basehaz A list of admissible baseline hazards # @param times A numeric vector with eventtimes for each individual # @param status A numeric vector with event indicators for each individual @@ -1376,8 +1376,9 @@ handle_basehaz_surv <- function(basehaz, if (basehaz %in% c("ms", "bs", "piecewise")) { - df <- basehaz_ops$df - knots <- basehaz_ops$knots + df <- basehaz_ops$df + knots <- basehaz_ops$knots + degree <- basehaz_ops$degree if (!is.null(df) && !is.null(knots)) stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") @@ -1385,6 +1386,9 @@ handle_basehaz_surv <- function(basehaz, if (is.null(df)) df <- 5L # assumes no intercept, ignored if the user specified knots + if (is.null(degree)) + degree <- 3L # cubic splines + tt <- times[status == 1] # uncensored event times if (is.null(knots) && !length(tt)) { warning2("No observed events found in the data. Censoring times will ", @@ -1425,15 +1429,15 @@ handle_basehaz_surv <- function(basehaz, } else if (basehaz == "bs") { bknots <- c(min_t, max_t) - iknots <- get_iknots(tt, df = df, iknots = knots) - basis <- get_basis(tt, iknots = iknots, bknots = bknots, type = "bs") + iknots <- get_iknots(tt, df = df, iknots = knots, degree = degree) + basis <- get_basis(tt, iknots = iknots, bknots = bknots, degree = degree, type = "bs") nvars <- ncol(basis) # number of aux parameters, basis terms } else if (basehaz == "ms") { bknots <- c(min_t, max_t) - iknots <- get_iknots(tt, df = df, iknots = knots) - basis <- get_basis(tt, iknots = iknots, bknots = bknots, type = "ms") + iknots <- get_iknots(tt, df = df, iknots = knots, degree = degree) + basis <- get_basis(tt, iknots = iknots, bknots = bknots, degree = degree, type = "ms") nvars <- ncol(basis) # number of aux parameters, basis terms } else if (basehaz == "piecewise") { @@ -1449,7 +1453,8 @@ handle_basehaz_surv <- function(basehaz, type = basehaz_for_stan(basehaz), nvars, iknots, - bknots, + bknots, + degree, basis, df = nvars, user_df = nvars, @@ -1464,8 +1469,8 @@ handle_basehaz_surv <- function(basehaz, # @return A character vector, or NA if unmatched. get_ok_basehaz_ops <- function(basehaz_name) { switch(basehaz_name, - "bs" = c("df", "knots"), - "ms" = c("df", "knots"), + "bs" = c("df", "knots", "degree"), + "ms" = c("df", "knots", "degree"), "piecewise" = c("df", "knots"), NA) } From df43618024c7b220c0cf5b0619dd8e7722fb98a2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 5 Jun 2019 05:06:04 +1000 Subject: [PATCH 160/225] stan_surv: fix bug in M-spline baseline hazard The basis for the M/I-splines must still include an intercept when using the simplex as the constraint (i.e. intercept in the basis is not removed, but instead the simplex is used to ensure identifiability of both beta_0 AND the intercept coefficient in the basis). --- R/misc.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/misc.R b/R/misc.R index 2ee0dd37d..b2ae81527 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1754,10 +1754,10 @@ get_basis <- function(x, iknots, bknots = range(x), degree = degree, intercept = intercept) } else if (type == "is") { out <- splines2::iSpline(x, knots = iknots, Boundary.knots = bknots, - degree = degree, intercept = intercept) + degree = degree, intercept = TRUE) } else if (type == "ms") { out <- splines2::mSpline(x, knots = iknots, Boundary.knots = bknots, - degree = degree, intercept = intercept) + degree = degree, intercept = TRUE) } else { stop2("'type' is not yet accommodated.") } From 9c4312f7c40c821e8c64a45447a4bd1e8dbbfccb Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 11:40:43 +1000 Subject: [PATCH 161/225] plot.stansurv: add more documentation for param n --- R/plots.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/plots.R b/R/plots.R index f19ac7096..3686dec35 100644 --- a/R/plots.R +++ b/R/plots.R @@ -193,8 +193,9 @@ plot.stanreg <- function(x, plotfun = "intervals", pars = NULL, #' include in the plot. Can be \code{"ci"} for the Bayesian posterior #' uncertainty interval, or \code{"none"}. This argument is only relevant #' when \code{plotfun = "basehaz"} or \code{plotfun = "tve"} -#' @param n Integer, the number of time points at which to interpolate the -#' function when plotting the baseline hazard or time-varying hazard ratio. +#' @param n Integer specifying the number of points to interpolate along +#' when plotting the baseline hazard or time-varying hazard ratio. Each of +#' the points are joined using a line. #' plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, regex_pars = NULL, ..., prob = 0.95, From b5ef03b7e1984bd518fbeee08a8ada8bccfa4159 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 13:38:39 +1000 Subject: [PATCH 162/225] use bSpline function instead of bs --- R/misc.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/misc.R b/R/misc.R index b2ae81527..4b59e7d2b 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1750,14 +1750,14 @@ get_basis <- function(x, iknots, bknots = range(x), type = c("bs", "is", "ms")) { type <- match.arg(type) if (type == "bs") { - out <- splines::bs(x, knots = iknots, Boundary.knots = bknots, - degree = degree, intercept = intercept) + out <- splines2::bSpline(x, knots = iknots, Boundary.knots = bknots, + degree = degree, intercept = intercept) } else if (type == "is") { out <- splines2::iSpline(x, knots = iknots, Boundary.knots = bknots, - degree = degree, intercept = TRUE) + degree = degree, intercept = TRUE) } else if (type == "ms") { out <- splines2::mSpline(x, knots = iknots, Boundary.knots = bknots, - degree = degree, intercept = TRUE) + degree = degree, intercept = TRUE) } else { stop2("'type' is not yet accommodated.") } From 266de624bef238cb6b2c8fd8bab2fc775761ad02 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 14:04:45 +1000 Subject: [PATCH 163/225] Fix small bug in handle_basehaz --- R/stan_surv.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/stan_surv.R b/R/stan_surv.R index 89f642879..a1ab4d1ef 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1407,6 +1407,7 @@ handle_basehaz_surv <- function(basehaz, if (basehaz %in% c("exp", "exp-aft")) { + degree <- NULL # degree for splines bknots <- NULL # boundary knot locations iknots <- NULL # internal knot locations basis <- NULL # spline basis @@ -1414,6 +1415,7 @@ handle_basehaz_surv <- function(basehaz, } else if (basehaz %in% c("weibull", "weibull-aft")) { + degree <- NULL # degree for splines bknots <- NULL # boundary knot locations iknots <- NULL # internal knot locations basis <- NULL # spline basis @@ -1421,6 +1423,7 @@ handle_basehaz_surv <- function(basehaz, } else if (basehaz == "gompertz") { + degree <- NULL # degree for splines bknots <- NULL # boundary knot locations iknots <- NULL # internal knot locations basis <- NULL # spline basis @@ -1442,6 +1445,7 @@ handle_basehaz_surv <- function(basehaz, } else if (basehaz == "piecewise") { + degree <- NULL # degree for splines bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) basis <- NULL # spline basis From 202b7c7a3f5745ed51483a0b411dbac9d6836162 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 16:26:45 +1000 Subject: [PATCH 164/225] Add frailty models to stan_surv vignette --- vignettes/surv.Rmd | 100 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 88 insertions(+), 12 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 3c2eca180..bf444218c 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -167,19 +167,21 @@ h_i(t) = \gamma t^{\gamma-1} \lambda_i(t) h_i(t) = \exp(\gamma t) \lambda_i(t) \end{equation} -- **M-splines model** (`basehaz = "ms"`, the default): letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma} > 0$ we have: +- **M-splines model** (`basehaz = "ms"`, the default): letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta)$ denote a degree $\delta$ M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0} = $ and parameter vector $\boldsymbol{\gamma} > 0$ we have: \ \begin{equation} -h_i(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) \exp ( \eta_i(t) ) +h_i(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta) \exp ( \eta_i(t) ) \end{equation} \ -For identifiability of the intercept $\beta_0$ in the linear predictor $\eta_i$ we constrain the M-spline coefficients to a simplex, that is, $\sum_{j=1}^J{\gamma_j} = 1$. +The M-spline function is calculated using the method described in Ramsay (1988) and implemented in the **splines2** R package (Wang and Yan (2018)). To ensure that the hazard function $h_i(t)$ is not constrained to zero at the origin (i.e. when $t$ approaches 0) the M-spline basis incorporates an intercept. To ensure identifiability of both the intercept parameter in the M-spline function and the intercept parameter in the linear predictor (i.e. $\beta_0$) we constrain the M-spline coefficients to a simplex, that is, $\sum_{j=1}^J{\gamma_j} = 1$. The default degree in **rstanarm** is $\delta = 3$; that is, cubic M-splines. However this can be controlled by the user via the `basehaz_ops` argument. It is worthwhile noting that $\delta = 0$ would correspond to a piecewise constant baseline hazard. -- **B-splines model** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0})$ denote a cubic B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have: +- **B-splines model** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta)$ denote a degree $\delta$ B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have: \ \begin{equation} -h_i(t) = \exp ( B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}) + \eta_i(t) ) +h_i(t) = \exp ( B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta) + \eta_i(t) ) \end{equation} +\ +The B-spline function is calculated using the method implemented in the **splines2** R package (Wang and Yan (2018)). The B-spline basis does not require an intercept and therefore does not include one; any constant shift in the log hazard is fully captured via the intercept in the linear predictor (i.e. $\beta_0$). **Note:** When the linear predictor *is not* time-varying (i.e. under proportional hazards) there is a closed form expression for the survival probability (except for the B-splines model); details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under non-proportional hazards) there is no closed form expression for the survival probability; instead, quadrature is used to evaluate the survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. @@ -324,7 +326,7 @@ The additional coefficients required for estimating time-varying effects (i.e. t # Usage examples -## Example: a flexible parametric proportional hazards model +## Example: A flexible parametric proportional hazards model We will use the German Breast Cancer Study Group dataset (see `?rstanarm-datasets` for details and references). In brief, the data consist of $N = 686$ patients with primary node positive breast cancer recruited between 1984-1989. The primary response is time to recurrence or death. Median follow-up time was 1084 days. Overall, there were 299 (44%) events and the remaining 387 (56%) individuals were right censored. We concern our analysis here with a 3-category baseline covariate for cancer prognosis (good/medium/poor). @@ -443,7 +445,7 @@ plot(ph) + We can quite clearly see in the plot the assumption of proportional hazards. We can also see that the hazard is highest in the `Poor` prognosis group (i.e. worst survival) and the hazard is lowest in the `Good` prognosis group (i.e. best survival). This corresponds to what we saw in the plot of the survival functions previously. -## Example: non-proportional hazards modelled using B-splines +## Example: Non-proportional hazards modelled using B-splines To demonstrate the implementation of time-varying effects in `stan_surv` we will use a simulated dataset, generated using the **simsurv** package (Brilleman, 2018). @@ -510,11 +512,12 @@ From the plot, we can see how the hazard ratio (i.e. the effect of treatment on The plot shows a large amount of uncertainty around the estimated time-varying hazard ratio. This is to be expected, since we only simulated a dataset of 200 individuals of which only around 70% experienced the event before being censored at 5 years. So, there is very little data (i.e. very few events) with which to reliably estimate the time-varying hazard ratio. We can also see this reflected in the differences between our data generating model and the estimates from our fitted model. In our data generating model, the time-varying hazard ratio equals 1 (i.e. the log hazard ratio equals 0) at 2.5 years, but in our fitted model the median estimate for our time-varying hazard ratio equals 1 at around ~3 years. This is a reflection of the large amount of sampling error, due to our simulated dataset being so small. -## Example: non-proportional hazards modelled using a piecewise constant function +## Example: Non-proportional hazards modelled using a piecewise constant function In the previous example we showed how non-proportional hazards can be modelled by using a smooth B-spline function for the time-varying log hazard ratio. This is the default approach when the `tve` function is used to estimate a time-varying effect for a covariate in the model formula. However, another approach for modelling a time-varying log hazard ratio is to use a piecewise constant function. If we want to use a piecewise constant for the time-varying log hazard ratio (instead of the smooth B-spline function) then we just have to specify the `type` argument to the `tve` function. -We will again simulate some survival data using the **simsurv** package (Brilleman, 2018) to show how a piecewise constant hazard ratio can be estimated using `stan_surv`. +We will again simulate some survival data using the **simsurv** package to show how a piecewise constant hazard ratio can be estimated using `stan_surv`. + Similar to the previous example, we will simulate a dataset with $N = 500$ individuals with event times generated under a Weibull hazard function with scale parameter $\lambda = 0.1$, shape parameter $\gamma = 1.5$, and binary baseline covariate $X_i \sim \text{Bern}(0.5)$. However, in this example our time-varying hazard ratio will be defined as $\beta(t) = -0.5 + 0.7 \times I(t > 2.5)$ where $I(X)$ is the indicator function taking the value 1 if $X$ is true and 0 otherwise. This corresponds to a piecewise constant log hazard ratio with just two "pieces" or time intervals. The first time interval is $[0,2.5]$ during which the true hazard ratio is $\exp(-0.5) = 0.61$. The second time interval is $(2.5,\infty]$ during which the true log hazard ratio is $\exp(-0.5 + 0.7) = 1.22$. Our example uses only two time intervals for simplicity, but in general we could easily have considered more (although it would have required couple of additional lines of code to simulate the data). We will again enforce administrative censoring at 5 years if an individual's simulated event time is >5 years. ```{r simsurv-simdata2} @@ -544,9 +547,9 @@ dat <- merge(dat, covs) head(dat) ``` -We know estimate a model with a piecewise constant time-varying effect for the covariate `trt` as +We now estimate a model with a piecewise constant time-varying effect for the covariate `trt` as -```{r tve_fit2, warning = FALSE, message = FALSE, results='hide'} +```{r tve-fit2, warning = FALSE, message = FALSE, results='hide'} mod3 <- stan_surv(formula = Surv(eventtime, status) ~ tve(trt, type = "pw", knots = 2.5), data = dat, @@ -566,12 +569,85 @@ plot(mod3, plotfun = "tve") Here we see that the estimated hazard ratio reasonably reflects our true data generating model (i.e. a hazard ratio of $\approx 0.6$ during the first time interval and a hazard ratio of $\approx 1.2$ during the second time interval) although there is a slight discrepancy due to the sampling variation in the simulated event times. +## Example: Hierarchical survival models + +To demonstrate the estimation of a hierarchical model for survival data in `stan_surv` we will use the `frail` dataset (see `help("rstanarm-datasets")` for a description). The `frail` datasets contains simulated event times for 200 patients clustered within 20 hospital sites (10 patients per hospital site). The event times are simulated from a parametric proportional hazards model under the following assumptions: (i) a constant (i.e. exponential) baseline hazard rate of 0.1; (ii) a fixed treatment effect with log hazard ratio of 0.3; and (iii) a site-specific random intercept (specified on the log hazard scale) drawn from a N(0,1) distribution. + +Let's look at the first few rows of the data: + +```{r frail-data-head} +head(frail) +``` + +To fit a hierarchical model for clustered survival data we use a formula syntax similar to what is used in the **lme4** R package (Bates et al. (2015)). Let's consider the following model (which aligns with the model used to generate the simulated data): + +```{r frail-fit-model, warning = FALSE, message = FALSE} +mod_randint <- stan_surv( + formula = Surv(eventtime, status) ~ trt + (1 | site), + data = frail, + basehaz = "exp", + chains = CHAINS, + cores = CORES, + seed = SEED, + iter = ITER) +``` + +The model contains a baseline covariate for treatment (0 or 1) as well as a site-specific intercept to allow for correlation in the event times for patients from the same site. We've call the model object `mod_randint` to denote the fact that it includes a site-specific (random) intercept. Let's examine the parameter estimates from the model: + +```{r frail-estimates} +print(mod_randint, digits = 2) +``` + +We see that the estimated log hazard ratio for treatment ($\hat{\beta}_{\text{(trt)}} = 0.46$) is a bit larger than the "true" log hazard ratio used in the data generating model ($\beta_{\text{(trt)}} = 0.3$). The estimated baseline hazard rate is $\exp(-2.3716) = 0.093$, which is pretty close to the baseline hazard rate used in the data generating model ($0.1$). Of course, the differences between the estimated parameters and the true parameters from the data generating model are attributable to sampling noise. + +If this were a real analysis, we might wonder whether the site-specific estimates are necessary! Well, we can assess that by fitting an alternative model that does **not** include the site-specific intercepts and compare it to the model we just estimated. We will compare it using the `loo` function. We first need to fit the model without the site-specific intercept. To do this, we will just use the generic `update` method for `stansurv` objects, since all we are changing is the model formula: + +```{r frail-fixed-model, warning = FALSE, message = FALSE} +mod_fixed <- update(mod_randint, formula. = Surv(eventtime, status) ~ trt) +``` + +Let's calculate the `loo` for both these models and compare them: + +```{r frail-compare-1, warning = FALSE, message = FALSE} +loo_fixed <- loo(mod_fixed) +loo_randint <- loo(mod_randint) +compare_models(loo_fixed, loo_randint) +``` + +We see strong evidence in favour of the model with the site-specific intercepts! + +But let's not quite finish there. What about if we want to generalise the random effects structure further. For instance, is the site-specific intercept enough? Perhaps we should consider estimating both a site-specific intercept and a site-specific treatment effect. We have minimal data to estimate such a model (recall that there is only 20 sites and 10 patients per site) but for the sake of demonstration we will forge on nonetheless. Let's fit a model with both a site-specific intercept and a site-specific coefficient for the covariate `trt` (i.e. treatment): + +```{r frail-random-trt, warning = FALSE, message = FALSE} +mod_randtrt <- update(mod_randint, formula. = + Surv(eventtime, status) ~ trt + (trt | site)) +print(mod_randtrt, digits = 2) +``` + +We see that we have an estimated standard deviation for the site-specific intercepts and the site-specific coefficients for `trt`, as well as the estimated correlation between those site-specific parameters. + +Let's now compare all three of these models based on `loo`: + +```{r frail-compare-2, warning = FALSE, message = FALSE} +loo_randtrt <- loo(mod_randtrt) +compare_models(loo_fixed, loo_randint, loo_randtrt) +``` + +It appears that the model with just a site-specific intercept is the best fitting model. It is much better than the model without a site-specific intercept, and slightly better than the model with both a site-specific intercept and a site-specific treatment effect. In other words, including a site-specific intercept appears important, but including a site-specific treatment effect is not. This conclusion is reassuring, because it aligns with the data generating model we used to simulate the data! + + # References -Brilleman, S. (2018) *simsurv: Simulate Survival Data.* R package version 0.2.2. \url{https://CRAN.R-project.org/package=simsurv} +Bates D, Maechler M, Bolker B, Walker S. Fitting Linear Mixed-Effects Models Using lme4. *Journal of Statistical Software* 2015;67(1):1--48. \url{https://doi.org/10.18637/jss.v067.i01} + +Brilleman S. (2018) *simsurv: Simulate Survival Data.* R package version 0.2.2. \url{https://CRAN.R-project.org/package=simsurv} Hougaard P. Fundamentals of Survival Data. *Biometrics* 1999;55:13--22. +Ramsay JO. Monotone Regression Splines in Action. *Statistical Science* 1988;3(4):425--461. \url{https://doi.org/10.1214/ss/1177012761} + +Wang W, Yan J. (2018) *splines2: Regression Spline Functions and Classes.* R package version 0.2.8. \url{https://CRAN.R-project.org/package=splines2} + # Appendix A: Parameterisations on the hazard scale From 7f2fdf0127fbd0e97f43047a080d6dbabb1795b4 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 16:27:57 +1000 Subject: [PATCH 165/225] stan_surv: add example for frailty models --- R/stan_surv.R | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index a1ab4d1ef..71305897b 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -29,11 +29,14 @@ #' either proportional or non-proportional hazards; and #' (iii) standard parametric (exponential, Weibull) accelerated failure time #' models, with covariates included under assumptions of either time-fixed or -#' time-varying survival time ratios. -#' Where relevant, the user can choose between either a smooth B-spline -#' function or a piecewise constant function for modelling each time-varying -#' coefficient (i.e. time-varying log hazard ratio or time-varying log -#' survival time ratio) in the linear predictor. +#' time-varying survival time ratios. Left, right, and interval censored +#' survival data are allowed. Delayed entry is allows. Both fixed and random +#' effects can be estimated for covariates (i.e. group-specific parameters +#' are allowed). Time-varying covariates and time-varying coefficients are +#' both allowed. For modelling time-varying coefficients (i.e. time-varying +#' log hazard ratio or time-varying log survival time ratio) the user can +#' choose between either a smooth B-spline function or a piecewise constant +#' function. #' #' @export #' @importFrom splines bs @@ -50,7 +53,10 @@ #' object. Left censored, right censored, and interval censored data #' are allowed, as well as delayed entry (i.e. left truncation). See #' \code{\link[survival]{Surv}} for how to specify these outcome types. -#' If you wish to include time-varying effects (i.e. time-varying +#' The right hand side of the formula can include fixed and/or random +#' effects of covariates, with random effects specified in the same +#' way as for the \code{\link[lme4]{lmer}} function in the \pkg{lme4} +#' package. If you wish to include time-varying effects (i.e. time-varying #' coefficients, e.g. non-proportional hazards) in the model #' then any covariate(s) that you wish to estimate a time-varying #' coefficient for should be specified as \code{tve(varname)} where @@ -421,7 +427,21 @@ #' #' # same model (...slight differences due to sampling) #' summary(m_ph, par = "log-posterior")[, 'mean'] -#' summary(m_aft, par = "log-posterior")[, 'mean'] +#' summary(m_aft, par = "log-posterior")[, 'mean'] +#' +#' #----- Frailty model, i.e. site-specific intercepts +#' +#' m_frail <- stan_surv( +#' formula = Surv(eventtime, status) ~ trt + (1 | site), +#' data = frail[1:40,], +#' basehaz = "exp", +#' chains = 1, +#' refresh = 0, +#' iter = 600, +#' seed = 123) +#' print(m_frail) # shows SD for frailty +#' VarCorr(m_frail) # extract SD explicitly +#' #' } #' stan_surv <- function(formula, From 5c824fbcd3a87fe76bb540dc7a4a5cabb8a6e591 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 16:40:09 +1000 Subject: [PATCH 166/225] Fix typo --- R/stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 71305897b..b46edf2eb 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -30,10 +30,10 @@ #' (iii) standard parametric (exponential, Weibull) accelerated failure time #' models, with covariates included under assumptions of either time-fixed or #' time-varying survival time ratios. Left, right, and interval censored -#' survival data are allowed. Delayed entry is allows. Both fixed and random +#' survival data are allowed. Delayed entry is allowed. Both fixed and random #' effects can be estimated for covariates (i.e. group-specific parameters #' are allowed). Time-varying covariates and time-varying coefficients are -#' both allowed. For modelling time-varying coefficients (i.e. time-varying +#' both allowed. For modelling each time-varying coefficient (i.e. time-varying #' log hazard ratio or time-varying log survival time ratio) the user can #' choose between either a smooth B-spline function or a piecewise constant #' function. From 25aaaca8a8e84e6491f8e4e7f4c10fb0feba28a2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 17:05:46 +1000 Subject: [PATCH 167/225] stan_surv: update documentation for M-splines --- R/stan_surv.R | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index b46edf2eb..2dc529ccf 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -71,7 +71,7 @@ #' #' The following are available under a hazard scale formulation: #' \itemize{ -#' \item \code{"ms"}: a flexible parametric model using cubic M-splines to +#' \item \code{"ms"}: A flexible parametric model using cubic M-splines to #' model the baseline hazard. The default locations for the internal knots, #' as well as the basis terms for the splines, are calculated with respect #' to time. If the model does \emph{not} include any time-dependendent @@ -80,7 +80,7 @@ #' On the other hand, if the model does include time-varying effects then #' quadrature is used to evaluate the cumulative hazard at each MCMC #' iteration and, therefore, estimation of the model will be slower. -#' \item \code{"bs"}: a flexible parametric model using cubic B-splines to +#' \item \code{"bs"}: A flexible parametric model using cubic B-splines to #' model the \emph{log} baseline hazard. The default locations for the #' internal knots, as well as the basis terms for the splines, are calculated #' with respect to time. A closed form solution for the cumulative hazard @@ -89,10 +89,10 @@ #' the cumulative hazard at each MCMC iteration. Therefore, if your model #' does not include any time-varying effects, then estimation using the #' \code{"ms"} baseline hazard will be faster. -#' \item \code{"exp"}: an exponential distribution for the event times +#' \item \code{"exp"}: An exponential distribution for the event times #' (i.e. a constant baseline hazard). -#' \item \code{"weibull"}: a Weibull distribution for the event times. -#' \item \code{"gompertz"}: a Gompertz distribution for the event times. +#' \item \code{"weibull"}: A Weibull distribution for the event times. +#' \item \code{"gompertz"}: A Gompertz distribution for the event times. #' } #' #' The following are available under an accelerated failure time (AFT) @@ -104,12 +104,23 @@ #' @param basehaz_ops A named list specifying options related to the baseline #' hazard. Currently this can include: \cr #' \itemize{ +#' \item \code{degree}: A positive integer specifying the degree for the +#' M-splines or B-splines. The default is \code{degree = 3}, which +#' corresponds to cubic splines. Note that specifying \code{degree = 0} +#' is also allowed and corresponds to piecewise constant. #' \item \code{df}: A positive integer specifying the degrees of freedom -#' for the M-splines or B-splines. Two boundary knots and \code{df - 3} -#' internal knots are used to generate the cubic spline basis. The default -#' is \code{df = 5}; that is, two boundary knots and two internal knots. -#' The internal knots are placed at equally spaced percentiles of the -#' distribution of uncensored event times. +#' for the M-splines or B-splines. For M-splines (i.e. when +#' \code{basehaz = "ms"}), two boundary knots and \code{df - degree - 1} +#' internal knots are used to generate the spline basis. For B-splines +#' (i.e. when \code{basehaz = "bs"}), two boundary knots and +#' \code{df - degree} internal knots are used to generate the spline +#' basis. The difference is due to the fact that the M-spline basis +#' includes an intercept, whereas the B-spline basis does not. The +#' default is \code{df = 6} for M-splines and \code{df = 5} for +#' B-splines (i.e. two boundary knots and two internal knots when the +#' default cubic splines are being used). The internal knots are placed +#' at equally spaced percentiles of the distribution of uncensored event +#' times. #' \item \code{knots}: A numeric vector explicitly specifying internal #' knot locations for the M-splines or B-splines. Note that \code{knots} #' cannot be specified if \code{df} is specified. @@ -1404,7 +1415,11 @@ handle_basehaz_surv <- function(basehaz, stop2("Cannot specify both 'df' and 'knots' for the baseline hazard.") if (is.null(df)) - df <- 5L # assumes no intercept, ignored if the user specified knots + df <- switch(basehaz, + "ms" = 6L, # assumes intercept + "bs" = 5L, # assumes no intercept + "piecewise" = 5L, # assumes no intercept + df) # NB this is ignored if the user specified knots if (is.null(degree)) degree <- 3L # cubic splines From 7925a1776718440990408d39a5720a72a23b79d4 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 6 Jun 2019 17:14:11 +1000 Subject: [PATCH 168/225] Fix typo --- R/stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 2dc529ccf..e7c5538b1 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -402,8 +402,8 @@ #' d4 <- simsurv(lambdas = 0.1, #' gammas = 1.5, #' betas = c(trt = -0.5), -#' tde = c(trt = 0.4), -#' tdefun = function(t) { (t > 2.5) } +#' tve = c(trt = 0.4), +#' tvefun = function(t) { (t > 2.5) }, #' x = covs, #' maxt = 5) #' d4 <- merge(d4, covs) From a708aa30ae30b0d311e6eea73cd695afaa392c24 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 18 Jun 2019 11:22:21 +1000 Subject: [PATCH 169/225] stan_surv vignette: fix small typo --- vignettes/surv.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index bf444218c..e0ae8fbf0 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -251,7 +251,7 @@ for scale parameter $\lambda_i = \exp ( -\gamma \eta_i )$ and shape parameter $\ ## Time-fixed and time-varying effects of covariates -The coefficient $\beta_p(t)$ (i.e. the log hazard ratio) or $\beta_p^*(t)$ (i.e. log survival time ratio) can be treated as a time-fixed quantity (e.g. $\beta_p(t) = \beta_p$) or as a time-varying quantity. We refer to the latter as *time-varying effects* because the effect of the covariate is allowed to change as a function of time. In `stan_surv` time-varying effects are specified by using the `tde` function in the model formula. Note that in the following definitions we only refer to $\beta_p(t)$ (i.e. the log hazard ratio) but the same methodology applies to $\beta_p^*(t)$ (i.e. the log survival time ratio). +The coefficient $\beta_p(t)$ (i.e. the log hazard ratio) or $\beta_p^*(t)$ (i.e. log survival time ratio) can be treated as a time-fixed quantity (e.g. $\beta_p(t) = \beta_p$) or as a time-varying quantity. We refer to the latter as *time-varying effects* because the effect of the covariate is allowed to change as a function of time. In `stan_surv` time-varying effects are specified by using the `tve` function in the model formula. Note that in the following definitions we only refer to $\beta_p(t)$ (i.e. the log hazard ratio) but the same methodology applies to $\beta_p^*(t)$ (i.e. the log survival time ratio). Without time-varying effects we have: \ From b02b6d7134721c98bdace53a110cfdd87ebdf514 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 8 Jul 2019 13:26:42 +1000 Subject: [PATCH 170/225] posterior_survfit: add return_matrix argument --- R/posterior_survfit.R | 69 ++++++++++++++++++++++++++++++++++--------- 1 file changed, 55 insertions(+), 14 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 5bb66aae7..e01986249 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -238,8 +238,9 @@ #' were transformed before passing the data to one of the modeling functions #' and \emph{not} if transformations were specified inside the model formula. #' -#' @return A data frame of class \code{survfit.stanjm}. The data frame includes -#' columns for each of the following: +#' @return When \code{return_matrix = FALSE} (the default), a data frame of +#' class \code{survfit.stansurv} or \code{survfit.stanjm}. The data frame +#' includes columns for each of the following: #' (i) the median of the posterior predictions (\code{median}); #' (ii) each of the lower and upper limits of the corresponding uncertainty #' interval for the posterior predictions (\code{ci_lb} and \code{ci_ub}); @@ -250,7 +251,17 @@ #' (v) the last known survival time on which the prediction is conditional #' (\code{cond_time}); this will be set to NA if not relevant. #' The returned object also includes a number of additional attributes. -#' +#' +#' When \code{return_matrix = TRUE} a list of matrices is returned. Each +#' matrix contains the predictions evaluated at one step of the +#' extrapolation time sequence (note that if \code{extrapolate = FALSE} +#' then the list will be of length one, i.e. the predictions are only +#' evaluated at one time point for each individual). Each matrix has +#' \code{draws} rows by \code{nrow(newdata)} columns, such that each +#' row contains a vector of predictions generated using a single draw of +#' the model parameters from the posterior distribution. The returned +#' list also includes a number of additional attributes. +#' #' @seealso #' \code{\link{plot.survfit.stanjm}} for plotting the estimated survival #' probabilities \cr @@ -331,17 +342,18 @@ posterior_survfit <- function(object, ...) UseMethod("posterior_survfit") #' @export #' posterior_survfit.stansurv <- function(object, - newdata = NULL, - type = "surv", - extrapolate = TRUE, - control = list(), - condition = FALSE, - last_time = NULL, - prob = 0.95, - times = NULL, - standardise = FALSE, - draws = NULL, - seed = NULL, + newdata = NULL, + type = "surv", + extrapolate = TRUE, + control = list(), + condition = FALSE, + last_time = NULL, + prob = 0.95, + times = NULL, + standardise = FALSE, + draws = NULL, + seed = NULL, + return_matrix = FALSE, ...) { validate_stansurv_object(object) @@ -480,6 +492,20 @@ posterior_survfit.stansurv <- function(object, attr(surv, "last_time") <- last_time } + # Optionally return draws rather than summarising into median and CI + if (return_matrix) { + return(structure(surv, + type = type, + extrapolate = extrapolate, + control = control, + condition = condition, + standardise = standardise, + last_time = if (condition) last_time else NULL, + ids = id_list, + draws = NROW(stanmat), + seed = seed)) + } + # Summarise posterior draws to get median and CI out <- .pp_summarise_surv(surv = surv, prob = prob, @@ -521,6 +547,7 @@ posterior_survfit.stanjm <- function(object, scale = 1.5, draws = NULL, seed = NULL, + return_matrix = FALSE, ...) { validate_stanjm_object(object) @@ -709,6 +736,20 @@ posterior_survfit.stanjm <- function(object, surv <- surv_t } + # Optionally return draws rather than summarising into median and CI + if (return_matrix) { + return(structure(surv, + type = type, + extrapolate = extrapolate, + control = control, + condition = condition, + standardise = standardise, + last_time = if (condition) last_time else NULL, + ids = id_list, + draws = NROW(stanmat), + seed = seed)) + } + # Summarise posterior draws to get median and CI out <- .pp_summarise_surv(surv = surv, prob = prob, From 9926d571e2c9cb085596efbe10dfb9df61fa6f3e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 8 Jul 2019 13:33:36 +1000 Subject: [PATCH 171/225] posterior_survfit: document return_matrix argument --- R/posterior_survfit.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index e01986249..2338523f3 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -188,6 +188,12 @@ #' default number of draws for \code{stan_jm} models is because dynamic #' predictions (when \code{dynamic = TRUE}) can be slow. #' @param seed An optional \code{\link[=set.seed]{seed}} to use. +#' @param return_matrix A logical. If \code{TRUE} then a list of \code{draws} by +#' \code{nrow(newdata)} matrices is returned. Each matrix contains the actual +#' simulations or draws from the posterior predictive distribution. Otherwise +#' if \code{return_matrix} is set to \code{FALSE} (the default) then a +#' data frame is returned. See the \strong{Value} section below for more +#' detail. #' @param ... Currently unused. #' #' @details From 66b5e58730237719352b48e2579117768bd3baab Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 9 Jul 2019 17:36:20 +1000 Subject: [PATCH 172/225] Allow marginalised survival predictions for stan_jm --- R/misc.R | 12 +- R/posterior_survfit.R | 71 ++++--- R/posterior_traj.R | 465 ++++++++++++++++++++++++++---------------- R/pp_data.R | 26 ++- 4 files changed, 362 insertions(+), 212 deletions(-) diff --git a/R/misc.R b/R/misc.R index 4b59e7d2b..eadfc98a2 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1298,9 +1298,11 @@ check_pp_ids <- function(object, ids, m = 1) { # variable must be included in the new data frame # @return A list of validated data frames validate_newdatas <- function(object, newdataLong = NULL, newdataEvent = NULL, - duplicate_ok = FALSE, response = TRUE) { + duplicate_ok = FALSE, response = TRUE, + needs_time_var = TRUE) { validate_stanmvreg_object(object) id_var <- object$id_var + time_var <- object$time_var newdatas <- list() if (!is.null(newdataLong)) { if (!is(newdataLong, "list")) @@ -1308,6 +1310,14 @@ validate_newdatas <- function(object, newdataLong = NULL, newdataEvent = NULL, dfcheck <- sapply(newdataLong, is.data.frame) if (!all(dfcheck)) stop("'newdataLong' must be a data frame or list of data frames.", call. = FALSE) + if (!needs_time_var) { + newdataLong <- lapply(newdataLong, function(m) { + if (!time_var %in% colnames(m)) { + m[[time_var]] <- 0 # hack to pass nacheck below + } + m + }) + } nacheck <- sapply(seq_along(newdataLong), function(m) { if (response) { # newdataLong needs the reponse variable fmL <- formula(object, m = m) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 2338523f3..53a332aee 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -26,8 +26,9 @@ #' \code{condition} argument discussed below). Predictions are obtained #' using unique draws from the posterior distribution of each of the model #' parameters and then summarised into a median and posterior uncertainty -#' interval. For \code{stan_jm} models "dynamic" predictions are also allowed -#' (see the \code{dynamic} argument discussed below). +#' interval. For \code{stan_jm} models "dynamic" predictions are allowed and +#' are in fact the default when new data is provided (see the \code{dynamic} +#' argument discussed below). #' #' #' @export @@ -55,7 +56,8 @@ #' for variables with which to predict. If omitted, the model matrices are #' used. If new data is provided, then it should also contain the longitudinal #' outcome data on which to condition when drawing the new group-specific -#' coefficients for individuals in the new data. Note that there is only +#' coefficients for individuals in the new data unless the \code{dynamic} +#' argument is set to \code{FALSE}. Note that there is only #' allowed to be one row of data for each individual in \code{newdataEvent}, #' that is, time-varying covariates are not allowed in the prediction data for #' the event submodel. Also, \code{newdataEvent} can optionally include a @@ -168,10 +170,13 @@ #' in the joint modelling context, because the predictions can be updated #' each time additional longitudinal biomarker data is collected on the individual. #' On the other hand, if \code{dynamic = FALSE} then the survival probabilities -#' will just be marginalised over the distribution of the group-specific -#' coefficients; this will mean that the predictions will incorporate all -#' uncertainty due to between-individual variation so there will likely be -#' very wide credible intervals on the predicted survival probabilities. +#' will be obtained by marginalising over the distribution of the group-specific +#' coefficients; this has the benefit that the user does not need to provide +#' longitudinal outcome data for the new individuals, but it will also +#' mean that the survival predictions will incorporate all uncertainty due +#' to between-individual variation in the longitudinal trajectories and so +#' there is likely to be very wide credible intervals on the predicted +#' survival probabilities. #' @param scale Only relevant for \code{stan_jm} models when new data #' is supplied and \code{dynamic = TRUE}, in which case new random effects #' are simulated for the individuals in the new data using a @@ -213,12 +218,15 @@ #' \code{standardise} argument. #' #' For \code{stansurv} objects, the predicted quantities are calculated for -#' each row of the prediction data, at the specified \code{times} as well as -#' any times generated through extrapolation (when \code{extrapolate = TRUE}). -#' For \code{stanjm} objects, these quantities are calculated for each -#' individual, at the specified \code{times} as well as any times generated -#' through extrapolation (when \code{extrapolate = TRUE}). +#' \emph{each row of the prediction data}, at the specified \code{times} as +#' well as any times generated through extrapolation (when +#' \code{extrapolate = TRUE}). #' +#' For \code{stanjm} objects, the predicted quantities are calculated for +#' \emph{each individual}, at the specified \code{times} as well as any times +#' generated through extrapolation (when \code{extrapolate = TRUE}). +#' +#' \subsection{Dynamic versus marginalised predictions}{ #' The following also applies for \code{stanjm} objects. #' By default the survival probabilities are conditional on an individual's #' group-specific coefficients (i.e. their individual-level random @@ -234,8 +242,11 @@ #' group-specific coefficients. This has the benefit that the user does #' not need to provide longitudinal outcome measurements for the new #' individuals, however, it does mean that the predictions will incorporate -#' all the uncertainty associated with between-individual variation, since -#' the predictions aren't conditional on any observed data for the individual. +#' all the uncertainty associated with between-individual variation in the +#' biomarker (longitudinal outcome) values since the predictions aren't +#' conditional on any observed biomarker (longitudinal outcome) data for +#' the individual. +#' } #' #' @note #' Note that if any variables were transformed (e.g. rescaled) in the data @@ -262,10 +273,11 @@ #' matrix contains the predictions evaluated at one step of the #' extrapolation time sequence (note that if \code{extrapolate = FALSE} #' then the list will be of length one, i.e. the predictions are only -#' evaluated at one time point for each individual). Each matrix has -#' \code{draws} rows by \code{nrow(newdata)} columns, such that each -#' row contains a vector of predictions generated using a single draw of -#' the model parameters from the posterior distribution. The returned +#' evaluated at \code{times} which corresponds to just one time point +#' for each individual). Each matrix will have \code{draws} rows and +#' \code{nrow(newdata)} columns, such that each row contains a +#' vector of predictions generated using a single draw of the model +#' parameters from the posterior distribution. The returned #' list also includes a number of additional attributes. #' #' @seealso @@ -593,10 +605,8 @@ posterior_survfit.stanjm <- function(object, ndL <- dats[1:M] ndE <- dats[["Event"]] } else { # user specified newdata - if (!dynamic) - stop2("Marginalised predictions for the event outcome are ", - "not currently implemented.") - newdatas <- validate_newdatas(object, newdataLong, newdataEvent) + newdatas <- validate_newdatas(object, newdataLong, newdataEvent, + response = dynamic, needs_time_var = dynamic) ndL <- newdatas[1:M] ndE <- newdatas[["Event"]] } @@ -722,7 +732,8 @@ posterior_survfit.stanjm <- function(object, pars = pars, type = type, id_list = id_list, - standardise = standardise) + standardise = standardise, + dynamic = dynamic) # Calculate survival probability at last known survival time and then # use that to calculate conditional survival probabilities @@ -735,7 +746,8 @@ posterior_survfit.stanjm <- function(object, newdataEvent = ndE, pars = pars, type = type, - id_list = id_list) + id_list = id_list, + dynamic = dynamic) surv <- lapply(surv_t, function(x) truncate(x / cond_surv, upper = 1)) attr(surv, "last_time") <- last_time } else { @@ -776,9 +788,11 @@ posterior_survfit.stanjm <- function(object, newdataEvent = ndE, pars = pars, type = type, - id_list = id_list) + id_list = id_list, + dynamic = dynamic) surv2 <- lapply(surv_t, function(x) truncate(x / cond_surv2, upper = 1)) out2 <- .pp_summarise_surv(surv = surv2, + prob = prob, id_var = id_var, time_var = time_var, standardise = standardise, @@ -822,7 +836,8 @@ posterior_survfit.stanjm <- function(object, pars, type = "surv", id_list = NULL, - standardise = FALSE) { + standardise = FALSE, + dynamic = TRUE) { if (is.stanjm(object) && !identical(length(times), length(id_list))) stop("Bug found: vector of ids should be same length as vector of times.") @@ -851,7 +866,9 @@ posterior_survfit.stanjm <- function(object, newdataEvent = newdataEvent, ids = id_list, etimes = times, - long_parts = FALSE) + long_parts = FALSE, + response = dynamic, + needs_time_var = dynamic) out <- .ll_survival(object, # refactoring for stanjm not yet finished data = ppdat, pars = pars, diff --git a/R/posterior_traj.R b/R/posterior_traj.R index 9555dc8c3..6c40bb71a 100644 --- a/R/posterior_traj.R +++ b/R/posterior_traj.R @@ -271,25 +271,43 @@ #' head(pt8) # note the much narrower ci, compared with pt5 #' } #' -posterior_traj <- function(object, m = 1, newdata = NULL, newdataLong = NULL, - newdataEvent = NULL, interpolate = TRUE, extrapolate = FALSE, - control = list(), last_time = NULL, prob = 0.95, ids, - dynamic = TRUE, scale = 1.5, draws = NULL, seed = NULL, - return_matrix = FALSE, ...) { +posterior_traj <- function(object, + m = 1, + newdata = NULL, + newdataLong = NULL, + newdataEvent = NULL, + interpolate = TRUE, + extrapolate = FALSE, + control = list(), + last_time = NULL, + prob = 0.95, + ids, + dynamic = TRUE, + scale = 1.5, + draws = NULL, + seed = NULL, + return_matrix = FALSE, + ...) { + if (!requireNamespace("data.table")) stop("the 'data.table' package must be installed to use this function") + validate_stanjm_object(object) + M <- object$n_markers; validate_positive_scalar(m, M) id_var <- object$id_var time_var <- object$time_var grp_stuff <- object$grp_stuff[[m]] + if (!is.null(seed)) set.seed(seed) + if (missing(ids)) ids <- NULL + dots <- list(...) - # Deal with deprecate newdata argument + # Deal with deprecated newdata argument if (!is.null(newdata)) { warning("The 'newdata' argument is deprecated. Use 'newdataLong' instead.") if (!is.null(newdataLong)) @@ -351,23 +369,18 @@ posterior_traj <- function(object, m = 1, newdata = NULL, newdataLong = NULL, } # Get stanmat parameter matrix for specified number of draws - S <- posterior_sample_size(object) - if (is.null(draws)) - draws <- if (S > 200L) 200L else S - if (draws > S) - stop("'draws' should be <= posterior sample size (", S, ").") - stanmat <- as.matrix(object$stanfit) - some_draws <- isTRUE(draws < S) - if (some_draws) { - samp <- sample(S, draws) - stanmat <- stanmat[samp, , drop = FALSE] - } - + stanmat <- sample_stanmat(object, draws = draws, default_draws = 200) + # Draw b pars for new individuals if (dynamic && !is.null(newdataEvent)) { - stanmat <- simulate_b_pars(object, stanmat = stanmat, ndL = ndL, ndE = ndE, - ids = id_list, times = last_time, scale = scale) - b_new <- attr(stanmat, "b_new") + stanmat <- simulate_b_pars(object, + stanmat = stanmat, + ndL = ndL, + ndE = ndE, + ids = id_list, + times = last_time, + scale = scale) + b_new <- attr(stanmat, "b_new") acceptance_rate <- attr(stanmat, "acceptance_rate") } @@ -396,41 +409,76 @@ posterior_traj <- function(object, m = 1, newdata = NULL, newdataLong = NULL, newX <- rolling_merge(newX, time_seq[[id_var]], time_seq[[time_var]]) } } - - ytilde <- posterior_predict(object, newdata = newX, m = m, stanmat = stanmat, ...) + + # Obtain posterior predictions at specified times + ytilde <- posterior_predict(object, m = m, + newdata = newX, + stanmat = stanmat, + ...) + + # Optionally return S * N matrix of draws (instead of data frame) if (return_matrix) { attr(ytilde, "mu") <- NULL # remove attribute mu - return(ytilde) # return S * N matrix, instead of data frame - } + return(ytilde) + } + + # Extract draws for the posterior mean mutilde <- attr(ytilde, "mu") if (!is.null(newX) && nrow(newX) == 1L) mutilde <- t(mutilde) + + ytilde_bounds <- median_and_bounds(ytilde, prob) # median and prob% CrI limits mutilde_bounds <- median_and_bounds(mutilde, prob) # median and prob% CrI limits - out <- data.frame(IDVAR = newX[[id_var]], - TIMEVAR = newX[[time_var]], - yfit = mutilde_bounds$med, - ci_lb = mutilde_bounds$lb, ci_ub = mutilde_bounds$ub, - pi_lb = ytilde_bounds$lb, pi_ub = ytilde_bounds$ub) + + # Summarise posterior draws to get median and CI if (grp_stuff$has_grp) { - out$GRPVAR = newX[[grp_var]] # add grp_var and reorder cols - out <- out[, c("IDVAR", "GRPVAR", "TIMEVAR", - "yfit", "ci_lb", "ci_ub", "pi_lb", "pi_ub")] + + nms <- c(id_var, grp_var, time_var, "yfit", "ci_lb", "ci_ub", "pi_lb", "pi_ub") + + out <- data.frame(IDVAR = newX[[id_var]], + TIMEVAR = newX[[time_var]], + GRPVAR = newX[[grp_var]], + yfit = mutilde_bounds$med, + ci_lb = mutilde_bounds$lb, + ci_ub = mutilde_bounds$ub, + pi_lb = ytilde_bounds$lb, + pi_ub = ytilde_bounds$ub) + + } else { + + nms <- c(id_var, time_var, "yfit", "ci_lb", "ci_ub", "pi_lb", "pi_ub") + + out <- data.frame(IDVAR = newX[[id_var]], + TIMEVAR = newX[[time_var]], + yfit = mutilde_bounds$med, + ci_lb = mutilde_bounds$lb, + ci_ub = mutilde_bounds$ub, + pi_lb = ytilde_bounds$lb, + pi_ub = ytilde_bounds$ub) + } - colnames(out) <- c(id_var, if (grp_stuff$has_grp) grp_var, time_var, - "yfit", "ci_lb", "ci_ub", "pi_lb", "pi_ub") - class(out) <- c("predict.stanjm", "data.frame") - Terms <- terms(formula(object, m = m)) - vars <- rownames(attr(Terms, "factors")) - y_var <- vars[[attr(Terms, "response")]] - out <- structure(out, observed_data = ndL[[m]], last_time = last_time, - y_var = y_var, id_var = id_var, time_var = time_var, - grp_var = if (grp_stuff$has_grp) grp_var else NULL, - interpolate = interpolate, extrapolate = extrapolate, - control = control, call = match.call()) + + out <- set_colnames(out, nms) + + # Return object + out <- structure(out, + observed_data = ndL[[m]], + last_time = last_time, + y_var = get_resp_name(object, m = m), + id_var = id_var, + time_var = time_var, + grp_var = if (grp_stuff$has_grp) grp_var else NULL, + interpolate = interpolate, + extrapolate = extrapolate, + control = control, + call = match.call(), + class = c("predict.stanjm", "data.frame")) + if (dynamic && !is.null(newdataEvent)) { out <- structure(out, b_new = b_new, acceptance_rate = acceptance_rate) } + out } @@ -526,166 +574,225 @@ posterior_traj <- function(object, m = 1, newdata = NULL, newdataLong = NULL, #' ggplot2::theme(strip.background = ggplot2::element_blank()) + #' ggplot2::labs(title = "Some plotted longitudinal trajectories") #' } -plot.predict.stanjm <- function(x, ids = NULL, limits = c("ci", "pi", "none"), - xlab = NULL, ylab = NULL, vline = FALSE, - plot_observed = FALSE, facet_scales = "free_x", - ci_geom_args = NULL, grp_overlay = FALSE, ...) { +plot.predict.stanjm <- function(x, + ids = NULL, + limits = c("ci", "pi", "none"), + xlab = NULL, + ylab = NULL, + vline = FALSE, + plot_observed = FALSE, + facet_scales = "free_x", + ci_geom_args = NULL, + grp_overlay = FALSE, + ...) { limits <- match.arg(limits) - if (!(limits == "none")) ci <- (limits == "ci") - y_var <- attr(x, "y_var") - id_var <- attr(x, "id_var") - time_var <- attr(x, "time_var") - grp_var <- attr(x, "grp_var") - obs_dat <- attr(x, "observed_data") + ci <- as.logical(limits == "ci") + pi <- as.logical(limits == "pi") + + y_var <- attr(x, "y_var") # outcome variable + i_var <- attr(x, "id_var") # id variable + g_var <- attr(x, "grp_var") # cluster variable + t_var <- attr(x, "time_var") # time variable + obs_dat <- attr(x, "observed_data") # observed data + fit_dat <- x # predicted data + if (is.null(ylab)) ylab <- paste0("Long. response (", y_var, ")") - if (is.null(xlab)) xlab <- paste0("Time (", time_var, ")") - if (!id_var %in% colnames(x)) + if (is.null(xlab)) xlab <- paste0("Time (", t_var, ")") + + if (!i_var %in% colnames(x)) stop("Bug found: could not find 'id_var' column in the data frame.") - if (!is.null(grp_var) && (!grp_var %in% colnames(x))) + + if (!is.null(g_var) && (!g_var %in% colnames(x))) stop("Bug found: could not find 'grp_var' column in the data frame.") + + # subset data if only plotting for some individuals if (!is.null(ids)) { - ids_missing <- which(!ids %in% x[[id_var]]) - if (length(ids_missing)) - stop("The following 'ids' are not present in the predict.stanjm object: ", - paste(ids[ids_missing], collapse = ", "), call. = FALSE) - plot_dat <- x[x[[id_var]] %in% ids, , drop = FALSE] - obs_dat <- obs_dat[obs_dat[[id_var]] %in% ids, , drop = FALSE] - } else { - plot_dat <- x + fit_dat <- subset_ids(fit_dat, ids, i_var) + obs_dat <- subset_ids(obs_dat, ids, i_var) + } + + # deal with outcome data if plotting observed data points + if (plot_observed) { + obs_dat <- handle_obs_data(obs_dat, + y_var = y_var, + i_var = i_var, + t_var = t_var, + g_var = g_var) } - # 'id_list' provides unique IDs sorted in the same order as plotting data - id_list <- unique(plot_dat[[id_var]]) - if (!is.null(grp_var)) - grp_list <- unique(plot_dat[[grp_var]]) - - plot_dat$id <- factor(plot_dat[[id_var]]) - plot_dat$time <- plot_dat[[time_var]] - if (!is.null(grp_var)) - plot_dat$grp <- plot_dat[[grp_var]] + # obtain list of ids/clusters in the same order as plotting data + i_list <- if (is.null(i_var)) NULL else unique(fit_dat[[i_var]]) # ids + g_list <- if (is.null(g_var)) NULL else unique(fit_dat[[g_var]]) # clusters - geom_defaults <- list(color = "black", method = "loess", se = FALSE) - geom_args <- set_geom_args(geom_defaults, ...) + # create columns with desired names + fit_dat$id <- if (is.null(i_var)) NULL else fit_dat[[i_var]] # ids + fit_dat$grp <- if (is.null(g_var)) NULL else fit_dat[[g_var]] # clusters + fit_dat$time <- if (is.null(t_var)) NULL else fit_dat[[t_var]] # times - lim_defaults <- list(alpha = 0.3) - lim_args <- do.call("set_geom_args", c(defaults = list(lim_defaults), ci_geom_args)) + # promote ids to factors (same as observed data used to fit the model) + fit_dat$id <- factor(fit_dat$id) - obs_defaults <- list() - obs_args <- set_geom_args(obs_defaults) - - if (is.null(grp_var)) { # no lower level clusters + # determine appropriate variable to use for facets + if (is.null(g_var)) { + # no lower level clusters group_var <- NULL facet_var <- "id" - } else if (grp_overlay) { # overlay lower level clusters + } else if (grp_overlay) { + # overlay lower level clusters group_var <- "grp" facet_var <- "id" - } else { # separate facets for lower level clusters + } else { + # separate facet for each lower level cluster group_var <- NULL facet_var <- "grp" } - n_facets <- if (facet_var == "id") length(id_list) else length(grp_list) - - if (n_facets > 60L) { - stop("Too many facets (ie. individuals) to plot. Perhaps limit the ", - "number of individuals by specifying the 'ids' argument.") - } else if (n_facets > 1L) { - geom_mapp <- list( - mapping = aes_string(x = "time", y = "yfit", group = group_var), - data = plot_dat) - graph <- ggplot() + theme_bw() + - do.call("geom_smooth", c(geom_mapp, geom_args)) + + + # validate the number of facets + n_facets <- if (facet_var == "id") length(i_list) else length(g_list) + + if (n_facets > 60L) + stop("Too many facets (ie. individuals) to plot. Perhaps ", + "limit the number of individuals by specifying the 'ids' argument.") + + # determine which limits to plot (used in aes mapping) + lim_lb <- if (ci) "ci_lb" else "pi_lb" + lim_ub <- if (ci) "ci_ub" else "pi_ub" + + # geom mapping for posterior median + med_mapp <- create_geom_mapp(x = "time", + y = "yfit", + group = group_var) + + # geom mapping for ci limits + lim_mapp <- create_geom_mapp(x = "time", + ymin = lim_lb, + ymax = lim_ub) + + # geom mapping for observed data + obs_mapp <- create_geom_mapp(x = "time", + y = "yobs", + group = group_var) + + # determine default plotting args + med_defaults <- list(color = "black") # for posterior median + lim_defaults <- list(alpha = 0.3) # for ci limits + obs_defaults <- list() # for observed data + + # combine default and user-specified plotting args + med_args <- create_geom_args(med_defaults, list(...)) + lim_args <- create_geom_args(lim_defaults, ci_geom_args) + obs_args <- create_geom_args(obs_defaults, list()) + + # construct each plot component + graph_base <- + ggplot(fit_dat) + theme_bw() + + do.call("geom_line", c(med_mapp, med_args)) + + graph_limits <- + if (ci || pi) { + do.call("geom_ribbon", c(lim_mapp, lim_args)) + } else NULL + + graph_facet <- + if (n_facets > 1L) { facet_wrap(facet_var, scales = facet_scales) - if (!limits == "none") { - graph_smoothlim <- ggplot(plot_dat) + - geom_smooth( - aes_string(x = "time", y = if (ci) "ci_lb" else "pi_lb", group = group_var), - method = "loess", se = FALSE) + - geom_smooth( - aes_string(x = "time", y = if (ci) "ci_ub" else "pi_ub", group = group_var), - method = "loess", se = FALSE) + - facet_wrap(facet_var, scales = facet_scales) - build_smoothlim <- ggplot_build(graph_smoothlim) - df_smoothlim <- data.frame(PANEL = build_smoothlim$data[[1]]$PANEL, - time = build_smoothlim$data[[1]]$x, - lb = build_smoothlim$data[[1]]$y, - ub = build_smoothlim$data[[2]]$y, - group = build_smoothlim$data[[1]]$group) - panel_id_map <- build_smoothlim$layout$layout[, c("PANEL", facet_var), drop = FALSE] - df_smoothlim <- merge(df_smoothlim, panel_id_map) - lim_mapp <- list( - mapping = aes_string(x = "time", ymin = "lb", ymax = "ub", group = "group"), - data = df_smoothlim) - graph_limits <- do.call("geom_ribbon", c(lim_mapp, lim_args)) - } else graph_limits <- NULL - } else { - geom_mapp <- list(mapping = aes_string(x = "time", y = "yfit", group = group_var), - data = plot_dat) - graph <- ggplot() + theme_bw() + - do.call("geom_smooth", c(geom_mapp, geom_args)) - if (!(limits == "none")) { - graph_smoothlim <- ggplot(plot_dat) + - geom_smooth(aes_string(x = "time", y = if (ci) "ci_lb" else "pi_lb"), - method = "loess", se = FALSE) + - geom_smooth(aes_string(x = "time", y = if (ci) "ci_ub" else "pi_ub"), - method = "loess", se = FALSE) - build_smoothlim <- ggplot_build(graph_smoothlim) - df_smoothlim <- data.frame(time = build_smoothlim$data[[1]]$x, - lb = build_smoothlim$data[[1]]$y, - ub = build_smoothlim$data[[2]]$y, - group = build_smoothlim$data[[1]]$group) - lim_mapp <- list( - mapping = aes_string(x = "time", ymin = "lb", ymax = "ub", group = "group"), - data = df_smoothlim) - graph_limits <- do.call("geom_ribbon", c(lim_mapp, lim_args)) - } else graph_limits <- NULL - } - if (plot_observed) { - if (y_var %in% colnames(obs_dat)) { - obs_dat$y <- obs_dat[[y_var]] - } else { - obs_dat$y <- try(eval(parse(text = y_var), obs_dat)) - if (inherits(obs_dat$y, "try-error")) - stop("Could not find ", y_var, "in observed data, nor able to parse ", - y_var, "as an expression.") - } - obs_dat$id <- factor(obs_dat[[id_var]]) - obs_dat$time <- obs_dat[[time_var]] - if (!is.null(grp_var)) - obs_dat$grp <- obs_dat[[grp_var]] - if (is.null(obs_dat[["y"]])) - stop("Cannot find observed outcome data to add to plot.") - obs_mapp <- list( - mapping = aes_string(x = "time", y = "y", group = group_var), - data = obs_dat) - graph_obs <- do.call("geom_point", c(obs_mapp, obs_args)) - } else graph_obs <- NULL - if (vline) { - if (facet_var == "id") { - facet_list <- unique(plot_dat[, id_var]) - last_time <- attr(x, "last_time")[as.character(facet_list)] # potentially reorder last_time to match plot_dat - } else { - facet_list <- unique(plot_dat[, c(id_var, grp_var)]) - last_time <- attr(x, "last_time")[as.character(facet_list[[id_var]])] # potentially reorder last_time to match plot_dat - facet_list <- facet_list[[grp_var]] - } - vline_dat <- data.frame(FACETVAR = facet_list, last_time = last_time) - colnames(vline_dat) <- c(facet_var, "last_time") - graph_vline <- geom_vline( - mapping = aes_string(xintercept = "last_time"), - data = vline_dat, linetype = 2) - } else graph_vline <- NULL - - ret <- graph + graph_limits + graph_obs + graph_vline + labs(x = xlab, y = ylab) - class_ret <- class(ret) - class(ret) <- c("plot.predict.stanjm", class_ret) - ret + } else NULL + + graph_obs <- + if (plot_observed) { + obs_mapp$data <- obs_dat + do.call("geom_point", c(obs_mapp, obs_args)) + } else NULL + + graph_vline <- + if (vline) { + # potentially reorder last_time to match ordering in fit_dat + if (facet_var == "id") { + facet_list <- unique(fit_dat[, i_var]) + last_time <- attr(x, "last_time")[as.character(facet_list)] + } else { + facet_list <- unique(fit_dat[, c(i_var, g_var)]) + last_time <- attr(x, "last_time")[as.character(facet_list[[i_var]])] + facet_list <- facet_list[[g_var]] + } + vline_dat <- data.frame(FACETVAR = facet_list, last_time = last_time) + vline_dat <- set_colnames(vline_dat, c(facet_var, "last_time")) + geom_vline(mapping = aes_string(xintercept = "last_time"), + data = vline_dat, + linetype = 2) + } else NULL + + graph_labels <- labs(x = xlab, y = ylab) + + gg <- + graph_base + + graph_facet + + graph_limits + + graph_labels + + graph_obs + + graph_vline + class_gg <- class(gg) + class(gg) <- c("plot.predict.stanjm", class_gg) + gg } # internal ---------------------------------------------------------------- +# Get the name of the response variable +# +# @param object A stanjm model. +# @param m Integer specifying which submodel. +get_resp_name <- function(object, m) { + Terms <- terms(formula(object, m = m)) + vars <- rownames(attr(Terms, "factors")) + yvar <- vars[[attr(Terms, "response")]] + yvar +} + +# Return a list with the aes mapping +create_geom_mapp <- function(...) { + list(mapping = ggplot2::aes_string(...)) +} + +# Call set_geom_args on the default and user-specified plotting args +create_geom_args <- function(defaults = list(), more_args = list()) { + do.call("set_geom_args", c(defaults = list(defaults), more_args)) +} + +# Construct a data frame for plotting observed biomarker data +handle_obs_data <- function(data, y_var, i_var, t_var, g_var) { + + # add outcome variable + if (y_var %in% colnames(data)) { + data$yobs <- data[[y_var]] + } else { + data$yobs <- try(eval(parse(text = y_var), data)) + if (inherits(data$yobs, "try-error")) + stop("Could not find ", y_var, "in observed data, nor able to parse ", + y_var, "as an expression.") + } + + # add id variable + data$id <- factor(data[[i_var]]) + + # add time variable + data$time <- data[[t_var]] + + # add grp variable (identifier for lower level clusters) + if (!is.null(g_var)) + data$grp <- data[[g_var]] + + # final validation that outcome data exists in data frame + if (is.null(data[["yobs"]])) + stop("Cannot find observed outcome data to add to plot.") + + data +} + + # Return a list with the control arguments for interpolation and/or # extrapolation in posterior_predict.stanmvreg and posterior_survfit.stanjm # diff --git a/R/pp_data.R b/R/pp_data.R index 3f625a0b2..c93b33589 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -425,17 +425,31 @@ pp_data <- # the fitted object (if newdataEvent is NULL) or in newdataEvent. # @param long_parts,event_parts A logical specifying whether to return the # design matrices for the longitudinal and/or event submodels. +# @param response Logical specifying whether the newdataLong requires the +# response variable. # @return A named list (with components M, Npat, ndL, ndE, yX, tZt, # yZnames, eXq, assoc_parts) -.pp_data_jm <- function(object, newdataLong = NULL, newdataEvent = NULL, - ids = NULL, etimes = NULL, long_parts = TRUE, - event_parts = TRUE) { +.pp_data_jm <- function(object, + newdataLong = NULL, + newdataEvent = NULL, + ids = NULL, + etimes = NULL, + long_parts = TRUE, + event_parts = TRUE, + response = TRUE, + needs_time_var = TRUE) { + M <- get_M(object) + id_var <- object$id_var time_var <- object$time_var if (!is.null(newdataLong) || !is.null(newdataEvent)) - newdatas <- validate_newdatas(object, newdataLong, newdataEvent) + newdatas <- validate_newdatas(object, + newdataLong, + newdataEvent, + response = response, + needs_time_var = needs_time_var) # prediction data for longitudinal submodels ndL <- if (is.null(newdataLong)) @@ -477,7 +491,7 @@ pp_data <- if (long_parts && event_parts) lapply(ndL, function(x) { - if (!time_var %in% colnames(x)) + if (!time_var %in% colnames(x)) STOP_no_var(time_var) if (!id_var %in% colnames(x)) STOP_no_var(id_var) @@ -507,6 +521,8 @@ pp_data <- qtimes <- uapply(qq$points, unstandardise_qpts, 0, etimes) qwts <- uapply(qq$weights, unstandardise_qwts, 0, etimes) starttime <- deparse(formula(object, m = "Event")[[2L]][[2L]]) + if ((!response) && (!starttime %in% colnames(ndE))) + ndE[[starttime]] <- 0 edat <- prepare_data_table(ndE, id_var, time_var = starttime) id_rep <- rep(id_list, qnodes + 1) times <- c(etimes, qtimes) # times used to design event submodel matrices From ce247c860499a02daa1f5f7445f9351fb5fb2789 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 16 Jul 2019 09:59:24 +1000 Subject: [PATCH 173/225] Avoid error when using exponential distribution with prior_PD = TRUE --- R/stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index e7c5538b1..c99ae48c8 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1636,8 +1636,8 @@ get_ok_priors_for_aux <- function(basehaz) { get_default_prior_for_aux <- function(basehaz) { nm <- get_basehaz_name(basehaz) switch(nm, - "exp" = NULL, - "exp-aft" = NULL, + "exp" = list(), # equivalent to NULL + "exp-aft" = list(), # equivalent to NULL "weibull" = normal(), "weibull-aft" = normal(), "gompertz" = normal(), From 2de7f20f85b2cc8d442f82d3cf9fbb7b3fc28256 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 17 Jul 2019 14:14:00 +1000 Subject: [PATCH 174/225] Change default scale for prior_aux with Gompertz models --- R/stan_surv.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index c99ae48c8..c1ee320f6 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -190,7 +190,7 @@ #' scale parameter, while the log shape parameter for the Gompertz #' distribution is incorporated as an intercept in the linear predictor. #' The auxiliary parameter has a lower bound at zero. The default prior is -#' a half-normal distribution with mean 0 and scale 2. +#' a half-normal distribution with mean 0 and scale 0.5. #' } #' Currently, \code{prior_aux} can be a call to \code{dirichlet}, #' \code{normal}, \code{student_t}, \code{cauchy} or \code{exponential}. @@ -1672,8 +1672,11 @@ get_varcov_names <- function(group) { # @param basehaz A list with info about the baseline hazard; see 'handle_basehaz'. # @return A scalar. get_default_aux_scale <- function(basehaz) { - nm <- get_basehaz_name(basehaz) - if (nm %in% c("weibull", "weibull-aft", "gompertz")) 2 else 20 + switch(get_basehaz_name(basehaz), + "weibull" = 2, + "weibull-aft" = 2, + "gompertz" = 0.5, + 20) } # Check if the type of baseline hazard has a closed form From 051c0a012dae9b872926b3ae4fc7b3a8be08ce50 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 24 Jul 2019 14:01:07 +1000 Subject: [PATCH 175/225] Fix up default df for M-splines & allow degree = 0 for tve function --- R/stan_surv.R | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index c1ee320f6..103d34ca1 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1357,8 +1357,8 @@ tve <- function(x, if (!is.null(df) && !is.null(knots)) stop("Cannot specify both 'df' and 'knots' in the 'tve' function.") - if (degree < 1) - stop("In 'tve' function, 'degree' must be positive.") + if (degree < 0) + stop("In 'tve' function, 'degree' must be non-negative.") if (is.null(df) && is.null(knots)) df <- 3L @@ -1474,7 +1474,7 @@ handle_basehaz_surv <- function(basehaz, } else if (basehaz == "ms") { bknots <- c(min_t, max_t) - iknots <- get_iknots(tt, df = df, iknots = knots, degree = degree) + iknots <- get_iknots(tt, df = df, iknots = knots, degree = degree, intercept = TRUE) basis <- get_basis(tt, iknots = iknots, bknots = bknots, degree = degree, type = "ms") nvars <- ncol(basis) # number of aux parameters, basis terms @@ -1537,6 +1537,8 @@ basehaz_for_stan <- function(basehaz_name) { # @param df The degrees of freedom. If specified, then 'df - degree - intercept'. # knots are placed at evenly spaced percentiles of 'x'. If 'iknots' is # specified then 'df' is ignored. +# @param degree Non-negative integer. The degree for the spline basis. +# @param iknots Optional vector of internal knots. # @return A numeric vector of internal knot locations, or NULL if there are # no internal knots. get_iknots <- function(x, df = 5L, degree = 3L, iknots = NULL, intercept = FALSE) { @@ -1925,8 +1927,8 @@ handle_tve <- function(formula, min_t, max_t, times, status) { if (!is.null(df) && !is.null(knots)) stop("Cannot specify both 'df' and 'knots' in the 'tve' function.") - if (degree < 1) - stop("In 'tve' function, 'degree' must be positive.") + if (degree < 0) + stop("In 'tve' function, 'degree' must be non-negative.") if (is.null(df) && is.null(knots)) df <- 3L @@ -1958,7 +1960,7 @@ handle_tve <- function(formula, min_t, max_t, times, status) { return(list( type = type, - call = sub("^list\\(", "splines::bs\\(times__, ", safe_deparse(new_args)))) + call = sub("^list\\(", "splines2::bSpline\\(times__, ", safe_deparse(new_args)))) } else if (type == "pw") { From 5877fceb1cbafe9971fcc9df8659df1e33730eea Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 24 Jul 2019 14:24:14 +1000 Subject: [PATCH 176/225] Fix up renaming of tve coefs --- R/stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 103d34ca1..bcb579247 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1598,8 +1598,8 @@ get_smooth_name <- function(x, type = "smooth_coefs") { return(NULL) nms <- colnames(x) - nms <- gsub(":splines::bs\\(times__.*\\)[0-9]*$", ":tve-bs-coef", nms) - nms <- gsub(":base::cut\\(times__.*\\]$", ":tve-pw-coef", nms) + nms <- gsub(":splines2::bSpline\\(times__.*\\)[0-9]*$", ":tve-bs-coef", nms) + nms <- gsub(":base::cut\\(times__.*\\]$", ":tve-pw-coef", nms) nms_trim <- gsub(":tve-[a-z][a-z]-coef[0-9]*$", "", nms) tally <- table(nms_trim) From b6fa27650aa1cbec520d2a8a8df0d217de32cc7a Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 25 Jul 2019 17:26:31 +1000 Subject: [PATCH 177/225] Add some simulation tests for stan_surv with piecewise constant hazard ratios --- tests/testthat/test_stan_surv.R | 82 +++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 166bad92d..b63fdd1e8 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -923,3 +923,85 @@ if (run_sims) { validate_relbias(sims_ms_i) } + +# run simulations to check piecewise constant time-varying effects +if (run_sims) { + + # number of simulations (for each model specification) + n_sims <- 250 + + # define a function to fit the model to one simulated dataset + sim_run <- function(N = 600, # number of individuals + type = "bs", # model to use for tve + return_relb = FALSE) { + + # simulate data + covs <- data.frame(id = 1:N, + trt = rbinom(N, 1, 0.5)) + + dat <- simsurv(dist = "exponential", + x = covs, + lambdas = c(0.15), + betas = c(trt = -0.4), + tde = c(trt = 0.8), + tdefun = function(t) as.numeric(t > 4), + maxt = 15) + + dat <- merge(covs, dat) + + # define appropriate model formula + if (type == "bs") { + ff <- Surv(eventtime, status) ~ tve(trt, degree = 0, knots = 4) + } else { + ff <- Surv(eventtime, status) ~ tve(trt, type = "pw", knots = 4) + } + + # fit model + mod <- stan_surv(formula = ff, + data = dat, + basehaz = "exp", + chains = 1, + refresh = 0, + iter = 1000) + + # true parameters (hard coded here) + true <- c(intercept = log(0.15), + trt = -0.4, + trt_tve = 0.8) + + # extract parameter estimates + ests <- c(intercept = fixef(mod)[1L], + trt = fixef(mod)[2L], + trt_tve = fixef(mod)[3L]) + + if (return_relb) + return(as.vector((ests - true) / true)) + + list(true = true, + ests = ests, + bias = ests - true, + relb = (ests - true) / true) + } + + # functions to summarise the simulations and check relative bias + summarise_sims <- function(x) { + rbind(true = colMeans(do.call(rbind, x["true",])), + ests = colMeans(do.call(rbind, x["ests",])), + bias = colMeans(do.call(rbind, x["bias",])), + relb = colMeans(do.call(rbind, x["relb",]))) + } + validate_relbias <- function(x, tol = 0.05) { + relb <- as.vector(summarise_sims(x)["relb",]) + expect_equal(relb, rep(0, length(relb)), tol = tol) + } + + # tve models + set.seed(5050) + sims_bs <- replicate(n_sims, sim_run(type = "bs")) + validate_relbias(sims_bs) + + set.seed(6060) + sims_pw <- replicate(n_sims, sim_run(type = "pw")) + validate_relbias(sims_pw) + +} From 6af4f2c5d3dad04b28057e39c4405938f15e6e84 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 28 Jul 2019 19:38:32 +1000 Subject: [PATCH 178/225] Use 200 interpolation points for ps_check --- R/ps_check.R | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/R/ps_check.R b/R/ps_check.R index d4c87f7a1..be8339c46 100644 --- a/R/ps_check.R +++ b/R/ps_check.R @@ -43,6 +43,9 @@ #' @param draws An integer indicating the number of MCMC draws to use to #' to estimate the survival function. The default and maximum number of #' draws is the size of the posterior sample. +#' @param npoints The number of time points at which to predict the survival +#' function. The plot of the survival function is generated by interpolating +#' these points using \code{\link[ggplot2]{geom_line}}. #' @param seed An optional \code{\link[=set.seed]{seed}} to use. #' @param ... Optional arguments passed to #' \code{\link[ggplot2]{geom_line}} and used to control features @@ -73,12 +76,13 @@ #' } #' ps_check <- function(object, - check = "survival", - limits = c("ci", "none"), - draws = NULL, - seed = NULL, - xlab = NULL, - ylab = NULL, + check = "survival", + limits = c("ci", "none"), + draws = NULL, + npoints = 200, + seed = NULL, + xlab = NULL, + ylab = NULL, ci_geom_args = NULL, ...) { @@ -100,7 +104,8 @@ ps_check <- function(object, standardise = TRUE, condition = FALSE, draws = draws, - seed = seed) + seed = seed, + control = list(epoints = npoints)) # Obtain the response variable for the fitted model response <- get_surv(object) From 38cd4ab3325942142339d14f79e05e7ed2d34f19 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 28 Jul 2019 19:40:35 +1000 Subject: [PATCH 179/225] psoterior_traj and posterior_survfit: use 100 points by default for interpolation and extrapolation --- R/posterior_survfit.R | 2 +- R/posterior_traj.R | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 53a332aee..23c72e3a2 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -89,7 +89,7 @@ #' \itemize{ #' \item \code{epoints}: a positive integer specifying the number of #' discrete time points at which to calculate the forecasted survival -#' probabilities. The default is 10. +#' probabilities. The default is 100. #' \item \code{edist}: a positive scalar specifying the amount of time #' across which to forecast the estimated survival function, represented #' in the same units of time as were used for the event times in the fitted diff --git a/R/posterior_traj.R b/R/posterior_traj.R index 6c40bb71a..099a3c75d 100644 --- a/R/posterior_traj.R +++ b/R/posterior_traj.R @@ -73,13 +73,13 @@ #' event or censoring time if no new data is provided; the time specified #' in the "last_time" column if provided in the new data (see \strong{Details} #' section below); or the time of the last longitudinal measurement if new -#' data is provided but no "last_time" column is included. The default is 15.} +#' data is provided but no "last_time" column is included. The default is 100.} #' \item{\code{epoints}}{a positive integer specifying the number of discrete #' time points at which to calculate the estimated longitudinal response for #' \code{extrapolate = TRUE}. These time points are evenly spaced between the #' last known observation time for each individual and the extrapolation #' distance specifed using either \code{edist} or \code{eprop}. -#' The default is 15.} +#' The default is 100.} #' \item{\code{eprop}}{a positive scalar between 0 and 1 specifying the #' amount of time across which to extrapolate the longitudinal trajectory, #' represented as a proportion of the total observed follow up time for each @@ -802,7 +802,7 @@ handle_obs_data <- function(data, y_var, i_var, t_var, g_var) { # @return A named list extrapolation_control <- function(control = list(), ok_args = c("epoints", "edist", "eprop")) { - defaults <- list(ipoints = 15, epoints = 15, edist = NULL, eprop = 0.2, last_time = NULL) + defaults <- list(ipoints = 100, epoints = 100, edist = NULL, eprop = 0.2, last_time = NULL) if (!is.list(control)) { stop("'control' should be a named list.") } else if (!length(control)) { From fe4c3108d950bcfa92b1fda3b35c4f1fc48ba01d Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 9 Aug 2019 10:37:12 +1000 Subject: [PATCH 180/225] ps_check and posterior_survfit: reduce default number of draws to 400 --- R/posterior_survfit.R | 13 +++++++------ R/ps_check.R | 28 ++++++++++++++++------------ 2 files changed, 23 insertions(+), 18 deletions(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 23c72e3a2..bf458cb1e 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -187,11 +187,12 @@ #' Student-t proposal distribution in the Metropolis-Hastings algorithm. #' @param draws An integer specifying the number of MCMC draws to use when #' evaluating the predicted quantities. For \code{stan_surv} models, the -#' default number of draws is the size of the posterior sample. -#' For \code{stan_jm} models, the default number of draws is 200 (or the -#' size of the posterior sample if that is less than 200). The smaller -#' default number of draws for \code{stan_jm} models is because dynamic -#' predictions (when \code{dynamic = TRUE}) can be slow. +#' default number of draws is 400 (or the size of the posterior sample if +#' that is less than 400). For \code{stan_jm} models, the default number +#' of draws is 200 (or the size of the posterior sample if that is less +#' than 200). The smaller default number of draws for \code{stan_jm} +#' models is because dynamic predictions (when \code{dynamic = TRUE}) +#' can be slow. #' @param seed An optional \code{\link[=set.seed]{seed}} to use. #' @param return_matrix A logical. If \code{TRUE} then a list of \code{draws} by #' \code{nrow(newdata)} matrices is returned. Each matrix contains the actual @@ -487,7 +488,7 @@ posterior_survfit.stansurv <- function(object, } # Get stanmat parameter matrix for specified number of draws - stanmat <- sample_stanmat(object, draws = draws, default_draws = NA) + stanmat <- sample_stanmat(object, draws = draws, default_draws = 400) pars <- extract_pars(object, stanmat) # Calculate survival probability at each increment of extrapolation sequence diff --git a/R/ps_check.R b/R/ps_check.R index be8339c46..8af45cf33 100644 --- a/R/ps_check.R +++ b/R/ps_check.R @@ -19,9 +19,10 @@ #' Graphical checks of the estimated survival function #' -#' This function plots the estimated marginal survival function based on draws -#' from the posterior predictive distribution of the fitted model, -#' and then overlays a Kaplan-Meier curve based on the observed data. +#' This function plots the estimated standardised survival curve for the +#' estimation sample based on draws from the posterior distribution of the +#' fitted model, and then overlays a Kaplan-Meier survival curve based +#' on the observed data. #' #' @importFrom ggplot2 ggplot aes_string geom_step #' @export @@ -33,19 +34,22 @@ #' @template args-ci-geom-args #' #' @param check The type of plot to show. Currently only "survival" is -#' allowed, which compares the estimated marginal survival function -#' under the fitted model to the estimated Kaplan-Meier curve based -#' on the observed data. +#' allowed, which compares the estimated standardised survival curve +#' based on the fitted model to the estimated Kaplan-Meier survival +#' curve based on the observed data. #' @param limits A quoted character string specifying the type of limits to #' include in the plot. Can be one of: \code{"ci"} for the Bayesian #' posterior uncertainty interval (often known as a credible interval); #' or \code{"none"} for no interval limits. -#' @param draws An integer indicating the number of MCMC draws to use to -#' to estimate the survival function. The default and maximum number of -#' draws is the size of the posterior sample. +#' @param draws Passed to the \code{draws} argument of +#' \code{\link{posterior_survfit}}. It must be an integer indicating the +#' number of MCMC draws to use to when evaluating the posterior estimate +#' of the standardised survival curve. The default is 400 for +#' \code{stan_surv} models or 200 for \code{stan_jm} models (or +#' equal to the posterior sample size if it is smaller than that). #' @param npoints The number of time points at which to predict the survival -#' function. The plot of the survival function is generated by interpolating -#' these points using \code{\link[ggplot2]{geom_line}}. +#' function. The plot of the survival curve is generated by interpolating +#' along these points using \code{\link[ggplot2]{geom_line}}. #' @param seed An optional \code{\link[=set.seed]{seed}} to use. #' @param ... Optional arguments passed to #' \code{\link[ggplot2]{geom_line}} and used to control features @@ -79,7 +83,7 @@ ps_check <- function(object, check = "survival", limits = c("ci", "none"), draws = NULL, - npoints = 200, + npoints = 101, seed = NULL, xlab = NULL, ylab = NULL, From 2325d3a9371c108d0c7d9905e5edaa2bfc6ae8b0 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 19 Aug 2019 15:46:45 +1000 Subject: [PATCH 181/225] Use hexNumeric for deparsing bSpline call --- R/stan_surv.R | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index bcb579247..6194827f9 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1951,31 +1951,23 @@ handle_tve <- function(formula, min_t, max_t, times, status) { if (type == "bs") { - bknots <- c(min_t, max_t) iknots <- get_iknots(tt, df = df, iknots = knots) - + + bknots <- c(min_t, max_t) + new_args <- list(knots = iknots, Boundary.knots = bknots, degree = degree) return(list( type = type, - call = sub("^list\\(", "splines2::bSpline\\(times__, ", safe_deparse(new_args)))) - - } else if (type == "pw") { - - iknots <- get_iknots(tt, df = df, degree = 0, iknots = knots) - - new_args <- list(breaks = c(min_t, iknots, max_t), - include.lowest = TRUE) - - return(list( - type = type, - call = sub("^list\\(", "base::cut\\(times__, ", safe_deparse(new_args)))) + call = sub("^list\\(", "splines2::bSpline\\(times__, ", + deparse(new_args, 500L, control = c("all", "hexNumeric"))))) + # NB use of hexNumeric to ensure numeric accuracy is maintained } - } + } tt_parsed <- eval(parse(text = all_vars[sel[i]])) tt_terms <- which(attr(Terms, "factors")[i, ] > 0) From 8628335f615b9b93171d5bdb80e6eb9513e2f9a9 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 19 Aug 2019 16:45:30 +1000 Subject: [PATCH 182/225] Remove type="pw" option for tve function --- R/plots.R | 21 ++--- R/stan_surv.R | 148 +++++++++++++++----------------- tests/testthat/test_stan_surv.R | 50 ++++------- 3 files changed, 99 insertions(+), 120 deletions(-) diff --git a/R/plots.R b/R/plots.R index 3686dec35..0ecf94c68 100644 --- a/R/plots.R +++ b/R/plots.R @@ -258,20 +258,21 @@ plot.stansurv <- function(x, plotfun = "basehaz", pars = NULL, betas_td <- stanpars$beta_tve[, sel2, drop = FALSE] betas <- cbind(betas_tf, betas_td) - tt_varid <- unique(x$formula$tt_map[smooth_map == sel1]) - tt_type <- x$formula$tt_types[[tt_varid]] - tt_form <- x$formula$tt_forms[[tt_varid]] - tt_data <- data.frame(times__ = times) - tt_x <- model.matrix(tt_form, tt_data) + tt_varid <- unique(x$formula$tt_map[smooth_map == sel1]) + tt_type <- x$formula$tt_types [[tt_varid]] + tt_degree <- x$formula$tt_degrees[[tt_varid]] + tt_form <- x$formula$tt_forms [[tt_varid]] + tt_data <- data.frame(times__ = times) + tt_x <- model.matrix(tt_form, tt_data) - coef <- linear_predictor(betas, tt_x) + coef <- linear_predictor(betas, tt_x) - is_aft <- get_basehaz_name(x$basehaz) %in% c("exp-aft", "weibull-aft") + is_aft <- get_basehaz_name(x$basehaz) %in% c("exp-aft", "weibull-aft") - plotdat <- median_and_bounds(exp(coef), prob, na.rm = TRUE) - plotdat <- data.frame(times, plotdat) + plotdat <- median_and_bounds(exp(coef), prob, na.rm = TRUE) + plotdat <- data.frame(times, plotdat) - uses_step_stair <- (tt_type %in% c("pw", "piecewise")) + uses_step_stair <- (tt_degree == 0) xlab <- "Time" ylab <- ifelse(is_aft, diff --git a/R/stan_surv.R b/R/stan_surv.R index 6194827f9..c6fa04bf2 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -309,22 +309,19 @@ #' \code{formula}, e.g. \code{Surv(time, status) ~ tve(sex) + age + trt}. #' The coefficient for \code{sex} will then be modelled using a flexible #' smooth function based on a cubic B-spline expansion of time. -#' Alternatively we can use a piecewise constant function to model the -#' time-varying coefficient by specifying \code{tve(sex, type = "pw")}. #' #' Additional arguments used to control the modelling of the time-varying -#' effect are explained in the \code{\link{tve}} documentation. -#' In particular, the flexibility of the function can primarily be -#' controlled by increasing or decreasing the degrees of freedom -#' (i.e. the number of B-spline basis terms or the number of -#' time intervals in the piecewise constant function). For example, to -#' use cubic B-splines with 7 degrees of freedom we could specify -#' \code{tve(sex, df = 7)} in the model formula instead of just -#' \code{tve(sex)}. +#' effect are explained in the \code{\link{tve}} documentation. +#' Of particular note is the fact that a piecewise constant basis is +#' allowed as a special case of the B-splines. For example, specifying +#' \code{tve(sex, degree = 0)} in the model formula instead of just +#' \code{tve(sex)} would request a piecewise constant time-varying effect. +#' The user can also control the degrees of freedom or knot locations for +#' the B-spline (or piecewise constant) function. #' -#' It is worth noting however that an additional way to control the +#' It is worth noting that an additional way to control the #' flexibility of the function used to model the time-varying effect -#' is through the priors. A random walk prior is used for the piecewise +#' is through priors. A random walk prior is used for the piecewise #' constant or B-spline coefficients, and the hyperparameter (standard #' deviation) of the random walk prior can be controlled via the #' \code{prior_smooth} argument. This is a more indirect way to @@ -334,11 +331,9 @@ #' more explicit details on the formulation of the time-varying effects #' and the prior distributions used for their coefficients. #' -#' In practice, the default \code{tve()} function should provide sufficient -#' flexibility for modelling most time-varying effects. However, it is worth -#' noting that reliable estimation of a time-varying effect usually -#' requires a relatively large number of events in the data (e.g. say >1000, -#' depending on the setting). +#' It is worth noting that reliable estimation of a time-varying effect +#' usually requires a relatively large number of events in the data (e.g. +#' say >1000 depending on the setting). #' } #' #' @examples @@ -408,7 +403,7 @@ #' maxt = 5) #' d4 <- merge(d4, covs) #' m4 <- stan_surv(Surv(eventtime, status) ~ -#' tve(trt, type = "pw", knots = c(2.5)), +#' tve(trt, degree = 0, knots = c(2.5)), #' data = d4, chains = 1, refresh = 0, iter = 600) #' print(m4, 4) #' plot(m4, "tve") # time-varying hazard ratio @@ -1270,10 +1265,12 @@ stan_surv <- function(formula, #' This is a special function that can be used in the formula of a Bayesian #' survival model estimated using \code{\link{stan_surv}}. It specifies that a #' time-varying coefficient should be estimated for the covariate \code{x}. -#' The \code{tve} function only has meaning when evaluated within the formula -#' of a \code{\link{stan_surv}} call and does not have meaning outside of that +#' The time-varying coefficient is currently modelled using B-splines (with +#' piecewise constant included as a special case). Note that the \code{tve} +#' function only has meaning when evaluated within the formula of a +#' \code{\link{stan_surv}} call and does not have meaning outside of that #' context. The exported function documented here just returns \code{x}. -#' However, when called internally the \code{tve} function returns several +#' However when called internally the \code{tve} function returns several #' other pieces of useful information used in the model fitting. #' #' @export @@ -1281,36 +1278,28 @@ stan_surv <- function(formula, #' @param x The covariate for which a time-varying coefficient should be #' estimated. #' @param type The type of function used to model the time-varying coefficient. -#' Can currently be one of the following: -#' \itemize{ -#' \item \code{"bs"}: A B-spline function (the default). Note that cubic -#' B-splines are used by default, but this can be changed by the user via the -#' \code{degree} argument described below. -#' \item \code{"pw"}: A piecewise constant function with the number of -#' "pieces" or "time intervals" determined by either the \code{df} or -#' \code{knots} arguments described below. -#' } +#' Currently only \code{type = "bs"} is allowed. This corresponds to a +#' B-spline function. Note that \emph{cubic} B-splines are used by default +#' but this can be changed by the user via the \code{degree} argument +#' described below. Of particular note is that \code{degree = 0} is +#' is treated as a special case corresponding to a piecewise constant basis. #' @param df A positive integer specifying the degrees of freedom -#' for the piecewise constant or B-spline function. -#' When \code{type = "bs"} two boundary knots and \code{df - degree} +#' for the B-spline function. Two boundary knots and \code{df - degree} #' internal knots are used to generate the B-spline function. -#' When \code{type = "pw"} two boundary knots and \code{df} -#' internal knots are used to generate the piecewise constant function. #' The internal knots are placed at equally spaced percentiles of the -#' distribution of the uncensored event times. -#' The default is to use \code{df = 3} unless \code{df} or \code{knots} is -#' explicitly specified by the user. +#' distribution of the uncensored event times. The default is to use +#' \code{df = 3} unless \code{df} or \code{knots} is explicitly +#' specified by the user. #' @param knots A numeric vector explicitly specifying internal knot -#' locations for the piecewise constant or B-spline function. Note that -#' \code{knots} cannot be specified if \code{df} is specified. Also note -#' that this argument only controls the \emph{internal} knot locations. -#' In addition, boundary knots are placed at the earliest entry time and -#' latest event or censoring time and these cannot be changed by the user. +#' locations for the B-spline function. Note that \code{knots} cannot be +#' specified if \code{df} is specified. Also note that this argument only +#' controls the \emph{internal} knot locations. In addition, boundary +#' knots are placed at the earliest entry time and latest event or +#' censoring time and these cannot be changed by the user. #' @param degree A positive integer specifying the degree for the B-spline #' function. The order of the B-spline is equal to \code{degree + 1}. -#' This argument is only relevant for B-splines (i.e. when -#' \code{type = "bs"}) and not for the piecewise constant function (when -#' \code{type = "pw"}). +#' Note that \code{degree = 0} is allowed and is treated as a special +#' case corresponding to a piecewise constant basis. #' #' @return The exported \code{tve} function documented here just returns #' \code{x}. However, when called internally the \code{tve} function returns @@ -1322,17 +1311,18 @@ stan_surv <- function(formula, #' \itemize{ #' \item \code{tt_vars}: A list with the names of variables in the model #' formula that were wrapped in the \code{tve} function. -#' \item \code{tt_types}: A list with the \code{type} (e.g. \code{"bs"}, -#' \code{"pw"}) of \code{tve} function corresponding to each variable in -#' \code{tt_vars}. +#' \item \code{tt_types}: A list with the \code{type} (e.g. \code{"bs"}) +#' of \code{tve} function corresponding to each variable in \code{tt_vars}. +#' \item \code{tt_degrees}: A list with the \code{degree} for the +#' B-spline function corresponding to each variable in \code{tt_vars}. #' \item \code{tt_calls}: A list with the call required to construct the #' transformation of time for each variable in \code{tt_vars}. #' \item \code{tt_forms}: Same as \code{tt_calls} but expressed as formulas. #' \item \code{tt_frame}: A single formula that can be used to generate a -#' model frame that contains the unique set of transformations of time (e.g. -#' basis terms or dummy indicators) that are required to build all -#' time-varying coefficients in the model. In other words a single formula -#' with the unique element(s) contained in \code{tt_forms}. +#' model frame that contains the unique set of transformations of time +#' (i.e. the basis terms) that are required to build all time-varying +#' coefficients in the model. In other words a single formula with the +#' unique element(s) contained in \code{tt_forms}. #' } #' #' @examples @@ -1341,13 +1331,13 @@ stan_surv <- function(formula, #' #' # Internally the function returns and stores information #' # used to form the time-varying coefficients in the model -#' m1 <- stan_surv(Surv(futimeYears, death) ~ tve(trt) + tve(sex, "pw"), +#' m1 <- stan_surv(Surv(futimeYears, death) ~ tve(trt) + tve(sex, degree = 0), #' data = pbcSurv, chains = 1, iter = 50) #' m1$formula[["tt_vars"]] #' m1$formula[["tt_forms"]] #' tve <- function(x, - type = c("bs", "pw"), + type = "bs", df = NULL, knots = NULL, degree = 3L) { @@ -1599,8 +1589,7 @@ get_smooth_name <- function(x, type = "smooth_coefs") { nms <- colnames(x) nms <- gsub(":splines2::bSpline\\(times__.*\\)[0-9]*$", ":tve-bs-coef", nms) - nms <- gsub(":base::cut\\(times__.*\\]$", ":tve-pw-coef", nms) - + nms_trim <- gsub(":tve-[a-z][a-z]-coef[0-9]*$", "", nms) tally <- table(nms_trim) indices <- uapply(tally, seq_len) @@ -1811,13 +1800,14 @@ parse_formula_and_data <- function(formula, data) { max_t = max_t, times = t_end, status = status) - tf_form <- tve_stuff$tf_form - td_form <- tve_stuff$td_form # may be NULL - tt_vars <- tve_stuff$tt_vars # may be NULL - tt_frame <- tve_stuff$tt_frame # may be NULL - tt_types <- tve_stuff$tt_types # may be NULL - tt_calls <- tve_stuff$tt_calls # may be NULL - tt_forms <- tve_stuff$tt_forms # may be NULL + tf_form <- tve_stuff$tf_form + td_form <- tve_stuff$td_form # may be NULL + tt_vars <- tve_stuff$tt_vars # may be NULL + tt_frame <- tve_stuff$tt_frame # may be NULL + tt_types <- tve_stuff$tt_types # may be NULL + tt_degrees <- tve_stuff$tt_degrees # may be NULL + tt_calls <- tve_stuff$tt_calls # may be NULL + tt_forms <- tve_stuff$tt_forms # may be NULL # just fixed-effect part of formula fe_form <- lme4::nobars(tf_form) @@ -1842,6 +1832,7 @@ parse_formula_and_data <- function(formula, data) { tt_vars, tt_frame, tt_types, + tt_degrees, tt_calls, tt_forms, fe_form, @@ -1906,9 +1897,10 @@ handle_tve <- function(formula, min_t, max_t, times, status) { # extract 'tve(x, ...)' from formula and return '~ x' and '~ bs(times, ...)' idx <- 1 - tt_vars <- list() - tt_types <- list() - tt_calls <- list() + tt_vars <- list() + tt_types <- list() + tt_degrees <- list() + tt_calls <- list() for (i in seq_along(sel)) { @@ -1916,11 +1908,10 @@ handle_tve <- function(formula, min_t, max_t, times, status) { # # @param x The variable the time-varying effect is going to be applied to. # @param type Character string, the type of time-varying effect to use. Can - # currently be one of: bs, ms, pw. - # @param ... Additional arguments passed by the user that control aspects of - # the time-varying effect. + # currently only be "bs". + # @param df,knots,degree Additional arguments passed to splines2::bSpline. # @return The call used to construct a time-varying basis. - tve <- function(x, type = c("bs", "pw"), df = NULL, knots = NULL, degree = 3L) { + tve <- function(x, type = "bs", df = NULL, knots = NULL, degree = 3L) { type <- match.arg(type) @@ -1960,10 +1951,11 @@ handle_tve <- function(formula, min_t, max_t, times, status) { degree = degree) return(list( - type = type, - call = sub("^list\\(", "splines2::bSpline\\(times__, ", - deparse(new_args, 500L, control = c("all", "hexNumeric"))))) - # NB use of hexNumeric to ensure numeric accuracy is maintained + type = type, + degree = degree, + call = sub("^list\\(", "splines2::bSpline\\(times__, ", + deparse(new_args, 500L, control = c("all", "hexNumeric"))))) + # NB use of hexNumeric to ensure numeric accuracy is maintained } @@ -1972,9 +1964,10 @@ handle_tve <- function(formula, min_t, max_t, times, status) { tt_parsed <- eval(parse(text = all_vars[sel[i]])) tt_terms <- which(attr(Terms, "factors")[i, ] > 0) for (j in tt_terms) { - tt_vars [[idx]] <- tf_terms[j] - tt_types[[idx]] <- tt_parsed$type - tt_calls[[idx]] <- tt_parsed$call + tt_vars [[idx]] <- tf_terms[j] + tt_types [[idx]] <- tt_parsed$type + tt_degrees[[idx]] <- tt_parsed$degree + tt_calls [[idx]] <- tt_parsed$call idx <- idx + 1 } } @@ -2005,6 +1998,7 @@ handle_tve <- function(formula, min_t, max_t, times, status) { tt_vars, tt_frame, tt_types, + tt_degrees, tt_calls, tt_forms) } diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index b63fdd1e8..7d404e235 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -162,20 +162,14 @@ test_that("prior arguments work", { test_that("tve function works", { es(up(testmod, formula. = s ~ tve(x1) + x2)) es(up(testmod, formula. = s ~ tve(x1) + tve(x2))) - es(up(testmod, formula. = s ~ tve(x1, type = "bs") + tve(x2, type = "pw"))) + es(up(testmod, formula. = s ~ tve(x1, knots = 1) + tve(x2, knots = 2))) }) test_that("tve function works: b-spline optional arguments", { - es(up(testmod, formula. = s ~ tve(x1, type = "bs", knots = c(1,2)) + x2)) - es(up(testmod, formula. = s ~ tve(x1, type = "bs", df = 4) + x2)) - es(up(testmod, formula. = s ~ tve(x1, type = "bs", degree = 2) + x2)) - ee(up(testmod, formula. = s ~ tve(x1, type = "bs", junk = 2) + x2), "unused") -}) - -test_that("tve function works: piecewise optional arguments", { - es(up(testmod, formula. = s ~ tve(x1, type = "pw", knots = c(1,2)) + x2)) - es(up(testmod, formula. = s ~ tve(x1, type = "pw", df = 4) + x2)) - ee(up(testmod, formula. = s ~ tve(x1, type = "pw", junk = 2) + x2), "unused") + es(up(testmod, formula. = s ~ tve(x1, knots = c(1,2)) + x2)) + es(up(testmod, formula. = s ~ tve(x1, df = 4) + x2)) + es(up(testmod, formula. = s ~ tve(x1, degree = 0) + x2)) + ee(up(testmod, formula. = s ~ tve(x1, junk = 2) + x2), "unused") }) @@ -214,13 +208,13 @@ o<-SW(f12 <- up(f5, Surv(futimeYears, death) ~ sex + tve(trt))) o<-SW(f13 <- up(f6, Surv(futimeYears, death) ~ sex + tve(trt))) o<-SW(f14 <- up(f7, Surv(futimeYears, death) ~ sex + tve(trt))) -o<-SW(f15 <- up(f1, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f16 <- up(f2, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f17 <- up(f3, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f18 <- up(f4, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f19 <- up(f5, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f20 <- up(f6, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) -o<-SW(f21 <- up(f7, Surv(futimeYears, death) ~ sex + tve(trt, type = "pw"))) +o<-SW(f15 <- up(f1, Surv(futimeYears, death) ~ sex + tve(trt, degree = 0))) +o<-SW(f16 <- up(f2, Surv(futimeYears, death) ~ sex + tve(trt, degree = 0))) +o<-SW(f17 <- up(f3, Surv(futimeYears, death) ~ sex + tve(trt, degree = 0))) +o<-SW(f18 <- up(f4, Surv(futimeYears, death) ~ sex + tve(trt, degree = 0))) +o<-SW(f19 <- up(f5, Surv(futimeYears, death) ~ sex + tve(trt, degree = 0))) +o<-SW(f20 <- up(f6, Surv(futimeYears, death) ~ sex + tve(trt, degree = 0))) +o<-SW(f21 <- up(f7, Surv(futimeYears, death) ~ sex + tve(trt, degree = 0))) # start-stop notation (incl. delayed entry) o<-SW(f22 <- up(f1, Surv(t0, futimeYears, death) ~ sex + trt)) @@ -527,7 +521,7 @@ compare_surv(data = dat, basehaz = "weibull-aft") #-------- Check parameter estimates: stan (tve) vs coxph (tt) --------------- -# NB: this only checks piecewise constant hazard ratio (not B-spline) +# NB: this only checks piecewise constant hazard ratio set.seed(SEED) @@ -551,7 +545,7 @@ o<-SW(surv1 <- coxph( tt = function(x, t, ...) { x * as.numeric(t > 10) })) o<-SW(stan1 <- stan_surv( - formula = Surv(eventtime, status) ~ tve(X1, type = "pw", knots = c(10)) + X2, + formula = Surv(eventtime, status) ~ tve(X1, degree = 0, knots = c(10)) + X2, data = merge(dat, covs), basehaz = "exp", chains = CHAINS, @@ -931,9 +925,7 @@ if (run_sims) { n_sims <- 250 # define a function to fit the model to one simulated dataset - sim_run <- function(N = 600, # number of individuals - type = "bs", # model to use for tve - return_relb = FALSE) { + sim_run <- function(N = 600, return_relb = FALSE) { # simulate data covs <- data.frame(id = 1:N, @@ -950,11 +942,7 @@ if (run_sims) { dat <- merge(covs, dat) # define appropriate model formula - if (type == "bs") { - ff <- Surv(eventtime, status) ~ tve(trt, degree = 0, knots = 4) - } else { - ff <- Surv(eventtime, status) ~ tve(trt, type = "pw", knots = 4) - } + ff <- Surv(eventtime, status) ~ tve(trt, degree = 0, knots = 4) # fit model mod <- stan_surv(formula = ff, @@ -997,11 +985,7 @@ if (run_sims) { # tve models set.seed(5050) - sims_bs <- replicate(n_sims, sim_run(type = "bs")) - validate_relbias(sims_bs) - - set.seed(6060) - sims_pw <- replicate(n_sims, sim_run(type = "pw")) + sims_pw <- replicate(n_sims, sim_run()) validate_relbias(sims_pw) } From 3f4ef645803c1133adab6574770adbdb819cde70 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 25 Sep 2019 10:12:39 +1000 Subject: [PATCH 183/225] stan_surv.R: allow any number of grouping factors --- R/stan_surv.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index c6fa04bf2..817859eb5 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1816,8 +1816,6 @@ parse_formula_and_data <- function(formula, data) { bars <- lme4::findbars(tf_form) re_parts <- lapply(bars, split_at_bars) re_forms <- fetch(re_parts, "re_form") - if (length(bars) > 2L) - stop2("A maximum of 2 grouping factors are allowed.") nlist(formula, data, From cd73314afec2b6d0ef7c6311914165c638fbd7b0 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 26 Sep 2019 18:13:22 +1000 Subject: [PATCH 184/225] surv.stan: change dimension of redundant simplex --- src/stan_files/surv.stan | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 7d3daf285..58dd3da82 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -692,7 +692,7 @@ parameters { // M-spline model: nvars = number of basis terms, ie. spline coefs // B-spline model: nvars = number of basis terms, ie. spline coefs vector[type == 4 ? 0 : nvars] z_coefs; - simplex[nvars] ms_coefs[type == 4]; // constrained coefs for M-splines + simplex[type == 4 ? nvars : 1] ms_coefs; // constrained coefs for M-splines // unscaled tve spline coefficients vector[S] z_beta_tve; @@ -916,12 +916,12 @@ model { if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); } else if (type == 4) { // M-splines, on haz scale - if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, ms_coefs[1]); - if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, ms_coefs[1]); - if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, ms_coefs[1]); - if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, ms_coefs[1]); - if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, ms_coefs[1]); - if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, ms_coefs[1]); + if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, ms_coefs); + if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, ms_coefs); + if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, ms_coefs); + if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, ms_coefs); + if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, ms_coefs); + if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, ms_coefs); } else { reject("Bug found: invalid baseline hazard (without quadrature)."); @@ -1108,13 +1108,13 @@ model { if (qdelay > 0) lhaz_qpts_delay = gompertz_log_haz(eta_qpts_delay, qpts_delay, scale); } else if (type == 4) { // M-splines, on haz scale - if (Nevent > 0) lhaz_epts_event = mspline_log_haz(eta_epts_event, basis_epts_event, ms_coefs[1]); - if (qevent > 0) lhaz_qpts_event = mspline_log_haz(eta_qpts_event, basis_qpts_event, ms_coefs[1]); - if (qlcens > 0) lhaz_qpts_lcens = mspline_log_haz(eta_qpts_lcens, basis_qpts_lcens, ms_coefs[1]); - if (qrcens > 0) lhaz_qpts_rcens = mspline_log_haz(eta_qpts_rcens, basis_qpts_rcens, ms_coefs[1]); - if (qicens > 0) lhaz_qpts_icenl = mspline_log_haz(eta_qpts_icenl, basis_qpts_icenl, ms_coefs[1]); - if (qicens > 0) lhaz_qpts_icenu = mspline_log_haz(eta_qpts_icenu, basis_qpts_icenu, ms_coefs[1]); - if (qdelay > 0) lhaz_qpts_delay = mspline_log_haz(eta_qpts_delay, basis_qpts_delay, ms_coefs[1]); + if (Nevent > 0) lhaz_epts_event = mspline_log_haz(eta_epts_event, basis_epts_event, ms_coefs); + if (qevent > 0) lhaz_qpts_event = mspline_log_haz(eta_qpts_event, basis_qpts_event, ms_coefs); + if (qlcens > 0) lhaz_qpts_lcens = mspline_log_haz(eta_qpts_lcens, basis_qpts_lcens, ms_coefs); + if (qrcens > 0) lhaz_qpts_rcens = mspline_log_haz(eta_qpts_rcens, basis_qpts_rcens, ms_coefs); + if (qicens > 0) lhaz_qpts_icenl = mspline_log_haz(eta_qpts_icenl, basis_qpts_icenl, ms_coefs); + if (qicens > 0) lhaz_qpts_icenu = mspline_log_haz(eta_qpts_icenu, basis_qpts_icenu, ms_coefs); + if (qdelay > 0) lhaz_qpts_delay = mspline_log_haz(eta_qpts_delay, basis_qpts_delay, ms_coefs); } else if (type == 2) { // B-splines, on log haz scale if (Nevent > 0) lhaz_epts_event = bspline_log_haz(eta_epts_event, basis_epts_event, coefs); @@ -1162,7 +1162,7 @@ model { // log priors for baseline hazard parameters if (type == 4) { - real dummy = basehaz_lp(ms_coefs[1], prior_dist_for_aux, prior_conc_for_aux); + real dummy = basehaz_lp(ms_coefs, prior_dist_for_aux, prior_conc_for_aux); } else if (nvars > 0) { real dummy = basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); @@ -1184,7 +1184,7 @@ model { generated quantities { // baseline hazard parameters to return - vector[nvars] aux = (type == 4) ? ms_coefs[1] : coefs; + vector[nvars] aux = (type == 4) ? ms_coefs : coefs; // transformed intercept real alpha; From 6bee0169cce716d3e673bc7fcae01a3cd0a90f80 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 1 Oct 2019 16:45:05 +1000 Subject: [PATCH 185/225] stan_surv.R: fix up get_iknots function --- R/stan_surv.R | 4 ++-- tests/testthat/test_stan_surv.R | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 817859eb5..9d146e040 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1472,7 +1472,7 @@ handle_basehaz_surv <- function(basehaz, degree <- NULL # degree for splines bknots <- c(min_t, max_t) - iknots <- get_iknots(tt, df = df, iknots = knots) + iknots <- get_iknots(tt, df = df, iknots = knots, degree = 0) basis <- NULL # spline basis nvars <- length(iknots) + 1 # number of aux parameters, dummy indicators @@ -1940,7 +1940,7 @@ handle_tve <- function(formula, min_t, max_t, times, status) { if (type == "bs") { - iknots <- get_iknots(tt, df = df, iknots = knots) + iknots <- get_iknots(tt, df = df, iknots = knots, degree = degree) bknots <- c(min_t, max_t) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 7d404e235..c99c54005 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -549,7 +549,6 @@ o<-SW(stan1 <- stan_surv( data = merge(dat, covs), basehaz = "exp", chains = CHAINS, - cores = CORES, refresh = REFRESH, iter = ITER)) From c2b39c157049529173ea7cfc58f5b5f2ec94f855 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 2 Oct 2019 10:20:11 +1000 Subject: [PATCH 186/225] test_stan_surv.R: only use simulations that converged (based on Rhat) --- tests/testthat/test_stan_surv.R | 104 ++++++++++++++++++++++++-------- 1 file changed, 80 insertions(+), 24 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index c99c54005..a8a93a57e 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -782,7 +782,7 @@ o<-SW(m12 <- up(m1, formula. = ffi, data = dat_icens, basehaz = "ms")) # check the estimates against the true parameters for (j in c(1:12)) { - modfrail <- get(paste0("f", j)) + modfrail <- get(paste0("m", j)) for (i in 1:3) expect_equal(get_ests(modfrail)[[i]], true[[i]], tol = tols[[i]]) } @@ -826,7 +826,7 @@ if (run_sims) { chains = 1, refresh = 0, iter = 2000) - + # true parameters (hard coded here) true <- c(intercept = log(0.1), trt = 0.3, @@ -843,6 +843,16 @@ if (run_sims) { ests <- ests[2:3] } + + # check Rhat + rhats <- summary(mod)[, "Rhat"] + rhats <- rhats[!names(rhats) %in% c("lp__", "log-posterior")] + + converged <- (all(rhats <= 1.1, na.rm = TRUE)) + + if (!converged) + ests <- rep(NA, length(ests)) # set estimates to NA if model didn't converge + if (return_relb) return(as.vector((ests - true) / true)) @@ -854,69 +864,99 @@ if (run_sims) { # functions to summarise the simulations and check relative bias summarise_sims <- function(x) { - rbind(true = colMeans(do.call(rbind, x["true",])), - ests = colMeans(do.call(rbind, x["ests",])), - bias = colMeans(do.call(rbind, x["bias",])), - relb = colMeans(do.call(rbind, x["relb",]))) + message("Number of simulations that converged: ", + sum(!is.na(do.call(rbind, x["ests",])[,1]))) + rbind(true = colMeans(do.call(rbind, x["true",]), na.rm = TRUE), + ests = colMeans(do.call(rbind, x["ests",]), na.rm = TRUE), + bias = colMeans(do.call(rbind, x["bias",]), na.rm = TRUE), + relb = colMeans(do.call(rbind, x["relb",]), na.rm = TRUE)) } + validate_relbias <- function(x, tol = 0.05) { + message("Number of simulations that converged: ", + sum(!is.na(do.call(rbind, x["ests",])[,1]))) relb <- as.vector(summarise_sims(x)["relb",]) expect_equal(relb, rep(0, length(relb)), tol = tol) } - # right censored models +} + +# right censored models +if (run_sims) { set.seed(5050) sims_exp <- replicate(n_sims, sim_run(basehaz = "exp")) validate_relbias(sims_exp) - +} + +if (run_sims) { set.seed(6060) sims_weibull <- replicate(n_sims, sim_run(basehaz = "weibull")) validate_relbias(sims_weibull) - +} + +if (run_sims) { set.seed(7070) sims_gompertz <- replicate(n_sims, sim_run(basehaz = "gompertz")) validate_relbias(sims_gompertz) - +} + +if (run_sims) { set.seed(8080) sims_ms <- replicate(n_sims, sim_run(basehaz = "ms")) validate_relbias(sims_ms) - - # delayed entry models +} + +# delayed entry models +if (run_sims) { set.seed(5050) sims_exp_d <- replicate(n_sims, sim_run(basehaz = "exp", delay = TRUE)) validate_relbias(sims_exp_d) - +} + +if (run_sims) { set.seed(6060) sims_weibull_d <- replicate(n_sims, sim_run(basehaz = "weibull", delay = TRUE)) validate_relbias(sims_weibull_d) - +} + +if (run_sims) { set.seed(7070) sims_gompertz_d <- replicate(n_sims, sim_run(basehaz = "gompertz", delay = TRUE)) validate_relbias(sims_gompertz_d) - +} + +if (run_sims) { set.seed(8080) sims_ms_d <- replicate(n_sims, sim_run(basehaz = "ms", delay = TRUE)) validate_relbias(sims_ms_d) - - # interval censored models +} + +# interval censored models +if (run_sims) { set.seed(5050) sims_exp_i <- replicate(n_sims, sim_run(basehaz = "exp", icens = TRUE)) validate_relbias(sims_exp_i) - +} + +if (run_sims) { set.seed(6060) sims_weibull_i <- replicate(n_sims, sim_run(basehaz = "weibull", icens = TRUE)) validate_relbias(sims_weibull_i) - +} + +if (run_sims) { set.seed(7070) sims_gompertz_i <- replicate(n_sims, sim_run(basehaz = "gompertz", icens = TRUE)) validate_relbias(sims_gompertz_i) - +} + +if (run_sims) { set.seed(8080) sims_ms_i <- replicate(n_sims, sim_run(basehaz = "ms", icens = TRUE)) validate_relbias(sims_ms_i) - } + # run simulations to check piecewise constant time-varying effects if (run_sims) { @@ -961,6 +1001,15 @@ if (run_sims) { trt = fixef(mod)[2L], trt_tve = fixef(mod)[3L]) + # check Rhat + rhats <- summary(mod)[, "Rhat"] + rhats <- rhats[!names(rhats) %in% c("lp__", "log-posterior")] + + converged <- (all(rhats <= 1.1, na.rm = TRUE)) + + if (!converged) + ests <- rep(NA, length(ests)) # set estimates to NA if model didn't converge + if (return_relb) return(as.vector((ests - true) / true)) @@ -972,19 +1021,26 @@ if (run_sims) { # functions to summarise the simulations and check relative bias summarise_sims <- function(x) { + message("Number of simulations that converged: ", + sum(!is.na(do.call(rbind, x["ests",])[,1]))) rbind(true = colMeans(do.call(rbind, x["true",])), ests = colMeans(do.call(rbind, x["ests",])), bias = colMeans(do.call(rbind, x["bias",])), relb = colMeans(do.call(rbind, x["relb",]))) } + validate_relbias <- function(x, tol = 0.05) { + message("Number of simulations that converged: ", + sum(!is.na(do.call(rbind, x["ests",])[,1]))) relb <- as.vector(summarise_sims(x)["relb",]) expect_equal(relb, rep(0, length(relb)), tol = tol) } - - # tve models + +} + +# tve models +if (run_sims) { set.seed(5050) sims_pw <- replicate(n_sims, sim_run()) validate_relbias(sims_pw) - } From fe27541f8932c6390fd1c8f0213ab9ca47c9abf7 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 4 Oct 2019 12:10:23 +1000 Subject: [PATCH 187/225] posterior_survfit.R: fix up validate_newdata --- R/posterior_survfit.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index bf458cb1e..7e4639a79 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -391,7 +391,7 @@ posterior_survfit.stansurv <- function(object, dots <- list(...) - newdata <- validate_newdata(newdata) + newdata <- validate_newdata(object, newdata = newdata) has_newdata <- not.null(newdata) # Obtain a vector of unique subject ids From b91202ad1945bf7265d5300840cde73225ed194b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 4 Oct 2019 12:10:59 +1000 Subject: [PATCH 188/225] stan_surv vignette: use loo_compare --- vignettes/surv.Rmd | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index e0ae8fbf0..74889cd0c 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -28,15 +28,16 @@ h1 { /* Header 1 */ ``` ```{r, child="children/SETTINGS-gg.txt"} ``` -```{r, child="children/SETTINGS-rstan.txt"} -``` -```{r, child="children/SETTINGS-loo.txt"} -``` ```{r setup_jm, include=FALSE, message=FALSE} knitr::opts_chunk$set(fig.width=10, fig.height=4) library(rstanarm) set.seed(989898) + +CHAINS <- 1 +CORES <- 1 +SEED <- 12345 +ITER <- 1000 ``` @@ -394,12 +395,12 @@ bayesplot::bayesplot_grid(p_exp, We can also compare the fit of these models using the `loo` method for `stansurv` objects ```{r, message=FALSE} -compare_models(loo(mod1_exp), - loo(mod1_weibull), - loo(mod1_gompertz), - loo(mod1_bspline), - loo(mod1_mspline1), - loo(mod1_mspline2)) +loo_compare(loo(mod1_exp), + loo(mod1_weibull), + loo(mod1_gompertz), + loo(mod1_bspline), + loo(mod1_mspline1), + loo(mod1_mspline2)) ``` where we see that models with a flexible parametric (spline-based) baseline hazard fit the data best followed by the standard parametric (Weibull, Gompertz, exponential) models. Roughly speaking, the B-spline and M-spline models seem to fit the data equally well since the differences in `elpd` or `looic` between the models are very small relative to their standard errors. Moreover, increasing the degrees of freedom for the M-splines from 5 to 10 doesn't seem to improve the fit (that is, the default degrees of freedom `df = 5` seems to provide sufficient flexibility to model the baseline hazard). @@ -611,7 +612,7 @@ Let's calculate the `loo` for both these models and compare them: ```{r frail-compare-1, warning = FALSE, message = FALSE} loo_fixed <- loo(mod_fixed) loo_randint <- loo(mod_randint) -compare_models(loo_fixed, loo_randint) +loo_compare(loo_fixed, loo_randint) ``` We see strong evidence in favour of the model with the site-specific intercepts! @@ -630,7 +631,7 @@ Let's now compare all three of these models based on `loo`: ```{r frail-compare-2, warning = FALSE, message = FALSE} loo_randtrt <- loo(mod_randtrt) -compare_models(loo_fixed, loo_randint, loo_randtrt) +loo_compare(loo_fixed, loo_randint, loo_randtrt) ``` It appears that the model with just a site-specific intercept is the best fitting model. It is much better than the model without a site-specific intercept, and slightly better than the model with both a site-specific intercept and a site-specific treatment effect. In other words, including a site-specific intercept appears important, but including a site-specific treatment effect is not. This conclusion is reassuring, because it aligns with the data generating model we used to simulate the data! From f8627b17764c7c38b1c4adfba87ba254c9d8b913 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Fri, 4 Oct 2019 18:23:41 +1000 Subject: [PATCH 189/225] stan_surv vignette: some small fixes --- vignettes/surv.Rmd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index 74889cd0c..727bd54c8 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -552,7 +552,7 @@ We now estimate a model with a piecewise constant time-varying effect for the co ```{r tve-fit2, warning = FALSE, message = FALSE, results='hide'} mod3 <- stan_surv(formula = Surv(eventtime, status) ~ - tve(trt, type = "pw", knots = 2.5), + tve(trt, degree = 0, knots = 2.5), data = dat, chains = CHAINS, cores = CORES, @@ -560,7 +560,7 @@ mod3 <- stan_surv(formula = Surv(eventtime, status) ~ iter = ITER) ``` -This time we specify some additional arguments to the `tve` function, so that our time-varying effect corresponds to the true data generating model used to simulate our event times. Specifically, we specify `type = "pw"` to say that we want the time-varying effect (i.e. the time-varying log hazard ratio) to be estimated using a piecewise constant function and `knots = 2.5` says that we only want one internal knot placed at the time $t = 2.5$. +This time we specify some additional arguments to the `tve` function, so that our time-varying effect corresponds to the true data generating model used to simulate our event times. Specifically, we specify `degree = 0` to say that we want the time-varying effect (i.e. the time-varying log hazard ratio) to be estimated using a piecewise constant function and `knots = 2.5` says that we only want one internal knot placed at the time $t = 2.5$. We can again use the generic `plot` function with argument `plotfun = "tve"` to examine our estimated hazard ratio for treatment From 77f8a90e0fe4ba0fbdcff7858d81b2b7a8444e03 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sat, 5 Oct 2019 13:09:35 +1000 Subject: [PATCH 190/225] stan_surv vignette: updates to vignette --- vignettes/surv.Rmd | 674 +++++++++++++++++++++++++++++++++++---------- 1 file changed, 534 insertions(+), 140 deletions(-) diff --git a/vignettes/surv.Rmd b/vignettes/surv.Rmd index e0ae8fbf0..95e475610 100644 --- a/vignettes/surv.Rmd +++ b/vignettes/surv.Rmd @@ -47,46 +47,30 @@ This vignette provides an introduction to the `stan_surv` modelling function in # Introduction -Survival (a.k.a. time-to-event) analysis is generally concerned with the time from some defined baseline (e.g. diagnosis of a disease) until an event of interest occurs (e.g. death or disease progression). +Survival (or time-to-event) analysis is concerned with the analysis of an outcome variable that corresponds to the time from some defined baseline until an event of interest occurs. The methodology is used in a range of disciplines where it is known by a variety of different names. These include survival analysis (medicine), duration analysis (economics), reliability analysis (engineering), and event history analysis (sociology). Survival analyses are particularly common in health and medical research, where a classic example of survival outcome data is the time from diagnosis of a disease until the occurrence of death. -In standard survival analysis, one event time is measured for each observational unit. In practice however that event time may be unobserved due to left, right, or interval censoring, in which case the event time is only known to have occurred within the relevant censoring interval. +In standard survival analysis, one event time is measured for each observational unit. In practice however that event time may be unobserved due to left, right, or interval censoring, in which case the event time is only known to have occurred within the relevant censoring interval. The combined aspects of time and censoring make survival analysis methodology distinct from many other regression modelling approaches. -There are two common approaches to modelling survival data. The first is to model the *rate* of the event (known as the *hazard*) as a function of time -- the class of models known as proportional and non-proportional hazards regression models. The second is to model the event time directly -- the class of models known as accelerated failure time (AFT) models. In addition, a number of extensions to standard survival analysis have been proposed. These include the handling of multiple (recurrent) events, competing events, clustered survival data, cure models, and more. +There are two common approaches to modelling survival data. The first is to model the instantaneous rate of the event (known as the hazard) as a function of time. This includes the class of models known as proportional and non-proportional hazards regression models. The second is to model the event time itself. This includes the class of models known as accelerated failure time (AFT) models. Under both of these modelling frameworks a number of extensions have been proposed. For instance the handling of recurrent events, competing events, clustered survival data, cure models, and more. More recently, methods for modelling both longitudinal (e.g. a repeatedly measured biomarker) and survival data have become increasingly popular (as described in the `stan_jm` [vignette](priors.html)). -The intention is for the `stan_surv` modelling function in the **rstanarm** package to provide functionality for fitting a wide range of Bayesian survival models. The current implementation allows for the following model formulations: +This vignette is structured as follows. In the next sections we describe the modelling, estimation, and prediction frameworks underpinning survival models in __rstanarm__. Following that we describe the implementation and arguments for the `stan_surv` modelling function. Following that we demonstrate usage of the package through a series of examples. -- standard parametric (exponential, Weibull and Gompertz) hazard models -- flexible parametric (cubic spline-based) hazard models -- standard parametric (exponential and Weibull) AFT models. - -Under each of those model formulations the following are allowed: - -- left, right, and interval censored survival data -- delayed entry (i.e. left truncation) -- covariates can be time-fixed or time-varying (with the latter specified using a "start-stop" data structure) -- coefficients for covariates can be either time-fixed (e.g. proportional hazards) or time-varying (e.g. non-proportional hazards) -- when coefficients are specified as time-varying they can be modelled using either a smooth (cubic) B-spline function or a piecewise constant function. - - -# Technical details +# Modelling framework ## Data and notation -We assume that a true event time for individual $i$ ($i = 1,...,N$) exists, denoted $T_i^*$, but that in practice it may or may not observed due to left, right, or interval censoring. Therefore, in practice we observe outcome data $\mathcal{D}_i = \{T_i, T_i^U, T_i^E, d_i\}$ for individual $i$ where: +We assume that a true event time for individual $i$ ($i = 1,...,N$) exists and can be denoted $T_i^*$. However, in practice $T_i^*$ may not be observed due to left, right, or interval censoring. We therefore observe outcome data $\mathcal{D}_i = \{T_i, T_i^U, T_i^E, d_i\}$ for individual $i$ where: -- $T_i$: the observed event or censoring time -- $T_i^U$: the observed upper limit for interval censored individuals -- $T_i^E$: the observed entry time (i.e. the time at which an individual became at risk for the event) +- $T_i$ denotes the observed event or censoring time +- $T_i^U$ denotes the observed upper limit for interval censored individuals +- $T_i^E$ denotes the observed entry time (i.e. the time at which an individual became at risk for the event); and +- $d_i \in \{0,1,2,3\}$ denotes an event indicator taking value 0 if individual $i$ was right censored (i.e. $T_i^* > T_i$), value 1 if individual $i$ was uncensored (i.e. $T_i^* = T_i$), value 2 if individual $i$ was left censored (i.e. $T_i^* < T_i$), or value 3 if individual $i$ was interval censored (i.e. $T_i < T_i^* < T_i^U$). -and $d_i \in \{0,1,2,3\}$ denotes an event indicator taking value: +### Hazard, cumulative hazard, and survival -- 0 if individual $i$ was right censored (i.e. $T_i^* > T_i$) -- 1 if individual $i$ was uncensored (i.e. $T_i^* = T_i$) -- 2 if individual $i$ was left censored (i.e. $T_i^* < T_i$) -- 3 if individual $i$ was interval censored (i.e. $T_i < T_i^* < T_i^U$) +There are three key quantities of interest in standard survival analysis: the hazard rate, the cumulative hazard, and the survival probability. It is these quantities that are used to form the likelihood function for the survival models described in later sections. -## The hazard rate, cumulative hazard, and survival probability - -The hazard of the event at time $t$ is the instantaneous rate of occurrence for the event at time $t$. Mathematically, it is defined as: +The hazard is the instantaneous rate of occurrence for the event at time $t$. Mathematically, it is defined as: \ \begin{equation} \begin{split} @@ -95,7 +79,9 @@ h_i(t) = \lim_{\Delta t \to 0} \end{split} \end{equation} \ -where $\Delta t$ is the width of some small time interval. The numerator is the conditional probability of the individual experiencing the event during the time interval $[t, t + \Delta t)$, given that they were still at risk of the event at time $t$. The denominator converts the conditional probability to a rate per unit of time. As $\Delta t$ approaches the limit, the width of the interval approaches zero and the instantaneous event rate is obtained. +where $\Delta t$ is the width of some small time interval. + +The numerator is the conditional probability of the individual experiencing the event during the time interval $[t, t + \Delta t)$, given that they were still at risk of the event at time $t$. The denominator converts the conditional probability to a rate per unit of time. As $\Delta t$ approaches the limit, the width of the interval approaches zero and the instantaneous event rate is obtained. The cumulative hazard is defined as: \ @@ -113,216 +99,624 @@ S_i(t) = \exp \left[ -H_i(t) \right] = \exp \left[ -\int_{s=0}^t h_i(s) ds \righ \end{split} \end{equation} -It can be seen here that in the standard survival analysis setting there is a one-to-one relationship between each of the hazard, the cumulative hazard, and the survival probability. These quantities are also used to form the likelihood for the survival model described in the later sections. +It can be seen here that in the standard survival analysis setting -- where there is one event type of interest (i.e. no competing events) -- there is a one-to-one relationship between each of the hazard, the cumulative hazard, and the survival probability. -## Hazard scale formulations +### Delayed entry -When `basehaz` is set equal to `"exp"`, `"weibull"`, `"gompertz"`, `"ms"` (the default), or `"bs"` then the model is defined on the hazard scale as described by the following parameterisations. +Delayed entry, also known as left truncation, occurs when an individual is not at risk of the event until some time $t > 0$. As previously described we use $T_i^E$ to denote the entry time at which the individual becomes at risk. A common situation where delayed entry occurs is when age is used as the time scale. With age as the time scale it is likely that our study will only be concerned with the observation of individuals starting from some time (i.e. age) $t > 0$. -We model the hazard of the event for individual $i$ at time $t$ using the regression model: +To allow for delayed entry we essentially want to work with a conditional survival probability: \ \begin{equation} \begin{split} -h_i(t) = h_0(t) \exp \left[ \eta_i(t) \right] +S_i \left(t \mid T_i^E > 0 \right) = \frac{S_i(t)}{S_i \left( T_i^E \right)} \end{split} \end{equation} -\ -where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-varying; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying hazard ratio). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity and the definition of the hazard function reduces to: -\ + +Here the survival probability is evaluated conditional on the individual having survived up to the entry time. This conditional survival probability is used to allow for delayed entry in the log likelihood of our survival model. + +## Model formulations + +Our modelling approaches are twofold. First, we define a class of models on the hazard scale. This includes both proportional and non-proportional hazard regression models. Second, we define a class of models on the scale of the survival time. These are often known as accelerated failure time (AFT) models and can include both time-fixed and time-varying acceleration factors. + +These two classes of models and their respective features are described in the following sections. + +### Hazard scale models + +Under a hazard scale formulation, we model the hazard of the event for individual $i$ at time $t$ using the regression model: +/ \begin{equation} \begin{split} -h_i(t) = h_0(t) \exp \left[ \eta_i \right] +h_i(t) = h_0(t) \exp \left( \eta_i(t) \right) \end{split} \end{equation} +/ +where $h_0(t)$ is the baseline hazard (i.e. the hazard for an individual with all covariates set equal to zero) at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. -Our linear predictor is defined as: -\ +For full generality we allow the linear predictor to be time-varying. That is, it may be a function of time-varying covariates and/or time-varying coefficients (e.g. a time-varying hazard ratio). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity and the definition of the hazard function reduces to: +/ \begin{equation} \begin{split} -\eta_i(t) = \beta_0 + \sum_{p=1}^P \beta_p(t) x_{ip}(t) +h_i(t) = h_0(t) \exp \left( \eta_i \right) \end{split} \end{equation} -\ -where $\beta_0$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p(t)$ denotes the coefficient for the $p^{th}$ covariate. +/ +where the linear predictor $\eta_i$ is no longer a function of time. We describe the linear predictor in detail in later sections. -The quantity $\exp \left( \beta_p(t) \right)$ is referred to as a "hazard ratio". The *hazard ratio (HR)* quantifies the relative increase in the hazard that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a hazard ratio of 2 means that a unit-increase in the covariate leads to a doubling in the hazard (i.e. the instantaneous rate) of the event. The hazard ratio can be treated as a time-fixed quantity (i.e. proportional hazards) or time-varying quantity (i.e. non-proportional hazards), as described in later sections. +Different distributional assumptions can be made for the baseline hazard $h_0(t)$ and affect how the baseline hazard changes as a function of time. The __rstanarm__ package currently accommodates several standard parametric distributions for the baseline hazard (exponential, Weibull, Gompertz) as well as more flexible approaches that directly model the baseline hazard as a piecewise or smooth function of time using splines. -### Distributions +The following describes the baseline hazards that are currently implemented in the __rstanarm__ package. -- **Exponential model** (`basehaz = "exp"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ we have: -\ +#### M-splines model (the default): + +Let $M_{l}(t; \boldsymbol{k}, \delta)$ denote the $l^{\text{th}}$ $(l = 1,...,L)$ basis term for a degree $\delta$ M-spline function evaluated at a vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$, and $\gamma_{l}$ denote the $l^{\text{th}}$ M-spline coefficient. We then have: +/ +\begin{equation} +h_i(t) = \sum_{l=1}^{L} \gamma_{l} M_{l}(t; \boldsymbol{k}, \delta) \exp ( \eta_i(t) ) +\end{equation} + +The M-spline basis is evaluated using the method described in \cite{Ramsay:1988} and implemented in the __splines2__ package \citep{Wang:2018}. + +To ensure that the hazard function $h_i(t)$ is not constrained to zero at the origin (i.e. when $t$ approaches 0) the M-spline basis incorporates an intercept. To ensure identifiability of both the M-spline coefficients and the intercept in the linear predictor we constrain the M-spline coefficients to a simplex, that is, $\sum_{l=1}^L{\gamma_l} = 1$. + +The default degree in __rstanarm__ is $\delta = 3$ (i.e. cubic M-splines) such that the baseline hazard can be modelled as a flexible and smooth function of time, however this can be changed by the user. It is worthwhile noting that setting $\delta = 0$ is treated as a special case that corresponds to a piecewise constant baseline hazard. + +#### Exponential model: + +For scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ we have: +/ \begin{equation} h_i(t) = \lambda_i(t) \end{equation} -- **Weibull model** (`basehaz = "weibull"`): for scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and shape parameter $\gamma > 0$ we have: -\ +In the case where the linear predictor is not time-varying, the exponential model leads to a hazard rate that is constant over time. + +#### Weibull model: + +For scale parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and shape parameter $\gamma > 0$ we have: +/ \begin{equation} h_i(t) = \gamma t^{\gamma-1} \lambda_i(t) \end{equation} -- **Gompertz model** (`basehaz = "gompertz"`): for shape parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and scale parameter $\gamma > 0$ we have: -\ +In the case where the linear predictor is not time-varying, the Weibull model leads to a hazard rate that is monotonically increasing or monotonically decreasing over time. In the special case where $\gamma = 1$ it reduces to the exponential model. + +#### Gompertz model: + +For shape parameter $\lambda_i(t) = \exp ( \eta_i(t) )$ and scale parameter $\gamma > 0$ we have: +/ \begin{equation} h_i(t) = \exp(\gamma t) \lambda_i(t) \end{equation} -- **M-splines model** (`basehaz = "ms"`, the default): letting $M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta)$ denote a degree $\delta$ M-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0} = $ and parameter vector $\boldsymbol{\gamma} > 0$ we have: -\ -\begin{equation} -h_i(t) = M(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta) \exp ( \eta_i(t) ) -\end{equation} -\ -The M-spline function is calculated using the method described in Ramsay (1988) and implemented in the **splines2** R package (Wang and Yan (2018)). To ensure that the hazard function $h_i(t)$ is not constrained to zero at the origin (i.e. when $t$ approaches 0) the M-spline basis incorporates an intercept. To ensure identifiability of both the intercept parameter in the M-spline function and the intercept parameter in the linear predictor (i.e. $\beta_0$) we constrain the M-spline coefficients to a simplex, that is, $\sum_{j=1}^J{\gamma_j} = 1$. The default degree in **rstanarm** is $\delta = 3$; that is, cubic M-splines. However this can be controlled by the user via the `basehaz_ops` argument. It is worthwhile noting that $\delta = 0$ would correspond to a piecewise constant baseline hazard. +#### B-splines model (for the log baseline hazard): -- **B-splines model** (for the *log* baseline hazard): letting $B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta)$ denote a degree $\delta$ B-spline function with basis evaluated at a vector of knot locations $\boldsymbol{k_0}$ and parameter vector $\boldsymbol{\gamma}$ we have: -\ +Let $B_{l}(t; \boldsymbol{k}, \delta)$ denote the $l^{\text{th}}$ $(l = 1,...,L)$ basis term for a degree $\delta$ B-spline function evaluated at a vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$, and $\gamma_{l}$ denote the $l^{\text{th}}$ B-spline coefficient. We then have: +/ \begin{equation} -h_i(t) = \exp ( B(t; \boldsymbol{\gamma}, \boldsymbol{k_0}, \delta) + \eta_i(t) ) +h_i(t) = \exp \left( \sum_{l=1}^{L} \gamma_{l} B_{l}(t; \boldsymbol{k}, \delta) + \eta_i(t) \right) \end{equation} -\ -The B-spline function is calculated using the method implemented in the **splines2** R package (Wang and Yan (2018)). The B-spline basis does not require an intercept and therefore does not include one; any constant shift in the log hazard is fully captured via the intercept in the linear predictor (i.e. $\beta_0$). +/ +The B-spline basis is calculated using the method implemented in the __splines2__ package \citep{Wang:2018}. The B-spline basis does not require an intercept and therefore does not include one; any constant shift in the log hazard is fully captured via an intercept in the linear predictor. By default cubic B-splines are used (i.e. $\delta = 3$) and these allow the log baseline hazard to be modelled as a smooth function of time. -**Note:** When the linear predictor *is not* time-varying (i.e. under proportional hazards) there is a closed form expression for the survival probability (except for the B-splines model); details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under non-proportional hazards) there is no closed form expression for the survival probability; instead, quadrature is used to evaluate the survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. +### Accelerated failure time (AFT) models -## Accelerated failure time formulations - -When `basehaz` is set equal to `"exp-aft"`, or `"weibull-aft"` then the model is defined on the accelerated failure time scale as described by the following parameterisations. - -Following Hougaard (1999), we model the survival probability for individual $i$ at time $t$ using the regression model: -\ -\begin{equation} +Under an AFT formulation we model the survival probability for individual $i$ at time $t$ using the regression model \citep{Hougaard:1999}: +/ +\begin{equation} \label{eq:aftform-surv} \begin{split} -S_i(t) = S_0 \left( \int_0^t \exp \left[ - \eta_i(u) \right] du \right) +S_i(t) = S_0 \left( \int_{u=0}^t \exp \left( - \eta_i(u) \right) du \right) \end{split} \end{equation} -\ -where $S_0(t)$ is the baseline survival probability at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality, we allow the linear predictor to be time-varying; that is, it may be a function of time-varying covariates or time-varying coefficients (i.e. a time-varying acceleration factor). However, if there are no time-varying covariates or time-varying coefficients in the model, then the linear predictor reduces to a time-fixed quantity (i.e. $\eta_i(t) = \eta_i$) and the definition of the survival probability reduces to: -\ -\begin{equation} +/ +where $S_0(t)$ is the baseline survival probability at time $t$, and $\eta_i(t)$ denotes the linear predictor evaluated for individual $i$ at time $t$. For full generality we again allow the linear predictor to be time-varying. This also leads to a corresponding general expression for the hazard function \citep{Hougaard:1999} as follows: +/ +\begin{align} \label{eq:aftform-haz} \begin{split} -S_i(t) = S_0 \left( t \exp \left[ - \eta_i \right] \right) +h_i(t) = \exp \left(-\eta_i(t) \right) h_0 \left( \int_{u=0}^t \exp \left( - \eta_i(u) \right) du \right) \end{split} -\end{equation} +\end{align} -Our linear predictor is defined as: -\ +If there are no time-varying covariates or time-varying coefficients in the model, then the definition of the survival probability reduces to: +/ \begin{equation} \begin{split} -\eta_i(t) = \beta_0^* + \sum_{p=1}^P \beta_p^*(t) x_{ip}(t) +S_i(t) = S_0 \left( t \exp \left( - \eta_i \right) \right) \end{split} \end{equation} -\ -where $\beta_0^*$ denotes the intercept parameter, $x_{ip}(t)$ denotes the observed value of $p^{th}$ $(p=1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\beta_p^*(t)$ denotes the coefficient for the $p^{th}$ covariate. +/ +and for the hazard: +/ +\begin{align} +\begin{split} +h_i(t) = \exp \left( -\eta_i \right) h_0 \left( t \exp \left( - \eta_i \right) \right) +\end{split} +\end{align} -The quantity $\exp \left( - \beta_p^*(t) \right)$ is referred to as an "acceleration factor" and the quantity $\exp \left( \beta_p^*(t) \right)$ is referred to as a "survival time ratio". The *acceleration factor* (AF) quantifies the acceleration (or deceleration) of the event process that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. an acceleration factor of 0.5 means that a unit-increase in the covariate leads to an individual approaching the event at half the speed. If you find that somewhat confusing, then it may be easier to think about the survival time ratio. The *survival time ratio* (STR) is interpreted as the increase (or decrease) in the expected survival time that is associated with a unit-increase in the relevant covariate, $x_{ip}$; e.g. a survival time ratio of 2 (which is equivalent to an acceleration factor of 0.5) means that a unit-increase in the covariate leads to an doubling in the expected survival time. The survival time ratio is equal to the inverse of the acceleration factor (i.e. $\text{STR} = 1/\text{AF}$). +Different distributional assumptions can be made for how the baseline survival probability $S_0(t)$ changes as a function of time. The __rstanarm__ package currently accommodates two standard parametric distributions (exponential, Weibull) although others may be added in the future. The current distributions are implemented as follows. -### Distributions +#### Exponential model: -- **Exponential model** (`basehaz = "exp-aft"`): When the linear predictor is time-varying we have: -\ +When the linear predictor is time-varying we have: +/ \begin{equation} -S_i(t) = \exp \left( - \int_0^t \exp ( -\eta_i(u) ) du \right) +S_i(t) = \exp \left( - \int_{u=0}^t \exp ( -\eta_i(u) ) du \right) \end{equation} -\ +/ and when the linear predictor is time-fixed we have: -\ +/ \begin{equation} S_i(t) = \exp \left( - t \lambda_i \right) \end{equation} -\ +/ for scale parameter $\lambda_i = \exp ( -\eta_i )$. -- **Weibull model** (`basehaz = "weibull-aft"`): When the linear predictor is time-varying we have: -\ +#### Weibull model: + +When the linear predictor is time-varying we have: +/ \begin{equation} -S_i(t) = \exp \left( - \left[ \int_0^t \exp ( -\eta_i(u) ) du \right]^{\gamma} \right) +S_i(t) = \exp \left( - \left( \int_{u=0}^t \exp ( -\eta_i(u) ) du \right)^{\gamma} \right) \end{equation} -\ +/ for shape parameter $\gamma > 0$ and when the linear predictor is time-fixed we have: -\ +/ \begin{equation} S_i(t) = \exp \left( - t^{\gamma} \lambda_i \right) \end{equation} -\ +/ for scale parameter $\lambda_i = \exp ( -\gamma \eta_i )$ and shape parameter $\gamma > 0$. -**Note:** When the linear predictor *is not* time-varying (i.e. under time-fixed acceleration), there is a closed form expression for both the hazard function and survival function; details shown in the appendix. However, when the linear predictor *is* time-varying (i.e. under time-varying acceleration) there is no closed form expression for the hazard function or survival probability; instead, quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate the hazard function and survival probability for inclusion in the likelihood. Extended details on the parameterisations are given in the appendix. +## Linear predictor + +Under all of the previous model formulations our linear predictor can be defined as: +/ +\begin{equation} \label{eq:eta} +\begin{split} +\eta_i(t) = \boldsymbol{\beta}^T(t) \boldsymbol{X}_i(t) +\end{split} +\end{equation} +/ +where $\boldsymbol{X}_i(t) = [1, x_{i1}(t), ..., x_{iP}(t) ]$ denotes a vector of covariates with $x_{ip}(t)$ denoting the observed value of $p^{th}$ $(p = 1,...,P)$ covariate for the $i^{th}$ $(i=1,...,N)$ individual at time $t$, and $\boldsymbol{\beta}(t) = [ \beta_0, \beta_1(t), ... , \beta_P(t) ]$ denotes a vector of parameters with $\beta_0$ denoting an intercept parameter and $\beta_p(t)$ denoting the possibly time-varying coefficient for the $p^{th}$ covariate. -## Time-fixed and time-varying effects of covariates +### Hazard ratios -The coefficient $\beta_p(t)$ (i.e. the log hazard ratio) or $\beta_p^*(t)$ (i.e. log survival time ratio) can be treated as a time-fixed quantity (e.g. $\beta_p(t) = \beta_p$) or as a time-varying quantity. We refer to the latter as *time-varying effects* because the effect of the covariate is allowed to change as a function of time. In `stan_surv` time-varying effects are specified by using the `tve` function in the model formula. Note that in the following definitions we only refer to $\beta_p(t)$ (i.e. the log hazard ratio) but the same methodology applies to $\beta_p^*(t)$ (i.e. the log survival time ratio). +Under a hazard scale formulation the quantity $\exp \left( \beta_p(t) \right)$ is referred to as a \textif{hazard ratio}. -Without time-varying effects we have: -\ +The hazard ratio quantifies the relative increase in the hazard that is associated with a unit-increase in the relevant covariate, $x_{ip}$, assuming that all other covariates in the model are held constant. For instance, a hazard ratio of 2 means that a unit-increase in the covariate leads to a doubling in the hazard (i.e. the instantaneous rate) of the event. + +### Acceleration factors and survival time ratios + +Under an AFT formulation the quantity $\exp \left( - \beta_p(t) \right)$ is referred to as an \textif{acceleration factor} and the quantity $\exp \left( \beta_p(t) \right)$ is referred to as a \textif{survival time ratio}. + +The acceleration factor quantifies the acceleration (or deceleration) of the event process that is associated with a unit-increase in the relevant covariate, $x_{ip}$. For instance, an acceleration factor of 0.5 means that a unit-increase in the covariate corresponds to approaching the event at half the speed. + +The survival time ratio is interpreted as the increase (or decrease) in the expected survival time that is associated with a unit-increase in the relevant covariate, $x_{ip}$. For instance, a survival time ratio of 2 (which is equivalent to an acceleration factor of 0.5) means that a unit-increase in the covariate leads to an doubling in the expected survival time. + +Note that the survival time ratio is a simple reparameterisation of the acceleration factor. Specifically, the survival time ratio is equal to the reciprocal of the acceleration factor. The survival time ratio and the acceleration factor therefore provide alternative interpretations for the same effect of the same covariate. + +### Time-fixed vs time-varying effects + +Under either a hazard scale or AFT formulation the coefficient $\beta_p(t)$ can be treated as a time-fixed or time-varying quantity. + +When $\beta_p(t)$ is treated as a time-fixed quantity we have: +/ \begin{equation} \begin{split} \beta_p(t) = \theta_{p0} \end{split} \end{equation} -\ -such that $\theta_{p0}$ is a time-fixed log hazard ratio (or log survival time ratio). +/ +such that $\theta_{p0}$ is a time-fixed log hazard ratio (or log survival time ratio). On the hazard scale this is equivalent to assuming proportional hazards, whilst on the AFT scale it is equivalent to assuming a time-fixed acceleration factor. -With **time-varying effects modelled using B-splines** we have: -\ +When $\beta_p(t)$ is treated as a time-varying quantity we refer to it as a time-varying effect because the effect of the covariate is allowed to change as a function of time. On the hazard scale this leads to non-proportional hazards, whilst on the AFT scale it leads to time-varying acceleration factors. + +When $\beta_p(t)$ is time-varying we must determine how we wish to model it. In __rstanarm__ the default is to use B-splines such that: +/ \begin{equation} \begin{split} -\beta_p(t) = \theta_{p0} + \sum_{m=1}^{M} \theta_{pm} B_{m}(t; \boldsymbol{k}, \delta) +\beta_p(t) = \theta_{p0} + \sum_{l=1}^{L} \theta_{pl} B_{l}(t; \boldsymbol{k}, \delta) \end{split} \end{equation} -\ -where $\theta_{p0}$ is a constant, $B_{m}(t; \boldsymbol{k}, \delta)$ is the $m^{\text{th}}$ $(m = 1,...,M)$ basis term for a degree $\delta$ B-spline function evaluated at a vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$, and $\theta_{pm}$ is the $m^{\text{th}}$ B-spline coefficient. By default cubic B-splines are used (i.e. $\delta = 3$). These allow the log hazard ratio (or log survival time ratio) to be modelled as a smooth function of time. +/ +where $\theta_{p0}$ is a constant, $B_{l}(t; \boldsymbol{k}, \delta)$ is the $l^{\text{th}}$ $(l = 1,...,L)$ basis term for a degree $\delta$ B-spline function evaluated at a vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$, and $\theta_{pl}$ is the $l^{\text{th}}$ B-spline coefficient. By default cubic B-splines are used (i.e. $\delta = 3$). These allow the log hazard ratio (or log survival time ratio) to be modelled as a smooth function of time. + +However an alternative is to model $\beta_p(t)$ using a piecewise constant function: +/ +\begin{equation} +\begin{split} +\beta_p(t) = \theta_{p0} + \sum_{l=1}^{L} \theta_{pl} I(k_{l+1} < t \leq k_{l+2}) +\end{split} +\end{equation} +/ +where $I(x)$ is an indicator function taking value 1 if $x$ is true and 0 otherwise, $\theta_{p0}$ is a constant corresponding to the log hazard ratio (or log survival time ratio for AFT models) in the first time interval, $\theta_{pl}$ is the deviation in the log hazard ratio (or log survival time ratio) between the first and $(l+1)^\text{th}$ $(l = 1,...,L)$ time interval, and $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ is a sequence of knot locations (i.e. break points) that includes the lower and upper boundary knots. This allows the log hazard ratio (or log survival time ratio) to be modelled as a piecewise constant function of time. -The degrees of freedom is equal to the number of additional parameters required to estimate a time-varying coefficient relative to a time-fixed coefficient. When a B-spline function is used to model the time-varying coefficient the degrees of freedom are $M = J + \delta - 2$ where $J$ is the total number of knots (including boundary knots). +Note that we have dropped the subscript $p$ from the knot locations $\boldsymbol{k}$ and degree $\delta$ discussed above. This is just for simplicity of the notation. In fact, if a model has a time-varying effect estimated for more than one covariate, then each of these can be modelled using different knot locations and/or degree if the user desires. These knot locations and/or degree can also differ from those used for modelling the baseline or log baseline hazard described previously in Section \ref{sec:modelformulations}. -With **time-varying effects modelled using a piecewise constant function** we have: -\ +### Relationship between proportional hazards and AFT models + +As shown in Section \ref{sec:modelformulations} some baseline distributions can be parameterised as either a proportional hazards or an AFT model. In __rstanarm__ this currently includes the exponential and Weibull models. One can therefore transform the estimates from an exponential or Weibull proportional hazards model to get the estimates that would be obtained under an exponential or Weibull AFT parameterisation. + +Specifically, the following relationship applies for the exponential model: +/ \begin{equation} \begin{split} -\beta_p(t) = \theta_{p0} + \sum_{m=1}^{M} \theta_{pm} I(k_{m+1} < t \leq k_{m+2}) +\beta_0 & = - \beta_0^* \\ +\beta_p & = - \beta_p^* \end{split} \end{equation} -\ -where $I(x)$ is an indicator function taking value 1 if $x$ is true and 0 otherwise, $\theta_{p0}$ is a constant corresponding to the log hazard ratio (or log survival time ratio for AFT models) in the first time interval, $\theta_{pm}$ is the deviation in the log hazard ratio (or log survival time ratio) between the first and $(m+1)^\text{th}$ $(m = 1,...,M)$ time interval, and $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ is a sequence of knot locations (i.e. break points) that includes the lower and upper boundary knots. This allows the log hazard ratio (or log survival time ratio) to be modelled as a piecewise constant function of time. +/ +and for the Weibull model: +/ +\begin{equation} +\begin{split} +\beta_0 & = -\gamma \beta_0^* \\ +\beta_p & = -\gamma \beta_p^* +\end{split} +\end{equation} +/ +where the unstarred parameters are from the proportional hazards model and the starred ($*$) parameters are from the AFT model. Note however that these relationships only hold in the absence of time-varying effects. This is demonstrated using a real dataset in the example in Section \ref{sec:aftmodel}. + +## Multilevel survival models + +The definition of the linear predictor in Equation \ref{eq:eta} can be extended to allow for shared frailty or other clustering effects. + +Suppose that the individuals in our sample belong to a series of clusters. The clusters may represent for instance hospitals, families, or GP clinics. We denote the $i^{th}$ individual ($i = 1,...,N_j$) as a member of the $j^{th}$ cluster ($j = 1,...,J$). Moreover, to indicate the fact that individual $i$ is now a member of cluster $j$ we index the observed data (i.e. event times, event indicator, and covariates) with a subscript $j$, that is $T_{ij}^*$, $\mathcal{D}_{ij} = \{T_{ij}, T_{ij}^U, T_{ij}^E, d_{ij}\}$ and $X_{ij}(t)$, as well as estimated quantities such as the hazard rate, cumulative hazard, survival probability, and linear predictor, that is $h_{ij}(t)$, $H_{ij}(t)$, $S_{ij}(t)$, and $\eta_{ij}(t)$. -The degrees of freedom is equal to the number of additional parameters required to estimate a time-varying coefficient relative to a time-fixed coefficient. When a piecewise constant function is used to model the time-varying coefficient the degrees of freedom are $M = J - 2$ where $J$ is the total number of knots (including boundary knots). +To allow for intra-cluster correlation in the event times we include cluster-specific random effects in the linear predictor as follows: +/ +\begin{equation} \label{eq:multileveleta} +\begin{split} +\eta_{ij}(t) = \boldsymbol{\beta}^T \boldsymbol{X}_{ij}(t) + \boldsymbol{b}_{j}^T \boldsymbol{Z}_{ij} +\end{split} +\end{equation} +/ +where $\boldsymbol{Z}_{ij}$ denotes a vector of covariates for the $i^{th}$ individual in the $j^{th}$ cluster, with an associated vector of cluster-specific parameters $\boldsymbol{b}_{j}$. We assume that the cluster-specific parameters are normally distributed such that $\boldsymbol{b}_{j} \sim N(0, \boldsymbol{\Sigma}}_{b})$ for some variance-covariance matrix $\boldsymbol{\Sigma}}_{b}$. We assume that $\boldsymbol{\Sigma}}_{b}$ is unstructured, that is each variance and covariance term is allowed to be different. -**Default knot locations:** The vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ includes a lower boundary knot $k_{1}$ at the earliest entry time (equal to zero if there isn't delayed entry) and an upper boundary knot $k_{J}$ at the latest event or censoring time. The boundary knots cannot be changed by the user. Internal knot locations -- that is $k_{2},...,k_{(J-1)}$ when $J \geq 3$ -- can be explicitly specified by the user (see the `knots` argument to the `tve` function) or are determined by default. The default is to place the internal knots at equally spaced percentiles of the distribution of uncensored event times. When a B-spline function is specified, the `tve` function uses default values $M = 3$ (degrees of freedom) and $\delta = 3$ (cubic splines) which in fact corresponds to a cubic B-spline function with no internal knots. When a piecewise constant function is specified, the `tve` function uses a default value of $M = 3$ (degrees of freedom) which corresponds to internal knots at the $25^{\text{th}}$, $50^{\text{th}}$, and $75^{\text{th}}$ percentiles of the distribution of the uncensored event times. +In most cases $\boldsymbol{b}_{j}$ will correspond to just a cluster-specific random intercept (often known as a "shared frailty" term) but more complex random effects structures are possible. -**Note on subscripts:** We have dropped the subscript $p$ from the knot locations $\boldsymbol{k}$ and degree of the B-splines $\delta$ discussed above. This is just for simplicity of the notation. In fact, if a model has time-varying effects estimated for more than one covariate, then each these can be modelled using different knot locations and/or degree if the user desires. +For simplicitly of notation Equation \ref{eq:multileveleta} also assumes just one clustering factor in the model (indexed by $j = 1,...,J$). However, it is possible to extend the model to multiple clustering factors (in __rstanarm__ there is no limit to the number of clustering factors that can be included). For example, suppose that the $i^{th}$ individual was clustered within the $j^{th}$ hospital that was clustered within the $k^{th}$ geographical region. Then we would have hospital-specific random effects $\boldsymbol{b}_j \sim N(0, \boldsymbol{\Sigma}}_{b})$ and region-specific random effects $\boldsymbol{u}_k \sim N(0, \boldsymbol{\Sigma}}_{u})$ and assume $\boldsymbol{b}_j$ and $\boldsymbol{u}_k$ are independent for all $(j,k)$. -## Likelihood +# Estimation framework -Allowing for the three forms of censoring and potential delayed entry (i.e. left truncation) the likelihood for the survival model takes the form: -\ -\begin{align} +## Log posterior + +The log posterior for the $i^{th}$ individual in the $j^{th}$ cluster can be specified as: +/ +\begin{equation} \begin{split} -p(\mathcal{D}_i | \boldsymbol{\gamma}, \boldsymbol{\beta}) = - & {\left[ h_i(T_i) \right]}^{I(d_i=1)} \\ - & \times {\left[ S_i(T_i) \right]}^{I(d_i \in \{0,1\})} \\ - & \times {\left[ 1 - S_i(T_i) \right]}^{I(d_i=2)} \\ - & \times {\left[ S_i(T_i) - S_i(T_i^U) \right]}^{I(d_i=3)} \\ - & \times {\left[ S_i(T_i^E) \right]}^{-1} +\log p(\boldsymbol{\theta}, \boldsymbol{b}_{j} \mid \mathcal{D}_{ij}) + \propto + \log p(\mathcal{D}_{ij} \mid \boldsymbol{\theta}, \boldsymbol{b}_{j}) + + \log p(\boldsymbol{b}_{j} \mid \boldsymbol{\theta}) + + \log p(\boldsymbol{\theta}) \end{split} -\end{align} +\end{equation} +/ +where $\log p(\mathcal{D}_{ij} \mid \boldsymbol{\theta}, \boldsymbol{b}_{j})$ is the log likelihood for the outcome data, $\log p(\boldsymbol{b}_{j} \mid \boldsymbol{\theta})$ is the log likelihood for the distribution of any cluster-specific parameters (i.e. random effects) when relevant, and $\log p(\boldsymbol{\theta})$ represents the log likelihood for the joint prior distribution across all remaining unknown parameters. + +## Log likelihood + +Allowing for the three forms of censoring (left, right, and interval censoring) and potential delayed entry (i.e. left truncation) the log likelihood for the survival model takes the form: +/ +\begin{equation} \label{eq:loglik} +\begin{split} +\log p(\mathcal{D}_{ij} \mid \boldsymbol{\theta}, \boldsymbol{b}_{j}) + & = {I(d_{ij} = 0)} \times \log \left[ S_{ij}(T_{ij}) \right] \\ + & \quad + {I(d_{ij} = 1)} \times \log \left[ h_{ij}(T_{ij}) \right] \\ + & \quad + {I(d_{ij} = 1)} \times \log \left[ S_{ij}(T_{ij}) \right] \\ + & \quad + {I(d_{ij} = 2)} \times \log \left[ 1 - S_{ij}(T_{ij}) \right] \\ + & \quad + {I(d_{ij} = 3)} \times \log \left[ S_{ij}(T_{ij}) - S_{ij}(T_{ij}^U) \right] \\ + & \quad - \log \left[ S_{ij} ( T_{ij}^E ) \right] +\end{split} +\end{equation} +/ +where $I(x)$ is an indicator function taking value 1 if $x$ is true and 0 otherwise. That is, each individual's contribution to the likelihood depends on the type of censoring for their event time. + +The last term on the right hand side of Equation \ref{eq:loglik} accounts for delayed entry. When an individual is at risk from time zero (i.e. no delayed entry) then $T_{ij}^E = 0$ and $S_{ij}(0) = 1$ meaning that the last term disappears from the likelihood. + +### Evaluating integrals in the log likelihood + +When the linear predictor is time-fixed there is a closed form expression for both the hazard rate and survival probability in almost all cases (the single exception is when B-splines are used to model the log baseline hazard). When there is a closed form expression for both the hazard rate and survival probability then there is also a closed form expression for the (log) likelihood function. The details of these expressions are given in Appendix \ref{app:haz-parameterisations} (for hazard models) and Appendix \ref{app:aft-parameterisations} (for AFT models). + +However, when the linear predictor is time-varying there isn't a closed form expression for the survival probability. Instead, Gauss-Kronrod quadrature with $Q$ nodes is used to approximate the necessary integrals. + +For hazard scale models Gauss-Kronrod quadrature is used to evaluate the cumulative hazard, which in turn is used to evaluate the survival probability. Expanding on Equation \ref{eq:survdef} we have: +/ +\begin{equation} +\begin{split} +\int_{u=0}^{T_{ij}} h_{ij}(u) du + \approx \frac{T_{ij}}{2} \sum_{q=1}^{Q} w_q h_{ij} \left( \frac{T_{ij}(1 + v_q)}{2} \right) +\end{split} +\end{equation} +/ +where $w_q$ and $v_q$, respectively, are the standardised weights and locations ("abscissa") for quadrature node $q$ $(q = 1,...,Q)$ \citep{Laurie:1997}. + +For AFT models Gauss-Kronrod quadrature is used to evaluate the cumulative acceleration factor, which in turn is used to evaluate both the survival probability and the hazard rate. Expanding on Equations \ref{eq:aftform-surv} and \ref{eq:aftform-haz} we have: +/ +\begin{equation} +\begin{split} +\int_{u=0}^{T_{ij}} \exp \left( - \eta_{ij}(u) \right) du + \approx \frac{T_{ij}}{2} \sum_{q=1}^{Q} w_q \exp \left( - \eta_{ij} \left( \frac{T_{ij}(1 + v_q)}{2} \right) \right) +\end{split} +\end{equation} + +When quadrature is necessary, the default in __rstanarm__ is to use $Q = 15$ nodes. But the number of nodes can be changed by the user. + +## Prior distributions + +For each of the parameters a number of prior distributions are available. Default choices exist, but the user can explicitly specify the priors if they wish. + +### Intercept + +All models include an intercept parameter in the linear predictor ($\beta_0$) which effectively forms part of the baseline hazard. Choices of prior distribution for $\beta_0$ include the normal, t, or Cauchy distributions. The default is a normal distribution with mean 0 and standard deviation of 20. + +However it is worth noting that -- internally (but not in the reported parameter estimates) -- the prior is placed on the intercept after centering the predictors at their sample means and after applying a constant shift of $\log \left( \frac{E}{T} \right)$ where $E$ is the total number of events and $T$ is the total follow up time. For instance, the default prior is not centered on an intercept of zero when all predictors are at their sample means, but rather, it is centered on the log crude event rate when all predictors are at their sample means. This is intended to help with numerical stability and sampling, but does not impact on the reported estimates (i.e. the intercept is back-transformed before being returned to the user). + +\subsubsection{Regression coefficients} + +Choices of prior distribution for the time-fixed regression coefficients $\theta_{p0}$ ($p = 1,...,P$) include normal, t, and Cauchy distributions as well as several shrinkage prior distributions. + +Where relevant, the additional coefficients required for estimating a time-varying effect (i.e. the B-spline coefficients or the interval-specific deviations in the piecewise constant function) are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ can be specified by the user and choices include an exponential, half-normal, half-t, or half-Cauchy distribution. Note that lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function for modelling the time-varying effect. + +\subsubsection{Auxiliary parameters} + +There are several choices of prior distribution for the so-called "auxiliary" parameters related to the baseline hazard (i.e. scalar $\gamma$ for the Weibull and Gompertz models or vector $\boldsymbol{\gamma}$ for the M-spline and B-spline models). These include: + +\begin{itemize} + +\item a Dirichlet prior distribution for the baseline hazard M-spline coefficients $\boldsymbol{\gamma}$; + +\item a half-normal, half-t, half-Cauchy or exponential prior distribution for the Weibull shape parameter $\gamma$; + +\item a half-normal, half-t, half-Cauchy or exponential prior distribution for the Gompertz scale parameter $\gamma$; and + +\item a normal, t, or Cauchy prior distribution for the log baseline hazard B-spline coefficients $\boldsymbol{\gamma}$. + +\end{itemize} + +\subsubsection{Covariance matrices} + +When a multilevel survival model is estimated there is an unstructured covariance matrix estimated for the random effects. Of course, in the situation where there is just one random effect in the model `formula` (e.g. a random intercept or "shared frailty" term) the covariance matrix will reduce to just a single element; i.e. it will be a scalar equal to the variance of the single random effect in the model. + +The prior distribution is based on a decomposition of the covariance matrix. The decomposition takes place as follows. The covariance matrix $\boldsymbol{\Sigma}_b$ is decomposed into a correlation matrix $\boldsymbol{\Omega}$ and vector of variances. The vector of variances is then further decomposed into a simplex $\pi$ (i.e. a probability vector summing to 1) and a scalar equal to the sum of the variances. Lastly, the sum of the variances is set equal to the order of the covariance matrix multiplied by the square of a scale parameter (here we denote that scale parameter $\tau$). + +The prior distribution for the correlation matrix $\boldsymbol{\Omega}$ is the LKJ distribution \citep{Lewandowski:2009}. It is parameterised through a regularisation parameter $\zeta > 0$. The default is $\zeta = 1$ such that the LKJ prior distribution is jointly uniform over all possible correlation matrices. When $\zeta > 1$ the mode of the LKJ distribution is the identity matrix and as $\zeta$ increases the distribution becomes more sharply peaked at the mode. When $0 < \zeta < 1$ the prior has a trough at the identity matrix. + +The prior distribution for the simplex $\boldsymbol{\pi}$ is a symmetric Dirichlet distribution with a single concentration parameter $\phi > 0$. The default is $\phi = 1$ such that the prior is jointly uniform over all possible simplexes. If $\phi > 1$ then the prior mode corresponds to all entries of the simplex being equal (i.e. equal variances for the random effects) and the larger the value of $\phi$ then the more pronounced the mode of the prior. If $0 < \phi < 1$ then the variances are polarised. -## Priors +The prior distribution for the scale parameter $\tau$ is a Gamma distribution. The shape and scale parameter for the Gamma distribution are both set equal to 1 by default, however the user can change the value of the shape parameter. The behaviour is such that increasing the shape parameter will help enforce that the trace of $\boldsymbol{\Sigma}_b$ (i.e. sum of the variances of the random effects) be non-zero. -The prior distribution for the so-called "auxiliary" parameters (i.e. $\gamma$ for the Weibull and Gompertz models, or $\boldsymbol{\gamma}$ for the M-spline and B-spline models) is specified via the `prior_aux` argument to `stan_surv`. Choices of prior distribution include: +Further details on this implied prior for covariance matrices can be found in the __rstanarm__ documentation and vignettes. + +## Estimation + +Estimation in __rstanarm__ is based on either full Bayesian inference (Hamiltonian Monte Carlo) or approximate Bayesian inference (either mean-field or full-rank variational inference). The default is full Bayesian inference, but the user can change this if they wish. The approximate Bayesian inference algorithms are much faster, but they only provide approximations for the joint posterior distribution and are therefore not recommended for final inference. + +Hamiltonian Monte Carlo is a form of Markov chain Monte Carlo (MCMC) in which information about the gradient of the log posterior is used to more efficiently sample from the posterior space. Stan uses a specific implementation of Hamiltonian Monte Carlo known as the No-U-Turn Sampler (NUTS) \citep{Hoffman:2014}. A benefit of NUTS is that the tuning parameters are handled automatically during a "warm-up" phase of the estimation. However the __rstanarm__ modelling functions provide arguments that allow the user to retain control over aspects such as the number of MCMC chains, number of warm-up and sampling iterations, and number of computing cores used. + +# Prediction framework + +## Survival predictions without clustering + +If our survival model does not contain any clustering effects (i.e. it is not a multilevel survival model) then our prediction framework is more straightforward. Let $\mathcal{D} = \{ \mathcal{D}_{i}; i = 1,...,N \}$ denote the entire collection of outcome data in our sample and let $T_{\max} = \max \{ T_{i}, T_{i}^U, T_{i}^E; i = 1,...,N \}$ denote the maximum event or censoring time across all individuals in our sample. + +Suppose that for some individual $i^*$ (who may or may not have been in our sample) we have covariate vector $\boldsymbol{x}_{i^*}$. Note that the covariate data must be time-fixed. The predicted probability of being event-free at time $0 < t \leq T_{\max}$, denoted $\hat{S}_{i^*}(t)$, can be generated from the posterior predictive distribution: +/ +\begin{equation} +\begin{split} +p \Big( \hat{S}_{i^*}(t) \mid \boldsymbol{x}_{i^*}, \mathcal{D} \Big) = + \int + p \Big( \hat{S}_{i^*}(t) \mid \boldsymbol{x}_{i^*}, \boldsymbol{\theta} \Big) + p \Big( \boldsymbol{\theta} \mid \mathcal{D} \Big) + d \boldsymbol{\theta} +\end{split} +\end{equation} + +We approximate this posterior predictive distribution by drawing from $p(\hat{S}_{i^*}(t) \mid \boldsymbol{x}_{i^*}, \boldsymbol{\theta}^{(l)})$ where $\boldsymbol{\theta}^{(l)}$ is the $l^{th}$ $(l = 1,...,L)$ MCMC draw from the posterior distribution $p(\boldsymbol{\theta} \mid \mathcal{D})$. + +## Survival predictions with clustering + +When there are clustering effects in the model (i.e. multilevel survival models) then our prediction framework requires conditioning on the cluster-specific parameters. Let $\mathcal{D} = \{ \mathcal{D}_{ij}; i = 1,...,N_j, j = 1,...,J \}$ denote the entire collection of outcome data in our sample and let $T_{\max} = \max \{ T_{ij}, T_{ij}^U, T_{ij}^E; i = 1,...,N_j, j = 1,...,J \}$ denote the maximum event or censoring time across all individuals in our sample. + +Suppose that for some individual $i^*$ (who may or may not have been in our sample) and who is known to come from cluster $j^*$ (which may or may not have been in our sample) we have covariate vectors $\boldsymbol{x}_{i^*j^*}$ and $\boldsymbol{z}_{i^*j^*}$. Note again that the covariate data is assumed to be time-fixed. + +If individual $i^*$ does in fact come from a cluster $j^* = j$ (for some $j \in \{1,...,J\}$) in our sample then the predicted probability of being event-free at time $0 < t \leq T_{\max}$, denoted $S_{i^*j}(t)$, can be generated from the posterior predictive distribution: +/ +\begin{equation} +\begin{split} +p \Big( \hat{S}_{i^*j}(t) \mid \boldsymbol{x}_{i^*j}, \boldsymbol{z}_{i^*j}, \mathcal{D} \Big) = + \int + \int + p \Big( \hat{S}_{i^*j}(t) \mid \boldsymbol{x}_{i^*j}, \boldsymbol{z}_{i^*j}, \boldsymbol{\theta}, \boldsymbol{b}_j \Big) + p \Big( \boldsymbol{\theta}, \boldsymbol{b}_j \mid \mathcal{D} \Big) + d \boldsymbol{b}_j \space d \boldsymbol{\theta} +\end{split} +\end{equation} + +Since cluster $j$ was included in our sample data it is easy for us to approximate this posterior predictive distribution by drawing from $p(\hat{S}_{i^*j}(t) \mid \boldsymbol{x}_{i^*j}, \boldsymbol{z}_{i^*j}, \boldsymbol{\theta}^{(l)}, \boldsymbol{b}_j^{(l)})$ where $\boldsymbol{\theta}^{(l)}$ and $\boldsymbol{b}_j^{(l)}$ are the $l^{th}$ $(l = 1,...,L)$ MCMC draws from the joint posterior distribution $p(\boldsymbol{\theta}, \boldsymbol{b}_j \mid \mathcal{D})$. + +Alternatively, individual $i^*$ may come from a new cluster $j^* \neq j$ (for all $j \in \{1,...,J\}$) that was not in our sample. The predicted probability of being event-free at time $0 < t \leq T_{\max}$ is therefore denoted $\hat{S}_{i^*j^*}(t)$ and can be generated from the posterior predictive distribution: +/ +\begin{equation} +\begin{aligned} +p \Big( \hat{S}_{i^*j^*}(t) \mid \boldsymbol{x}_{i^*j^*}, \boldsymbol{z}_{i^*j^*}, \mathcal{D} \Big) +& = + \int + \int + p \Big( \hat{S}_{i^*j^*}(t) \mid \boldsymbol{x}_{i^*j^*}, \boldsymbol{z}_{i^*j^*}, \boldsymbol{\theta}, \boldsymbol{\tilde{b}}_{j^*} \Big) + p \Big( \boldsymbol{\theta}, \boldsymbol{\tilde{b}}_{j^*} \mid \mathcal{D} \Big) + d \boldsymbol{\tilde{b}}_{j^*} \space d \boldsymbol{\theta} \\ +& = + \int + \int + p \Big( \hat{S}_{i^*j^*}(t) \mid \boldsymbol{x}_{i^*j^*}, \boldsymbol{z}_{i^*j^*}, \boldsymbol{\theta}, \boldsymbol{\tilde{b}}_{j^*} \Big) + p \Big( \boldsymbol{\tilde{b}}_{j^*} \mid \boldsymbol{\theta} \Big) + p \Big( \boldsymbol{\theta} \mid \mathcal{D} \Big) + d \boldsymbol{\tilde{b}}_{j^*} \space d \boldsymbol{\theta} \\ +\end{aligned} +\end{equation} +/ +where $\boldsymbol{\tilde{b}}_{j^*}$ denotes the cluster-specific parameters for the new cluster. We can obtain draws for $\boldsymbol{\tilde{b}}_{j^*}$ during estimation of the model (in a similar manner as for $\boldsymbol{b}_j$). At the $l^{th}$ iteration of the MCMC sampler we obtain $\boldsymbol{\tilde{b}}_{j^*}^{(l)}$ as a random draw from the posterior distribution of the cluster-specific parameters and store it for later use in predictions. The set of random draws $\boldsymbol{\tilde{b}}_{j^*}^{(l)}$ for $l = 1,...,L$ then allow us to essentially marginalise over the distribution of the cluster-specific parameters. This is the method used in __rstanarm__ when generating survival predictions for individuals in new clusters that were not part of the original sample. + +## Conditional survival probabilities + +In some instances we want to evaluate the predicted survival probability conditional on a last known survival time. This is known as a conditional survival probability. + +Suppose that individual $i^*$ is known to be event-free up until $C_{i^*}$ and we wish to predict the survival probability at some time $t > C_{i^*}$. To do this we draw from the conditional posterior predictive distribution: +/ +\begin{equation} +\begin{split} +p \Big( \hat{S}_{i^*}(t) \mid \boldsymbol{x}_{i^*}, \mathcal{D}, t > C_{i^*} \Big) = + \frac + {p \Big( \hat{S}_{i^*}(t) \mid \boldsymbol{x}_{i^*}, \mathcal{D} \Big)} + {p \Big( \hat{S}_{i^*}(C_{i^*}) \mid \boldsymbol{x}_{i^*}, \mathcal{D} \Big)} +\end{split} +\end{equation} +/ +or -- equivalently -- for multilevel survival models we have individual $i^*$ in cluster $j^*$ who is known to be event-free up until $C_{i^*j^*}$: +/ +\begin{equation} +\begin{split} +p \Big( \hat{S}_{i^*j^*}(t) \mid \boldsymbol{x}_{i^*j^*}, \boldsymbol{z}_{i^*j^*}, \mathcal{D}, t > C_{i^*j^*} \Big) = + \frac + {p \Big( \hat{S}_{i^*j^*}(t) \mid \boldsymbol{x}_{i^*j^*}, \boldsymbol{z}_{i^*j^*}, \mathcal{D} \Big)} + {p \Big( \hat{S}_{i^*j^*}(C_{i^*j^*}) \mid \boldsymbol{x}_{i^*j^*}, \boldsymbol{z}_{i^*j^*}, \mathcal{D} \Big)} +\end{split} +\end{equation} + +## Standardised survival probabilities + +All of the previously discussed predictions require conditioning on some covariate values $\boldsymbol{x}_{ij}$ and $\boldsymbol{z}_{ij}$. Even if we have a multilevel survival model and choose to marginalise over the distribution of the cluster-specific parameters, we are still obtaining predictions at some known unique values of the covariates. + +However sometimes we wish to generate an "average" survival probability. One possible approach is to predict at the mean value of all covariates \citep{Cupples:1995}. However this doesn't always make sense, especially not in the presence of categorical covariates. For instance, suppose our covariates are gender and a treatment indicator. Then predicting for an individual at the mean of all covariates might correspond to a 50% male who was 50% treated. That does not make sense and is not what we wish to do. + +A better alternative is to average over the individual survival probabilties. This essentially provides an approximation to marginalising over the joint distribution of the covariates. At any time $t$ it is possible to obtain a so-called standardised survival probability, denoted $\hat{S}^{*}(t)$, by averaging the individual-specific survival probabilities: +/ +\begin{equation} +\begin{split} +p ( \hat{S}^{*}(t) \mid \mathcal{D} ) = + \frac{1}{N^{P}} + \sum_{i=1}^{N^{P}} p ( \hat{S}_i(t) \mid \boldsymbol{x}_{i^*}, \mathcal{D} ) +\end{split} +\end{equation} +/ +where $\hat{S}_i(t)$ is the predicted survival probability for individual $i$ ($i = 1,...,N^{P}$) at time $t$, and $N^{P}$ is the number of individuals included in the predictions. For multilevel survival models the calculation is similar and follows quite naturally (details not shown). + +Note however that if $N^{P}$ is not sufficiently large (for example we predict individual survival probabilities using covariate data for just $N^{P} = 2$ individuals) then averaging over their covariate distribution may not be meaningful. Similarly, if we estimated a multilevel survival model and then predicted standardised survival probabilities based on just $N^{P} = 2$ individuals from our sample, the joint distribution of their cluster-specific parameters would likely be a poor representation of the distribution of cluster-specific parameters for the entire sample and population. + +It is therefore better to calculate standardised survival probabilities by setting $N^{P}$ equal to the total number of individuals in the original sample (i.e. $N^{P} = N$. This approach can then also be used for assessing the fit of the survival model in __rstanarm__ (see the \fct{ps_check} function described in Section \ref{sec:implementation}). Posterior predictive draws of the standardised survival probability are evaluated at a series of time points between 0 and $T_{\max}$ using all individuals in the estimation sample and the predicted standardised survival curve is overlaid with the observed Kaplan-Meier survival curve. + +# Implementation + +## Overview + +The __rstanarm__ package is built on top of the __rstan__ R package \citep{Stan:2019}, which is the R interface for Stan. +Models in __rstanarm__ are written in the Stan programming language, translated into C++ code, and then compiled at the time the package is built. This means that for most users -- who install a binary version of __rstanarm__ from the Comprehensive R Archive Network (CRAN) -- the models in __rstanarm__ will be pre-compiled. This is beneficial for users because there is no compilation time either during installation or when they estimate a model. + +## Main modelling function + +Survival models in __rstanarm__ are implemented around the \fct{stan_surv} modelling function. + +The function signature for \fct{stan_surv} is: +/ +<>= +stan_surv(formula, data, basehaz = "ms", basehaz_ops, qnodes = 15, + prior = normal(), prior_intercept = normal(), prior_aux, + prior_smooth = exponential(autoscale = FALSE), + prior_covariance = decov(), prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = 0.95, ...) +@ + +The following provides a brief description of the main features of each of these arguments: + +\begin{itemize} + +\item The `formula` argument accepts objects built around the standard R formula syntax (see \fct{stats::formula}). The left hand side of the formula should be an object returned by the \fct{Surv} function in the __survival__ package \citep{Therneau:2019}. Any random effects structure (for multilevel survival models) can be specified on the right hand side of the formula using the same syntax as the __lme4__ package \citep{Bates:2015} as shown in the example in Section \ref{sec:multilevelmodel}. + +By default, any covariate effects specified in the fixed-effect part of the model `formula` are included under a proportional hazards assumption (for models estimated using a hazard scale formulation) or under the assumption of time-fixed acceleration factors (for models estimated using an AFT formulation). Time-varying effects are specified in the model `formula` by wrapping the covariate name in the \fct{tve} function. For example, if we wanted to estimate a time-varying effect for the covariate \code{sex} then we could specify \code{tve(sex)} in the model formula, e.g. \code{formula = Surv(time, status) ~ tve(sex) + age}. The \fct{tve} function is a special function that only has meaning when used in the `formula` of a model estimated using \fct{stan_surv}. Its functionality is demonstrated in the worked examples in Sections \ref{sec:tvebs} and \ref{sec:tvepw}. + +\item The \code{data} argument accepts an object inheriting the class \class{data.frame}, in other words the usual R data frame. + +\item The choice of parametric baseline hazard (or baseline survival distribution for AFT models) is specified via the \code{basehaz} argument. For the M-spline (\code{"ms"}) and B-spline (\code{"bs"}) models additional options related to the spline degree $\delta$, knot locations $\boldsymbol{k}$, or degrees of freedom $L$ can be specified as a list and passed to the \code{basehaz_ops} argument. For example, specifying \code{basehaz = "ms"} and \code{basehaz_ops = list(degree = 2, knots = c(10,20))} would request a baseline hazard modelled using quadratic M-splines with two internal knots located at $t = 10$ and $t = 20$. + +\item The argument \code{qnodes} is a control argument that allows the user to specify the number of quadrature nodes when quadrature is required (as described in Section \ref{sec:loglikelihood}). + +\item The \code{prior} family of arguments allow the user to specify the prior distributions for each of the parameters, as follows: + + \begin{itemize} + + \item \code{prior} relates to the time-fixed regression coefficients; + + \item \code{prior_intercept} relates to the intercept in the linear predictor; + + \item \code{prior_aux} relates to the so-called "auxiliary" parameters in the baseline hazard ($\gamma$ for the Weibull and Gompertz models or $\boldsymbol{\gamma}$ for the M-spline and B-spline models); + + \item \code{prior_smooth} relates to the hyperparameter $\tau_p$ when the $p^{th}$ covariate has a time-varying effect; and + + \item \code{prior_covariance} relates to the covariance matrix for the random effects when a multilevel survival model is being estimated. + + \end{itemize} + +\item The remaining arguments (\code{prior_PD}, \code{algorithm}, and \code{adapt_delta}) are optional control arguments related to estimation in Stan: + + \begin{itemize} + + \item Setting \code{prior_PD = TRUE} states that the user only wants to draw from the prior predictive distribution and not condition on the data. + + \item The \code{algorithm} argument specifies the estimation routine to use. This includes either Hamiltonian Monte Carlo (\code{"sampling"}) or one of the variational Bayes algorithms (\code{"meanfield"} or \code{"fullrank"}). The model specification is agnostic to the chosen \code{algorithm}. That is, the user can choose from any of the available algorithms regardless of the specified model. + + \item The \code{adapt_delta} argument controls the target average acceptance probability. It is only relevant when \code{algorithm = "sampling"} in which case \code{adapt_delta} should be between 0 and 1, with higher values leading to smaller step sizes and therefore a more robust sampler but longer estimation times. + + \end{itemize} + +\end{itemize} + +The model returned by \fct{stan_surv} is an object of class \class{stansurv} and inheriting the \class{stanreg} class. It is effectively a list with a number of important attributes. There are a range of post-estimation functions that can be called on \class{stansurv} (and \class{stanreg}) objects -- some of the most important ones are described in Section \ref{sec:postest-functions}. + +### Default knot locations + +Default knot locations for the M-spline, B-spline, or piecewise constant functions are the same regardless of whether they are used for modelling the baseline hazard or time-varying effects. By default the vector of knot locations $\boldsymbol{k} = \{k_{1},...,k_{J}\}$ includes a lower boundary knot $k_{1}$ at the earliest entry time (equal to zero if there isn't delayed entry) and an upper boundary knot $k_{J}$ at the latest event or censoring time. The location of the boundary knots cannot be changed by the user. + +Internal knot locations -- that is $k_{2},...,k_{(J-1)}$ when $J \geq 3$ -- can be explicitly specified by the user or are determined by default. The number of internal knots and/or their locations can be controlled via the \code{basehaz_ops} argument to \fct{stan_surv} (for modelling the baseline hazard) or via the arguments to the \fct{tve} function (for modelling a time-varying effect). If knot locations are not explicitly specified by the user, then the default is to place the internal knots at equally spaced percentiles of the distribution of uncensored event times. For instance, if there are three internal knots they would be placed at the $25^{\text{th}}$, $50^{\text{th}}$, and $75^{\text{th}}$ percentiles of the distribution of the uncensored event times. + +## Post-estimation functions + +The __rstanarm__ package provides a range of post-estimation functions that can be used after fitting the survival model. This includes functions for inference (e.g. reporting parameter estimates), diagnostics (e.g. assessing model fit), and generating predictions. We highlight the most important ones here: + +\begin{itemize} + +\item The \fct{print} and \fct{summary} functions provide reports of parameter estimates and some summary information on the data (e.g. number of observations, number of events, etc). They each provide varying levels of detail. For example, the \fct{summary} method provides diagnostic measures such as Gelman and Rubin's Rhat statistic \citep{Gelman:1992} for assessing convergence of the MCMC chains and the number of effective MCMC samples. On the other hand, the \fct{print} method is more concise and does not provide this level of additional detail. + +\item The \fct{fixef} and \fct{ranef} functions report the fixed effect and random effect parameter estimates, respectively. + +\item The \fct{posterior_survfit} function is the primary function for generating survival predictions. The type of prediction is specified via the \code{type} arguments and can currently be any of the following: + + \begin{itemize} + + \item \code{"surv"}: the estimated survival probability; + \item \code{"cumhaz"}: the estimated cumulative hazard; + \item \code{"haz"}: the estimated hazard rate; + \item \code{"cdf"}: the estimated failure probability; + \item \code{"logsurv"}: the estimated log survival probability; + \item \code{"logcumhaz"}: the estimated log cumulative hazard; + \item \code{"loghaz"}: the estimated log hazard rate; or + \item \code{"logcdf"}: the estimated log failure probability. + + \end{itemize} -- a Dirichlet prior is allowed for the M-spline coefficients $\boldsymbol{\gamma}$ -- a half-normal, half-t, half-Cauchy or exponential prior is allowed for the Weibull shape parameter $\gamma$ -- a half-normal, half-t, half-Cauchy or exponential prior is allowed for the Gompertz scale parameter $\gamma$ -- a normal, t, or Cauchy prior is allowed for the B-spline coefficients $\boldsymbol{\gamma}$ +There are additional arguments to \fct{posterior_survfit} that control the time at which the predictions are generated (\code{times}), whether they are generated across a time range (referred to as extrapolation, see \code{extrapolate}), whether they are conditional on a last known survival time (\code{condition}), and whether they are averaged across individuals (referred to as standardised predictions, see \code{standardise}). The returned predictions are a data frame with a special class called \class{survfit.stansurv}. The \class{survfit.stansurv} class has both \fct{print} and \fct{plot} methods that can be called on it. These will be demonstrated as part of the examples in Section \ref{sec:usage}. -These choices are described in greater detail in the `stan_surv` or `priors` help file. +\item The \fct{loo} and \fct{waic} functions report model fit statistics. The former is based on approximate leave-one-out cross validation \citep{Vehtari:2017} and is recommended. The latter is a less preferable alternative that reports the Widely Applicable Information Criterion (WAIC) criterion \citep{Watanabe:2010}. Both of these functions are built on top of the __loo__ R package \citep{Vehtari:2019}. The values (objects) returned by either \fct{loo} or \fct{waic} can also be passed to the \fct{loo_compare} function to compare different models estimated on the same dataset. This will be demonstrated as part of the examples in Section \ref{sec:usage}. -The prior distribution for the intercept parameter in the linear predictor is specified via the `prior_intercept` argument to `stan_surv`. Choices include the normal, t, or Cauchy distributions. The default is a normal distribution with mean zero and scale 20. Note that -- internally (but not in the reported parameter estimates) -- the prior is placed on the intercept *after* centering the predictors at their sample means and *after* applying a constant shift of $\log \left( \frac{E}{T} \right)$ where $E$ is the total number of events and $T$ is the total follow up time. For example, a prior specified by the user as `prior_intercept = normal(0,20)` is in fact not centered on an intercept of zero when all predictors are at their sample means, but rather, it is centered on the log crude event rate when all predictors are at their means. This is intended to help with numerical stability and sampling, but does not impact on the reported estimates (i.e. the intercept is back-transformed before being returned to the user). +\item The \fct{log_lik} function generates a pointwise log likelihood matrix. That is, it calculates the log likelihood for each observation (either in the original dataset or some new dataset) using each MCMC draw of the model parameters. -The choice of prior distribution for the time-fixed coefficients $\theta_{p0}$ ($p = 1,...,P$) is specified via the `prior` argument to `stan_surv`. This can any of the standard prior distributions allowed for regression coefficients in the **rstanarm** package; see the [priors vignette](priors.html) and the `stan_surv` help file for details. +\item The \fct{plot} function allows for a variety of plots depending on the input to the \code{plotfun} argument. The default is to plot the estimated baseline hazard (\code{plotfun = "basehaz"}), but alternatives include a plot of the estimated time-varying hazard ratio for models with time-varying effects (\code{plotfun = "tve"}), plots summarising the parameter estimates (e.g. posterior densities or posterior intervals), and plots providing diagnostics (e.g. MCMC trace plots). -The additional coefficients required for estimating time-varying effects (i.e. the B-spline coefficients or the interval-specific deviations in the piecewise constant function) are given a random walk prior of the form $\theta_{p,1} \sim N(0,1)$ and $\theta_{p,m} \sim N(\theta_{p,m-1},\tau_p)$ for $m = 2,...,M$, where $M$ is the total number of cubic B-spline basis terms. The prior distribution for the hyperparameter $\tau_p$ is specified via the `prior_smooth` argument to `stan_surv`. Lower values of $\tau_p$ lead to a less flexible (i.e. smoother) function. Choices of prior distribution for the hyperparameter $\tau_p$ include an exponential, half-normal, half-t, or half-Cauchy distribution, and these are detailed in the `stan_surv` help file. +\item The \fct{ps_check} function provides a quick diagnostic check for the fitted survival function. It is based on the estimation sample and compares the predicted standardised survival curve to the observed Kaplan-Meier survival curve. +\end{itemize} # Usage examples From 7536bba7c6fc00b287a77b4da86fdc88ec1d5ebb Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 26 Jul 2020 16:48:25 +1000 Subject: [PATCH 191/225] Don't run stan_surv examples on 32 bit --- R/stan_surv.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/stan_surv.R b/R/stan_surv.R index 9d146e040..30a976336 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -337,6 +337,7 @@ #' } #' #' @examples +#' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' \donttest{ #' #----- Proportional hazards #' @@ -449,6 +450,7 @@ #' VarCorr(m_frail) # extract SD explicitly #' #' } +#' } #' stan_surv <- function(formula, data, From f842562111729134fcfa0802eaae795c4f93a86f Mon Sep 17 00:00:00 2001 From: jgabry Date: Wed, 29 Jul 2020 14:27:05 -0600 Subject: [PATCH 192/225] change return type from void to real --- src/stan_files/functions/mvmer_functions.stan | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stan_files/functions/mvmer_functions.stan b/src/stan_files/functions/mvmer_functions.stan index 8edc4d969..19e83f995 100644 --- a/src/stan_files/functions/mvmer_functions.stan +++ b/src/stan_files/functions/mvmer_functions.stan @@ -336,7 +336,7 @@ * @param df Real, df for the prior distribution * @return Nothing */ - void gamma_lp(real gamma, int dist, real mean_, real scale, real df) { + real gamma_lp(real gamma, int dist, real mean_, real scale, real df) { if (dist == 1) // normal target += normal_lpdf(gamma | mean_, scale); else if (dist == 2) // student_t From f931b28089bae2f69f8798ebd7a1e295d8b8e05d Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 9 Aug 2020 14:14:17 +1000 Subject: [PATCH 193/225] Fix docstring when returning target --- src/stan_files/functions/jm_functions.stan | 2 +- src/stan_files/functions/mvmer_functions.stan | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/stan_files/functions/jm_functions.stan b/src/stan_files/functions/jm_functions.stan index f058f1f16..c2a993efb 100644 --- a/src/stan_files/functions/jm_functions.stan +++ b/src/stan_files/functions/jm_functions.stan @@ -28,7 +28,7 @@ * @param dist Integer specifying the type of prior distribution * @param scale Real specifying the scale for the prior distribution * @param df Real specifying the df for the prior distribution - * @return Nothing + * @return lp__ */ real basehaz_lp(vector aux_unscaled, int dist, vector scale, vector df) { if (dist > 0) { diff --git a/src/stan_files/functions/mvmer_functions.stan b/src/stan_files/functions/mvmer_functions.stan index 19e83f995..252f4e1ea 100644 --- a/src/stan_files/functions/mvmer_functions.stan +++ b/src/stan_files/functions/mvmer_functions.stan @@ -236,7 +236,7 @@ * @param prior_dist Integer, the type of prior distribution * @param prior_mean,prior_scale Vectors of mean and scale parameters * for the prior distributions - * @return Nothing + * @return lp__ */ real glm_lp(vector y_real, int[] y_integer, vector eta, real[] aux, int family, int link, real sum_log_y, vector sqrt_y, vector log_y) { @@ -283,7 +283,7 @@ * @param global Real, the global parameter * @param mix Vector of shrinkage parameters * @param one_over_lambda Real - * @return Nothing + * @return lp__ */ real beta_lp(vector z_beta, int prior_dist, vector prior_scale, vector prior_df, real global_prior_df, vector[] local, @@ -334,7 +334,7 @@ * @param mean_ Real, mean of prior distribution * @param scale Real, scale for the prior distribution * @param df Real, df for the prior distribution - * @return Nothing + * @return lp__ */ real gamma_lp(real gamma, int dist, real mean_, real scale, real df) { if (dist == 1) // normal @@ -353,7 +353,7 @@ * @param dist Integer specifying the type of prior distribution * @param scale Real specifying the scale for the prior distribution * @param df Real specifying the df for the prior distribution - * @return Nothing + * @return lp__ */ real aux_lp(real aux_unscaled, int dist, real scale, real df) { if (dist > 0 && scale > 0) { From ff0a22b90cd70828616f73c39fa54ebb68522040 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 9 Aug 2020 14:21:39 +1000 Subject: [PATCH 194/225] Remove redundant assignments in hazard_functions.stan --- .../functions/hazard_functions.stan | 35 +++++-------------- 1 file changed, 9 insertions(+), 26 deletions(-) diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan index 1f0e56524..06de10a5d 100644 --- a/src/stan_files/functions/hazard_functions.stan +++ b/src/stan_files/functions/hazard_functions.stan @@ -27,9 +27,7 @@ * @return A vector */ vector weibull_log_haz(vector eta, vector t, real shape) { - vector[rows(eta)] res; - res = log(shape) + (shape - 1) * log(t) + eta; - return res; + return log(shape) + (shape - 1) * log(t) + eta; } /** @@ -41,9 +39,7 @@ * @return A vector */ vector weibullAFT_log_haz(vector af, vector caf, real shape) { - vector[rows(af)] res; - res = log(shape) + (shape - 1) * log(caf) + log(af); - return res; + return log(shape) + (shape - 1) * log(caf) + log(af); } /** @@ -55,9 +51,7 @@ * @return A vector */ vector gompertz_log_haz(vector eta, vector t, real scale) { - vector[rows(eta)] res; - res = scale * t + eta; - return res; + return scale * t + eta; } /** @@ -69,9 +63,7 @@ * @return A vector */ vector mspline_log_haz(vector eta, matrix basis, vector coefs) { - vector[rows(eta)] res; - res = log(basis * coefs) + eta; - return res; + return log(basis * coefs) + eta; } /** @@ -83,9 +75,7 @@ * @return A vector */ vector bspline_log_haz(vector eta, matrix basis, vector coefs) { - vector[rows(eta)] res; - res = basis * coefs + eta; - return res; + return basis * coefs + eta; } /** @@ -99,9 +89,7 @@ * @return A vector */ real quadrature_log_surv(vector qwts, vector log_hazard) { - real res; - res = - dot_product(qwts, exp(log_hazard)); // sum across all individuals - return res; + return - dot_product(qwts, exp(log_hazard)); // sum across all individuals } vector quadrature_log_cdf(vector qwts, vector log_hazard, int qnodes, int N) { @@ -110,9 +98,7 @@ matrix[N,qnodes] qwts_mat = to_matrix(qwts, N, qnodes); matrix[N,qnodes] haz_mat = to_matrix(hazard, N, qnodes); vector[N] chaz = rows_dot_product(qwts_mat, haz_mat); - vector[N] res; - res = log(1 - exp(- chaz)); - return res; + return log(1 - exp(- chaz)); } vector quadrature_log_cdf2(vector qwts_lower, vector log_hazard_lower, @@ -129,9 +115,7 @@ vector[N] chaz_upper = rows_dot_product(qwts_upper_mat, haz_upper_mat); vector[N] surv_lower = exp(- chaz_lower); vector[N] surv_upper = exp(- chaz_upper); - vector[N] res; - res = log(surv_lower - surv_upper); - return res; + return log(surv_lower - surv_upper); } @@ -150,6 +134,5 @@ vector[M] af = exp(-eta); // time-varying acceleration factor matrix[N,qnodes] qwts_mat = to_matrix(qwts, N, qnodes); matrix[N,qnodes] af_mat = to_matrix(af, N, qnodes); - vector[N] caf = rows_dot_product(qwts_mat, af_mat); - return caf; // cumulative acceleration factor + return rows_dot_product(qwts_mat, af_mat); // cumulative acceleration factor } From 99eea89f235db64fb3ca72a23ed4204715f2ca71 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 9 Aug 2020 15:33:42 +1000 Subject: [PATCH 195/225] Catch some undesirable inputs that were being absorbed in dots (i.e. extra args) Closes #458 --- R/posterior_survfit.R | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/R/posterior_survfit.R b/R/posterior_survfit.R index 7d4faaff2..2894955f6 100644 --- a/R/posterior_survfit.R +++ b/R/posterior_survfit.R @@ -392,6 +392,15 @@ posterior_survfit.stansurv <- function(object, dots <- list(...) + if ("newdataEvent" %in% names(dots)) + stop("The argument 'newdataEvent' should not be specified when ", + "predicting for stan_surv models. Perhaps you meant to specify ", + "'newdata' instead of 'newdataEvent'.") + + if ("newdataLong" %in% names(dots)) + stop("The argument 'newdataLong' should not be specified when ", + "predicting for stan_surv models.") + newdata <- validate_newdata(object, newdata = newdata) has_newdata <- not.null(newdata) @@ -586,6 +595,11 @@ posterior_survfit.stanjm <- function(object, dots <- list(...) + if ("newdata" %in% names(dots)) + stop("The argument 'newdata' should not be specified when predicting ", + "for stan_jm models. You should specify 'newdataLong' and ", + "'newdataEvent' instead of 'newdata'.") + # Temporarily only allow survprob for stan_jm until refactoring is done if (!type == "surv") stop("Currently only 'type = \"surv\"' is allowed for stanjm models.") From d8fea177ddc95671bfb8d8be7060b44c0de839cb Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 9 Aug 2020 15:53:13 +1000 Subject: [PATCH 196/225] Include stansurv objects in is.mer function --- R/misc.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/misc.R b/R/misc.R index 24e53576a..6370b4a7b 100644 --- a/R/misc.R +++ b/R/misc.R @@ -195,9 +195,12 @@ used.variational <- function(x) { # @param x A stanreg object. is.mer <- function(x) { stopifnot(is.stanreg(x)) + check0 <- is.stansurv(x) && x$has_bars check1 <- inherits(x, "lmerMod") check2 <- !is.null(x$glmod) - if (check1 && !check2) { + if (check0) { + return(TRUE) + } else if (check1 && !check2) { stop("Bug found. 'x' has class 'lmerMod' but no 'glmod' component.") } else if (!check1 && check2) { stop("Bug found. 'x' has 'glmod' component but not class 'lmerMod'.") From 02cc50565d470cf71fce7d85db9aea36c3c3f9c0 Mon Sep 17 00:00:00 2001 From: Jacqueline Buros Date: Thu, 17 Jun 2021 16:19:52 -0400 Subject: [PATCH 197/225] Reverse order of tests to address stan-dev/rstanarm#535 --- R/stanreg-methods.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stanreg-methods.R b/R/stanreg-methods.R index 942a1979b..4abfd8284 100644 --- a/R/stanreg-methods.R +++ b/R/stanreg-methods.R @@ -439,10 +439,10 @@ model.matrix.stanreg <- function(object, ...) { #' 'tve(varname)' terms in the model formula are returned as 'varname'. #' formula.stanreg <- function(x, ..., m = NULL) { - if (is.mer(x) && !isTRUE(x$stan_function == "stan_gamm4")) - return(formula_mer(x, ...)) if (is.surv(x)) return(formula_surv(x, ...)) + if (is.mer(x) && !isTRUE(x$stan_function == "stan_gamm4")) + return(formula_mer(x, ...)) x$formula } From 52260d9ac9e5dac7607b9fed2c829e5d9aebbcc2 Mon Sep 17 00:00:00 2001 From: Jacqueline Buros Date: Fri, 18 Jun 2021 12:59:35 -0400 Subject: [PATCH 198/225] update terms as well --- R/stanreg-methods.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/stanreg-methods.R b/R/stanreg-methods.R index 4abfd8284..9298b7f32 100644 --- a/R/stanreg-methods.R +++ b/R/stanreg-methods.R @@ -399,6 +399,9 @@ family.stanreg <- function(object, ...) object$family #' @param fixed.only See \code{\link[lme4:merMod-class]{model.frame.merMod}}. #' model.frame.stanreg <- function(formula, fixed.only = FALSE, ...) { + if (is.stansurv(formula)) { + return(formula$model_frame) + } if (is.mer(formula)) { fr <- formula$glmod$fr if (fixed.only) { @@ -408,9 +411,6 @@ model.frame.stanreg <- function(formula, fixed.only = FALSE, ...) { } return(fr) } - if (is.stansurv(formula)) { - return(formula$model_frame) - } NextMethod("model.frame") } From 8f07554c30e6f529c02280ce8f882236b1ffddce Mon Sep 17 00:00:00 2001 From: Jacqueline Buros Date: Sun, 20 Jun 2021 23:32:01 -0400 Subject: [PATCH 199/225] reverse order of checks per #535 --- R/pp_data.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index c93b33589..dd9ea44fa 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -24,6 +24,9 @@ pp_data <- m = NULL, ...) { validate_stanreg_object(object) + if (is.stansurv(object)) { + return(.pp_data_surv(object, newdata = newdata, ...)) + } if (is.mer(object)) { if (is.nlmer(object)) out <- .pp_data_nlmer(object, newdata = newdata, re.form = re.form, m = m, ...) @@ -32,9 +35,6 @@ pp_data <- if (!is.null(offset)) out$offset <- offset return(out) } - if (is.stansurv(object)) { - return(.pp_data_surv(object, newdata = newdata, ...)) - } .pp_data(object, newdata = newdata, offset = offset, ...) } From af555ab1c21221b9db504f5dc9b4ed3097e09704 Mon Sep 17 00:00:00 2001 From: Jacqueline Buros Date: Mon, 21 Jun 2021 03:13:25 -0400 Subject: [PATCH 200/225] Add some more checks for is.surv --- R/stanreg-methods.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stanreg-methods.R b/R/stanreg-methods.R index 9298b7f32..b4c0d140a 100644 --- a/R/stanreg-methods.R +++ b/R/stanreg-methods.R @@ -90,7 +90,7 @@ NULL #' @rdname stanreg-methods #' @export coef.stanreg <- function(object, ...) { - if (is.mer(object)) + if (is.mer(object) && !is.surv(object)) return(coef_mer(object, ...)) object$coefficients @@ -423,7 +423,7 @@ model.frame.stanreg <- function(formula, fixed.only = FALSE, ...) { #' model.matrix.stanreg <- function(object, ...) { if (inherits(object, "gamm4")) return(object$jam$X) - if (is.mer(object)) return(object$glmod$X) + if (is.mer(object) && !is.surv(object)) return(object$glmod$X) NextMethod("model.matrix") } From 29716846cef6ba452df4c623781f590040767993 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 3 Aug 2022 23:33:50 +1000 Subject: [PATCH 201/225] Fix up the overlapping test helper functions --- tests/testthat/helper.R | 68 +++++++++++++++++++- tests/testthat/helpers/expect_survfit_jm.R | 1 - tests/testthat/helpers/expect_survfit_surv.R | 1 - tests/testthat/helpers/get_tols_jm.R | 67 ------------------- tests/testthat/helpers/get_tols_surv.R | 29 --------- tests/testthat/helpers/recover_pars_jm.R | 35 ---------- tests/testthat/helpers/recover_pars_surv.R | 31 --------- tests/testthat/test_stan_jm.R | 12 ++-- tests/testthat/test_stan_mvmer.R | 6 +- tests/testthat/test_stan_surv.R | 34 ++++------ 10 files changed, 87 insertions(+), 197 deletions(-) delete mode 100644 tests/testthat/helpers/expect_survfit_jm.R delete mode 100644 tests/testthat/helpers/expect_survfit_surv.R delete mode 100644 tests/testthat/helpers/get_tols_jm.R delete mode 100644 tests/testthat/helpers/get_tols_surv.R delete mode 100644 tests/testthat/helpers/recover_pars_jm.R delete mode 100644 tests/testthat/helpers/recover_pars_surv.R diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 18d409528..7842f498f 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -109,7 +109,8 @@ expect_ppd <- function(x) { expect_stanreg <- function(x) expect_s3_class(x, "stanreg") expect_stanmvreg <- function(x) expect_s3_class(x, "stanmvreg") -expect_survfit <- function(x) expect_s3_class(x, "survfit.stanjm") +expect_survfit_jm <- function(x) expect_s3_class(x, "survfit.stanjm") +expect_survfit_surv <- function(x) expect_s3_class(x, "survfit.stansurv") # Use the standard errors from a fitted 'comparison model' to obtain # the tolerance for each parameter in the joint model @@ -128,7 +129,7 @@ expect_survfit <- function(x) expect_s3_class(x, "survfit.stanjm") # @param idvar The name of the ID variable. Used to extract the SDs for # group-specific terms that correspond to the individual/patient. # -get_tols <- function(modLong, modEvent = NULL, tolscales, idvar = "id") { +get_tols_jm <- function(modLong, modEvent = NULL, tolscales, idvar = "id") { if (is.null(modEvent)) modEvent <- modLong # if modLong is already a joint model @@ -179,6 +180,36 @@ get_tols <- function(modLong, modEvent = NULL, tolscales, idvar = "id") { return(ret) } +# Use the standard errors from a fitted 'comparison model' to obtain +# the tolerance for each parameter in the joint model +# Obtain parameter specific tolerances that can be used to assess the +# accuracy of parameter estimates in stan_jm models. The tolerances +# are calculated by taking the SE/SD for the parameter estimate in a +# "gold standard" model and multiplying this by the relevant element +# in the 'tolscales' argument. +# +# @param mod The "gold standard" longitudinal model. Likely to be +# a model estimated using coxph. +# @param toscales A named list with elements 'hr_fixef' and 'tve_fixef'. +# +get_tols_surv <- function(mod, tolscales) { + + cl <- class(mod)[1L] + + if (cl %in% c("coxph", "survreg")) { + fixef_ses <- sqrt(diag(mod$var))[1:length(mod$coefficients)] + fixef_tols <- tolscales$hr_fixef * fixef_ses + names(fixef_tols) <- names(mod$coefficients) + } + + if ("(Intercept)" %in% names(fixef_tols)) + fixef_tols[["(Intercept)"]] <- 2 * fixef_tols[["(Intercept)"]] + + ret <- Filter(function(x) !is.null(x), list(fixef = fixef_tols)) + + return(ret) +} + # Recover parameter estimates and return a list with consistent # parameter names for comparing stan_jm, stan_mvmer, stan_{g}lmer, # {g}lmer, and coxph estimates @@ -190,7 +221,7 @@ get_tols <- function(modLong, modEvent = NULL, tolscales, idvar = "id") { # @param idvar The name of the ID variable. Used to extract the estimates # for group-specific parameters that correspond to the individual/patient. # -recover_pars <- function(modLong, modEvent = NULL, idvar = "id") { +recover_pars_jm <- function(modLong, modEvent = NULL, idvar = "id") { if (is.null(modEvent)) modEvent <- modLong @@ -215,3 +246,34 @@ recover_pars <- function(modLong, modEvent = NULL, idvar = "id") { return(ret) } +# Recover parameter estimates and return a list with consistent +# parameter names for comparing stan_surv and coxph estimates +# +# @param mod The fitted survival model. Likely to be a model estimated +# using either coxph or stan_surv. +# +recover_pars_surv <- function(mod) { + + cl <- class(mod)[1L] + + fixef_pars <- switch(cl, + "coxph" = mod$coefficients, + "survreg" = mod$coefficients, + "stansurv" = fixef(mod), + NULL) + + if (cl == "stansurv") { + sel <- grep(":tve-[a-z][a-z]-coef[0-9]*$", names(fixef_pars)) + # replace stansurv tve names with coxph tt names + if (length(sel)) { + nms <- names(fixef_pars)[sel] + nms <- gsub(":tve-[a-z][a-z]-coef[0-9]*$", "", nms) + nms <- paste0("tt(", nms, ")") + names(fixef_pars)[sel] <- nms + } + } + + ret <- Filter(function(x) !is.null(x), list(fixef = fixef_pars)) + + return(ret) +} diff --git a/tests/testthat/helpers/expect_survfit_jm.R b/tests/testthat/helpers/expect_survfit_jm.R deleted file mode 100644 index 1b661489f..000000000 --- a/tests/testthat/helpers/expect_survfit_jm.R +++ /dev/null @@ -1 +0,0 @@ -expect_survfit <- function(x) expect_s3_class(x, "survfit.stanjm") diff --git a/tests/testthat/helpers/expect_survfit_surv.R b/tests/testthat/helpers/expect_survfit_surv.R deleted file mode 100644 index 258c10c2c..000000000 --- a/tests/testthat/helpers/expect_survfit_surv.R +++ /dev/null @@ -1 +0,0 @@ -expect_survfit <- function(x) expect_s3_class(x, "survfit.stansurv") diff --git a/tests/testthat/helpers/get_tols_jm.R b/tests/testthat/helpers/get_tols_jm.R deleted file mode 100644 index fb61090a0..000000000 --- a/tests/testthat/helpers/get_tols_jm.R +++ /dev/null @@ -1,67 +0,0 @@ -# Use the standard errors from a fitted 'comparison model' to obtain -# the tolerance for each parameter in the joint model -# Obtain parameter specific tolerances that can be used to assess the -# accuracy of parameter estimates in stan_jm models. The tolerances -# are calculated by taking the SE/SD for the parameter estimate in a -# "gold standard" model and multiplying this by the relevant element -# in the 'tolscales' argument. -# -# @param modLong The "gold standard" longitudinal model. Likely to be -# a model estimated using either {g}lmer or stan_{g}lmer. -# @param modEvent The "gold standard" event model. Likely to be a model -# estimated using coxph. -# @param toscales A named list with elements $lmer_fixef, $lmer_ranef, -# $glmer_fixef, $glmer_ranef, $event. -# @param idvar The name of the ID variable. Used to extract the SDs for -# group-specific terms that correspond to the individual/patient. -# -get_tols <- function(modLong, modEvent = NULL, tolscales, idvar = "id") { - - if (is.null(modEvent)) - modEvent <- modLong # if modLong is already a joint model - - if (class(modLong)[1] == "stanreg") { - fixef_nms <- names(fixef(modLong)) - fixef_ses <- modLong$ses[fixef_nms] - ranef_sds <- attr(VarCorr(modLong)[[idvar]], "stddev") - if (modLong$stan_function == "stan_lmer") { - fixef_tols <- tolscales$lmer_fixef * fixef_ses - ranef_tols <- tolscales$lmer_ranef * ranef_sds - } else if (modLong$stan_function == "stan_glmer") { - if (modLong$family$family == "gaussian") { - fixef_tols <- tolscales$lmer_fixef * fixef_ses - ranef_tols <- tolscales$lmer_ranef * ranef_sds - } else { - fixef_tols <- tolscales$glmer_fixef * fixef_ses - ranef_tols <- tolscales$glmer_ranef * ranef_sds - } - } - } else if (class(modLong)[1] %in% c("lmerMod", "glmerMod")) { - fixef_ses <- sqrt(diag(vcov(modLong))) - ranef_sds <- attr(VarCorr(modLong)[[idvar]], "stddev") - if (class(modLong)[1] == "lmerMod") { - fixef_tols <- tolscales$lmer_fixef * fixef_ses - ranef_tols <- tolscales$lmer_ranef * ranef_sds - } else if (class(modLong)[1] == "glmerMod") { - fixef_tols <- tolscales$glmer_fixef * fixef_ses - ranef_tols <- tolscales$glmer_ranef * ranef_sds - } - } - if ("(Intercept)" %in% names(fixef_tols)) - fixef_tols[["(Intercept)"]] <- 2 * fixef_tols[["(Intercept)"]] - if ("(Intercept)" %in% names(ranef_tols)) - ranef_tols[["(Intercept)"]] <- 2 * ranef_tols[["(Intercept)"]] - - if (class(modEvent)[1] == "coxph") { - event_ses <- summary(modEvent)$coefficients[, "se(coef)"] - } else event_ses <- NULL - event_tols <- if (!is.null(event_ses)) - tolscales$event * event_ses else NULL - if ("(Intercept)" %in% names(event_tols)) - event_tols[["(Intercept)"]] <- 2 * event_tols[["(Intercept)"]] - - ret <- Filter( - function(x) !is.null(x), - list(fixef = fixef_tols, ranef = ranef_tols, event = event_tols)) - return(ret) -} diff --git a/tests/testthat/helpers/get_tols_surv.R b/tests/testthat/helpers/get_tols_surv.R deleted file mode 100644 index 7c99b208c..000000000 --- a/tests/testthat/helpers/get_tols_surv.R +++ /dev/null @@ -1,29 +0,0 @@ -# Use the standard errors from a fitted 'comparison model' to obtain -# the tolerance for each parameter in the joint model -# Obtain parameter specific tolerances that can be used to assess the -# accuracy of parameter estimates in stan_jm models. The tolerances -# are calculated by taking the SE/SD for the parameter estimate in a -# "gold standard" model and multiplying this by the relevant element -# in the 'tolscales' argument. -# -# @param mod The "gold standard" longitudinal model. Likely to be -# a model estimated using coxph. -# @param toscales A named list with elements 'hr_fixef' and 'tve_fixef'. -# -get_tols <- function(mod, tolscales) { - - cl <- class(mod)[1L] - - if (cl %in% c("coxph", "survreg")) { - fixef_ses <- sqrt(diag(mod$var))[1:length(mod$coefficients)] - fixef_tols <- tolscales$hr_fixef * fixef_ses - names(fixef_tols) <- names(mod$coefficients) - } - - if ("(Intercept)" %in% names(fixef_tols)) - fixef_tols[["(Intercept)"]] <- 2 * fixef_tols[["(Intercept)"]] - - ret <- Filter(function(x) !is.null(x), list(fixef = fixef_tols)) - - return(ret) -} diff --git a/tests/testthat/helpers/recover_pars_jm.R b/tests/testthat/helpers/recover_pars_jm.R deleted file mode 100644 index fb9bfd376..000000000 --- a/tests/testthat/helpers/recover_pars_jm.R +++ /dev/null @@ -1,35 +0,0 @@ -# Recover parameter estimates and return a list with consistent -# parameter names for comparing stan_jm, stan_mvmer, stan_{g}lmer, -# {g}lmer, and coxph estimates -# -# @param modLong The fitted longitudinal model. Likely to be -# a model estimated using either {g}lmer or stan_{g}lmer. -# @param modEvent The fitted event model. Likely to be a model -# estimated using coxph. -# @param idvar The name of the ID variable. Used to extract the estimates -# for group-specific parameters that correspond to the individual/patient. -# -recover_pars <- function(modLong, modEvent = NULL, idvar = "id") { - - if (is.null(modEvent)) - modEvent <- modLong - - if (class(modLong)[1] %in% c("stanreg", "lmerMod", "glmerMod")) { - fixef_pars <- fixef(modLong) - ranef_pars <- ranef(modLong)[[idvar]] - } else if (class(modLong)[1] %in% c("stanjm", "stanmvreg")) { - fixef_pars <- fixef(modLong)[[1L]] - ranef_pars <- ranef(modLong)[[1L]][[idvar]] - } - - if (class(modEvent)[1] == "coxph") { - event_pars <- modEvent$coefficients - } else if (class(modEvent)[1] %in% c("stanjm", "stanmvreg")) { - event_pars <- fixef(modEvent)$Event - } else event_pars <- NULL - - ret <- Filter( - function(x) !is.null(x), - list(fixef = fixef_pars, ranef = ranef_pars, event = event_pars)) - return(ret) -} diff --git a/tests/testthat/helpers/recover_pars_surv.R b/tests/testthat/helpers/recover_pars_surv.R deleted file mode 100644 index ea93bff2b..000000000 --- a/tests/testthat/helpers/recover_pars_surv.R +++ /dev/null @@ -1,31 +0,0 @@ -# Recover parameter estimates and return a list with consistent -# parameter names for comparing stan_surv and coxph estimates -# -# @param mod The fitted survival model. Likely to be a model estimated -# using either coxph or stan_surv. -# -recover_pars <- function(mod) { - - cl <- class(mod)[1L] - - fixef_pars <- switch(cl, - "coxph" = mod$coefficients, - "survreg" = mod$coefficients, - "stansurv" = fixef(mod), - NULL) - - if (cl == "stansurv") { - sel <- grep(":tve-[a-z][a-z]-coef[0-9]*$", names(fixef_pars)) - # replace stansurv tve names with coxph tt names - if (length(sel)) { - nms <- names(fixef_pars)[sel] - nms <- gsub(":tve-[a-z][a-z]-coef[0-9]*$", "", nms) - nms <- paste0("tt(", nms, ")") - names(fixef_pars)[sel] <- nms - } - } - - ret <- Filter(function(x) !is.null(x), list(fixef = fixef_pars)) - - return(ret) -} diff --git a/tests/testthat/test_stan_jm.R b/tests/testthat/test_stan_jm.R index fa6574b98..6d00224e3 100644 --- a/tests/testthat/test_stan_jm.R +++ b/tests/testthat/test_stan_jm.R @@ -352,9 +352,9 @@ compare_glmer <- function(fmLong, fam = gaussian, ...) { s1 <- coxph(fmSurv, data = pbcSurv) j1 <- stan_jm(fmLong, pbcLong, fmSurv, pbcSurv, time_var = "year", family = fam, assoc = NULL, iter = 1000, chains = CHAINS, seed = SEED, ...) - tols <- get_tols(y1, s1, tolscales = TOLSCALES) - pars <- recover_pars(y1, s1) - parsjm <- recover_pars(j1) + tols <- get_tols_jm(y1, s1, tolscales = TOLSCALES) + pars <- recover_pars_jm(y1, s1) + parsjm <- recover_pars_jm(j1) for (i in names(tols$fixef)) expect_equal(pars$fixef[[i]], parsjm$fixef[[i]], tol = tols$fixef[[i]], info = fam) for (i in names(tols$ranef)) @@ -549,17 +549,17 @@ for (j in c(1:30)) { test_that("posterior_survfit works with estimation data", { SW(ps <- posterior_survfit(mod)) - expect_survfit(ps) + expect_survfit_jm(ps) }) test_that("posterior_survfit works with new data (one individual)", { SW(ps <- posterior_survfit(mod, newdataLong = ndL1, newdataEvent = ndE1)) - expect_survfit(ps) + expect_survfit_jm(ps) }) test_that("posterior_survfit works with new data (multiple individuals)", { SW(ps <- posterior_survfit(mod, newdataLong = ndL2, newdataEvent = ndE2)) - expect_survfit(ps) + expect_survfit_jm(ps) }) } } diff --git a/tests/testthat/test_stan_mvmer.R b/tests/testthat/test_stan_mvmer.R index 5dc3c9053..931ae4138 100644 --- a/tests/testthat/test_stan_mvmer.R +++ b/tests/testthat/test_stan_mvmer.R @@ -165,9 +165,9 @@ if (interactive()) { compare_glmer <- function(fmLong, fam = gaussian, ...) { SW(y1 <- stan_glmer(fmLong, pbcLong, fam, iter = 1000, chains = CHAINS, seed = SEED, refresh = 0)) SW(y2 <- stan_mvmer(fmLong, pbcLong, fam, iter = 1000, chains = CHAINS, seed = SEED, ..., refresh = 0)) - tols <- get_tols(y1, tolscales = TOLSCALES) - pars <- recover_pars(y1) - pars2 <- recover_pars(y2) + tols <- get_tols_jm(y1, tolscales = TOLSCALES) + pars <- recover_pars_jm(y1) + pars2 <- recover_pars_jm(y2) for (i in names(tols$fixef)) expect_equal(pars$fixef[[i]], pars2$fixef[[i]], tol = tols$fixef[[i]]) for (i in names(tols$ranef)) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index a8a93a57e..380ad7ddc 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -34,15 +34,7 @@ TOLSCALES <- list( hr_fixef = 0.5 # how many SEs can stan_surv HRs be from coxph/stpm2 HRs ) -source(test_path("helpers", "expect_matrix.R")) -source(test_path("helpers", "expect_stanreg.R")) -source(test_path("helpers", "expect_stanmvreg.R")) -source(test_path("helpers", "expect_survfit_surv.R")) -source(test_path("helpers", "expect_ppd.R")) -source(test_path("helpers", "expect_equivalent_loo.R")) -source(test_path("helpers", "get_tols_surv.R")) -source(test_path("helpers", "recover_pars_surv.R")) -source(test_path("helpers", "SW.R")) +content("stan_surv") eo <- function(...) { expect_output (...) } ee <- function(...) { expect_error (...) } @@ -269,17 +261,17 @@ for (j in c(1:33)) { if (mod$ndelayed == 0) # only test if no delayed entry test_that("posterior_survfit works with estimation data", { SW(ps <- posterior_survfit(mod)) - expect_survfit(ps) + expect_survfit_surv(ps) }) test_that("posterior_survfit works with new data (one individual)", { SW(ps <- posterior_survfit(mod, newdata = nd1)) - expect_survfit(ps) + expect_survfit_surv(ps) }) test_that("posterior_survfit works with new data (multiple individuals)", { SW(ps <- posterior_survfit(mod, newdata = nd2)) - expect_survfit(ps) + expect_survfit_surv(ps) }) } @@ -405,9 +397,9 @@ compare_surv <- function(data, basehaz = "weibull", ...) { refresh = REFRESH, chains = CHAINS, seed = SEED, ...) - tols <- get_tols(surv1, tolscales = TOLSCALES) - pars_surv <- recover_pars(surv1) - pars_stan <- recover_pars(stan1) + tols <- get_tols_surv(surv1, tolscales = TOLSCALES) + pars_surv <- recover_pars_surv(surv1) + pars_stan <- recover_pars_surv(stan1) for (i in names(tols$fixef)) expect_equal(pars_surv$fixef[[i]], pars_stan$fixef[[i]], @@ -478,9 +470,9 @@ compare_surv <- function(data, basehaz = "weibull-aft", ...) { chains = CHAINS, seed = SEED, ...) - tols <- get_tols(surv1, tolscales = TOLSCALES) - pars_surv <- recover_pars(surv1) - pars_stan <- recover_pars(stan1) + tols <- get_tols_surv(surv1, tolscales = TOLSCALES) + pars_surv <- recover_pars_surv(surv1) + pars_stan <- recover_pars_surv(stan1) for (i in names(tols$fixef)) expect_equal(pars_surv$fixef[[i]], pars_stan$fixef[[i]], @@ -552,10 +544,10 @@ o<-SW(stan1 <- stan_surv( refresh = REFRESH, iter = ITER)) -tols <- get_tols(surv1, tolscales = TOLSCALES) +tols <- get_tols_surv(surv1, tolscales = TOLSCALES) -pars_surv <- recover_pars(surv1) -pars_stan <- recover_pars(stan1) +pars_surv <- recover_pars_surv(surv1) +pars_stan <- recover_pars_surv(stan1) for (i in names(tols$fixef)) expect_equal(pars_surv$fixef[[i]], From 43b0796a2259165458dd9f5e0cbaf35853f7c3fd Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Thu, 4 Aug 2022 00:08:43 +1000 Subject: [PATCH 202/225] Remove reference to csr_matrix_times_vector2 --- src/stan_files/surv.stan | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 58dd3da82..2b7defed3 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -839,15 +839,15 @@ model { } else { if (nevent > 0) eta_event += - csr_matrix_times_vector2(nevent, q, w_event, v_event, u_event, b); + csr_matrix_times_vector(nevent, q, w_event, v_event, u_event, b); if (nlcens > 0) eta_lcens += - csr_matrix_times_vector2(nlcens, q, w_lcens, v_lcens, u_lcens, b); + csr_matrix_times_vector(nlcens, q, w_lcens, v_lcens, u_lcens, b); if (nrcens > 0) eta_rcens += - csr_matrix_times_vector2(nrcens, q, w_rcens, v_rcens, u_rcens, b); + csr_matrix_times_vector(nrcens, q, w_rcens, v_rcens, u_rcens, b); if (nicens > 0) eta_icens += - csr_matrix_times_vector2(nicens, q, w_icens, v_icens, u_icens, b); + csr_matrix_times_vector(nicens, q, w_icens, v_icens, u_icens, b); if (ndelay > 0) eta_delay += - csr_matrix_times_vector2(ndelay, q, w_delay, v_delay, u_delay, b); + csr_matrix_times_vector(ndelay, q, w_delay, v_delay, u_delay, b); } } @@ -1006,19 +1006,19 @@ model { } else { if (Nevent > 0) eta_epts_event += - csr_matrix_times_vector2(Nevent, q, w_epts_event, v_epts_event, u_epts_event, b); + csr_matrix_times_vector(Nevent, q, w_epts_event, v_epts_event, u_epts_event, b); if (qevent > 0) eta_qpts_event += - csr_matrix_times_vector2(qevent, q, w_qpts_event, v_qpts_event, u_qpts_event, b); + csr_matrix_times_vector(qevent, q, w_qpts_event, v_qpts_event, u_qpts_event, b); if (qlcens > 0) eta_qpts_lcens += - csr_matrix_times_vector2(qlcens, q, w_qpts_lcens, v_qpts_lcens, u_qpts_lcens, b); + csr_matrix_times_vector(qlcens, q, w_qpts_lcens, v_qpts_lcens, u_qpts_lcens, b); if (qrcens > 0) eta_qpts_rcens += - csr_matrix_times_vector2(qrcens, q, w_qpts_rcens, v_qpts_rcens, u_qpts_rcens, b); + csr_matrix_times_vector(qrcens, q, w_qpts_rcens, v_qpts_rcens, u_qpts_rcens, b); if (qicens > 0) eta_qpts_icenl += - csr_matrix_times_vector2(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); + csr_matrix_times_vector(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); if (qicens > 0) eta_qpts_icenu += - csr_matrix_times_vector2(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); + csr_matrix_times_vector(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); if (qdelay > 0) eta_qpts_delay += - csr_matrix_times_vector2(qdelay, q, w_qpts_delay, v_qpts_delay, u_qpts_delay, b); + csr_matrix_times_vector(qdelay, q, w_qpts_delay, v_qpts_delay, u_qpts_delay, b); } } From f9047a095f00a2f3d1d0420059dcf52842ad3c42 Mon Sep 17 00:00:00 2001 From: Ben Goodrich Date: Tue, 7 Feb 2023 10:42:13 -0500 Subject: [PATCH 203/225] csr_matrix_times_vector2 -> csr_matrix_times_vector --- src/stan_files/surv.stan | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 58dd3da82..2b7defed3 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -839,15 +839,15 @@ model { } else { if (nevent > 0) eta_event += - csr_matrix_times_vector2(nevent, q, w_event, v_event, u_event, b); + csr_matrix_times_vector(nevent, q, w_event, v_event, u_event, b); if (nlcens > 0) eta_lcens += - csr_matrix_times_vector2(nlcens, q, w_lcens, v_lcens, u_lcens, b); + csr_matrix_times_vector(nlcens, q, w_lcens, v_lcens, u_lcens, b); if (nrcens > 0) eta_rcens += - csr_matrix_times_vector2(nrcens, q, w_rcens, v_rcens, u_rcens, b); + csr_matrix_times_vector(nrcens, q, w_rcens, v_rcens, u_rcens, b); if (nicens > 0) eta_icens += - csr_matrix_times_vector2(nicens, q, w_icens, v_icens, u_icens, b); + csr_matrix_times_vector(nicens, q, w_icens, v_icens, u_icens, b); if (ndelay > 0) eta_delay += - csr_matrix_times_vector2(ndelay, q, w_delay, v_delay, u_delay, b); + csr_matrix_times_vector(ndelay, q, w_delay, v_delay, u_delay, b); } } @@ -1006,19 +1006,19 @@ model { } else { if (Nevent > 0) eta_epts_event += - csr_matrix_times_vector2(Nevent, q, w_epts_event, v_epts_event, u_epts_event, b); + csr_matrix_times_vector(Nevent, q, w_epts_event, v_epts_event, u_epts_event, b); if (qevent > 0) eta_qpts_event += - csr_matrix_times_vector2(qevent, q, w_qpts_event, v_qpts_event, u_qpts_event, b); + csr_matrix_times_vector(qevent, q, w_qpts_event, v_qpts_event, u_qpts_event, b); if (qlcens > 0) eta_qpts_lcens += - csr_matrix_times_vector2(qlcens, q, w_qpts_lcens, v_qpts_lcens, u_qpts_lcens, b); + csr_matrix_times_vector(qlcens, q, w_qpts_lcens, v_qpts_lcens, u_qpts_lcens, b); if (qrcens > 0) eta_qpts_rcens += - csr_matrix_times_vector2(qrcens, q, w_qpts_rcens, v_qpts_rcens, u_qpts_rcens, b); + csr_matrix_times_vector(qrcens, q, w_qpts_rcens, v_qpts_rcens, u_qpts_rcens, b); if (qicens > 0) eta_qpts_icenl += - csr_matrix_times_vector2(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); + csr_matrix_times_vector(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); if (qicens > 0) eta_qpts_icenu += - csr_matrix_times_vector2(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); + csr_matrix_times_vector(qicens, q, w_qpts_icens, v_qpts_icens, u_qpts_icens, b); if (qdelay > 0) eta_qpts_delay += - csr_matrix_times_vector2(qdelay, q, w_qpts_delay, v_qpts_delay, u_qpts_delay, b); + csr_matrix_times_vector(qdelay, q, w_qpts_delay, v_qpts_delay, u_qpts_delay, b); } } From f2d158d0b3bf8f2bd220e7bad0166b17909b8ee5 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 9 Jul 2023 15:46:35 +1000 Subject: [PATCH 204/225] Use | instead of || for or condition Changes introduced in R>=4.3 mean that the `||` operator returns an error when it is used to evaluate an or condition for a length > 1 vector. The fix here is to use the vectorised form - `|` - instead (which probably should have been used in the first place...). --- R/stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 30a976336..91fd80b2d 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -515,7 +515,7 @@ stan_surv <- function(formula, if (any(is.na(status))) stop2("Invalid status indicator in Surv object.") - if (any(status < 0 || status > 3)) + if (any(status < 0 | status > 3)) stop2("Invalid status indicator in Surv object.") # delayed entry indicator for each row of data @@ -1793,7 +1793,7 @@ parse_formula_and_data <- function(formula, data) { if (any(is.na(status))) stop2("Invalid status indicator in Surv object.") - if (any(status < 0 || status > 3)) + if (any(status < 0 | status > 3)) stop2("Invalid status indicator in Surv object.") # deal with tve(x, ...) From d95d9eef255ec1a2684373cd0bc35f5cfcbdb87b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 30 Oct 2023 22:00:51 +1100 Subject: [PATCH 205/225] Run R cmd check from dev branch --- .github/workflows/R-CMD-check.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 1adf545cd..8999a6da1 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -4,6 +4,7 @@ on: push: branches: - master + - survival_2_26_1 pull_request: branches: - master From 228cae3f4c5fbe8f373cfd553acabe9e73c5994b Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 30 Oct 2023 23:32:16 +1100 Subject: [PATCH 206/225] Ensure functions don't modify target --- src/stan_files/surv.stan | 116 ++++++++++++++++++++------------------- 1 file changed, 60 insertions(+), 56 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 2b7defed3..a4158e0ac 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -89,47 +89,48 @@ functions { * @param global Real, the global parameter * @param mix Vector of shrinkage parameters * @param one_over_lambda Real - * @return Nothing + * @return Real, the log probability. */ - real beta_lp(vector z_beta, int prior_dist, vector prior_scale, + real beta_custom_lpdf(vector z_beta, int prior_dist, vector prior_scale, vector prior_df, real global_prior_df, vector[] local, real[] global, vector[] mix, real[] one_over_lambda, real slab_df, real[] caux) { - if (prior_dist == 1) target += normal_lpdf(z_beta | 0, 1); - else if (prior_dist == 2) target += normal_lpdf(z_beta | 0, 1); // Student t + real lp = 0; + if (prior_dist == 1) lp += normal_lpdf(z_beta | 0, 1); + else if (prior_dist == 2) lp += normal_lpdf(z_beta | 0, 1); // Student t else if (prior_dist == 3) { // hs - target += normal_lpdf(z_beta | 0, 1); - target += normal_lpdf(local[1] | 0, 1); - target += inv_gamma_lpdf(local[2] | 0.5 * prior_df, 0.5 * prior_df); - target += normal_lpdf(global[1] | 0, 1); - target += inv_gamma_lpdf(global[2] | 0.5 * global_prior_df, 0.5 * global_prior_df); - target += inv_gamma_lpdf(caux | 0.5 * slab_df, 0.5 * slab_df); + lp += normal_lpdf(z_beta | 0, 1); + lp += normal_lpdf(local[1] | 0, 1); + lp += inv_gamma_lpdf(local[2] | 0.5 * prior_df, 0.5 * prior_df); + lp += normal_lpdf(global[1] | 0, 1); + lp += inv_gamma_lpdf(global[2] | 0.5 * global_prior_df, 0.5 * global_prior_df); + lp += inv_gamma_lpdf(caux | 0.5 * slab_df, 0.5 * slab_df); } else if (prior_dist == 4) { // hs+ - target += normal_lpdf(z_beta | 0, 1); - target += normal_lpdf(local[1] | 0, 1); - target += inv_gamma_lpdf(local[2] | 0.5 * prior_df, 0.5 * prior_df); - target += normal_lpdf(local[3] | 0, 1); + lp += normal_lpdf(z_beta | 0, 1); + lp += normal_lpdf(local[1] | 0, 1); + lp += inv_gamma_lpdf(local[2] | 0.5 * prior_df, 0.5 * prior_df); + lp += normal_lpdf(local[3] | 0, 1); // unorthodox useage of prior_scale as another df hyperparameter - target += inv_gamma_lpdf(local[4] | 0.5 * prior_scale, 0.5 * prior_scale); - target += normal_lpdf(global[1] | 0, 1); - target += inv_gamma_lpdf(global[2] | 0.5 * global_prior_df, 0.5 * global_prior_df); - target += inv_gamma_lpdf(caux | 0.5 * slab_df, 0.5 * slab_df); + lp += inv_gamma_lpdf(local[4] | 0.5 * prior_scale, 0.5 * prior_scale); + lp += normal_lpdf(global[1] | 0, 1); + lp += inv_gamma_lpdf(global[2] | 0.5 * global_prior_df, 0.5 * global_prior_df); + lp += inv_gamma_lpdf(caux | 0.5 * slab_df, 0.5 * slab_df); } else if (prior_dist == 5) { // laplace - target += normal_lpdf(z_beta | 0, 1); - target += exponential_lpdf(mix[1] | 1); + lp += normal_lpdf(z_beta | 0, 1); + lp += exponential_lpdf(mix[1] | 1); } else if (prior_dist == 6) { // lasso - target += normal_lpdf(z_beta | 0, 1); - target += exponential_lpdf(mix[1] | 1); - target += chi_square_lpdf(one_over_lambda[1] | prior_df[1]); + lp += normal_lpdf(z_beta | 0, 1); + lp += exponential_lpdf(mix[1] | 1); + lp += chi_square_lpdf(one_over_lambda[1] | prior_df[1]); } else if (prior_dist == 7) { // product_normal - target += normal_lpdf(z_beta | 0, 1); + lp += normal_lpdf(z_beta | 0, 1); } /* else prior_dist is 0 and nothing is added */ - return target(); + return lp; } /** @@ -140,15 +141,16 @@ functions { * @param mean Real, mean of prior distribution * @param scale Real, scale for the prior distribution * @param df Real, df for the prior distribution - * @return Nothing + * @return Real, the log probability */ - real gamma_lp(real gamma, int dist, real mean, real scale, real df) { + real gamma_custom_lpdf(real gamma, int dist, real mean, real scale, real df) { + real lp = 0; if (dist == 1) // normal - target += normal_lpdf(gamma | mean, scale); + lp += normal_lpdf(gamma | mean, scale); else if (dist == 2) // student_t - target += student_t_lpdf(gamma | df, mean, scale); + lp += student_t_lpdf(gamma | df, mean, scale); /* else dist is 0 and nothing is added */ - return target(); + return lp; } /** @@ -159,20 +161,21 @@ functions { * @param dist Integer specifying the type of prior distribution * @param df Real specifying the df for the prior distribution, or in the case * of the dirichlet distribution it is the concentration parameter(s) - * @return Nothing + * @return Real, the log probability */ - real basehaz_lp(vector aux_unscaled, int dist, vector df) { + real basehaz_lpdf(vector aux_unscaled, int dist, vector df) { + real lp = 0; if (dist > 0) { if (dist == 1) - target += normal_lpdf(aux_unscaled | 0, 1); + lp += normal_lpdf(aux_unscaled | 0, 1); else if (dist == 2) - target += student_t_lpdf(aux_unscaled | df, 0, 1); + lp += student_t_lpdf(aux_unscaled | df, 0, 1); else if (dist == 3) - target += exponential_lpdf(aux_unscaled | 1); + lp += exponential_lpdf(aux_unscaled | 1); else - target += dirichlet_lpdf(aux_unscaled | df); // df is concentration here + lp += dirichlet_lpdf(aux_unscaled | df); // df is concentration here } - return target(); + return lp; } /** @@ -184,20 +187,21 @@ functions { * smoothing sds * @param df Vector of reals specifying the df for the prior distribution * for the smoothing sds - * @return Nothing + * @return Real, the log probability */ - real smooth_lp(vector z_beta_tve, vector smooth_sd_raw, int dist, vector df) { - target += normal_lpdf(z_beta_tve | 0, 1); + real smooth_lpdf(vector z_beta_tve, vector smooth_sd_raw, int dist, vector df) { + real lp = 0; + lp += normal_lpdf(z_beta_tve | 0, 1); if (dist > 0) { real log_half = -0.693147180559945286; if (dist == 1) - target += normal_lpdf(smooth_sd_raw | 0, 1) - log_half; + lp += normal_lpdf(smooth_sd_raw | 0, 1) - log_half; else if (dist == 2) - target += student_t_lpdf(smooth_sd_raw | df, 0, 1) - log_half; + lp += student_t_lpdf(smooth_sd_raw | df, 0, 1) - log_half; else if (dist == 3) - target += exponential_lpdf(smooth_sd_raw | 1); + lp += exponential_lpdf(smooth_sd_raw | 1); } - return target(); + return lp; } /** @@ -1148,36 +1152,36 @@ model { // log priors for coefficients if (K > 0) { - real dummy = beta_lp(z_beta, prior_dist, prior_scale, prior_df, - global_prior_df, local, global, mix, ool, - slab_df, caux); + target += beta_custom_lpdf(z_beta | prior_dist, prior_scale, prior_df, + global_prior_df, local, global, mix, ool, + slab_df, caux); } // log prior for intercept if (has_intercept == 1) { - real dummy = gamma_lp(gamma[1], prior_dist_for_intercept, - prior_mean_for_intercept, prior_scale_for_intercept, - prior_df_for_intercept); + target += gamma_custom_lpdf(gamma[1] | prior_dist_for_intercept, + prior_mean_for_intercept, prior_scale_for_intercept, + prior_df_for_intercept); } // log priors for baseline hazard parameters if (type == 4) { - real dummy = basehaz_lp(ms_coefs, prior_dist_for_aux, prior_conc_for_aux); + target += basehaz_lpdf(ms_coefs | prior_dist_for_aux, prior_conc_for_aux); } else if (nvars > 0) { - real dummy = basehaz_lp(z_coefs, prior_dist_for_aux, prior_df_for_aux); + target += basehaz_lpdf(z_coefs | prior_dist_for_aux, prior_df_for_aux); } // log priors for tve spline coefficients and their smoothing parameters if (S > 0) { - real dummy = smooth_lp(z_beta_tve, smooth_sd_raw, - prior_dist_for_smooth, prior_df_for_smooth); + target += smooth_lpdf(z_beta_tve | smooth_sd_raw, + prior_dist_for_smooth, prior_df_for_smooth); } // log prior for random effects if (t > 0) { - real dummy = decov_lp(z_b, z_T, rho, zeta, tau, - regularization, delta, b_prior_shape, t, p); + target += decov_lpdf(z_b | z_T, rho, zeta, tau, + regularization, delta, b_prior_shape, t, p); } } From 1c6cecd34f8b13c0317b45524f8e1cc4db853b12 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 30 Oct 2023 23:37:53 +1100 Subject: [PATCH 207/225] Use new array syntax --- src/stan_files/surv.stan | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index a4158e0ac..8343d81d3 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -4,8 +4,8 @@ functions { -#include /functions/common_functions.stan -#include /functions/hazard_functions.stan + #include /functions/common_functions.stan + #include /functions/hazard_functions.stan /** * Return the lower bound for the baseline hazard parameters @@ -48,8 +48,8 @@ functions { */ vector make_beta(vector z_beta, int prior_dist, vector prior_mean, vector prior_scale, vector prior_df, real global_prior_scale, - real[] global, vector[] local, real[] ool, vector[] mix, - real[] aux, int family, real slab_scale, real[] caux) { + array[] real global, array[] vector local, array[] real ool, array[] vector mix, + array[] real aux, int family, real slab_scale, array[] real caux) { vector[rows(z_beta)] beta; if (prior_dist == 0) beta = z_beta; else if (prior_dist == 1) beta = z_beta .* prior_scale + prior_mean; @@ -92,9 +92,9 @@ functions { * @return Real, the log probability. */ real beta_custom_lpdf(vector z_beta, int prior_dist, vector prior_scale, - vector prior_df, real global_prior_df, vector[] local, - real[] global, vector[] mix, real[] one_over_lambda, - real slab_df, real[] caux) { + vector prior_df, real global_prior_df, array[] vector local, + array[] real global, array[] vector mix, array[] real one_over_lambda, + real slab_df, array[] real caux) { real lp = 0; if (prior_dist == 1) lp += normal_lpdf(z_beta | 0, 1); else if (prior_dist == 2) lp += normal_lpdf(z_beta | 0, 1); // Student t From 55325d9d3b194cf1651772ff33d3db9bdc612c99 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Mon, 30 Oct 2023 23:38:55 +1100 Subject: [PATCH 208/225] Disable most of the build environments --- .github/workflows/R-CMD-check.yaml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 8999a6da1..b2711b033 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -21,15 +21,15 @@ jobs: fail-fast: false matrix: config: - - {os: macOS-latest, r: 'devel', rstan: 'CRAN'} - - {os: macOS-latest, r: 'release', rstan: 'CRAN'} - - {os: windows-latest, r: 'devel', rstan: 'CRAN'} + # - {os: macOS-latest, r: 'devel', rstan: 'CRAN'} + # - {os: macOS-latest, r: 'release', rstan: 'CRAN'} + # - {os: windows-latest, r: 'devel', rstan: 'CRAN'} - {os: windows-latest, r: 'release', rstan: 'CRAN'} - - {os: ubuntu-latest, r: 'devel', rstan: 'CRAN'} - - {os: ubuntu-latest, r: 'release', rstan: 'CRAN'} - - {os: ubuntu-latest, r: 'oldrel', rstan: 'CRAN'} + # - {os: ubuntu-latest, r: 'devel', rstan: 'CRAN'} + # - {os: ubuntu-latest, r: 'release', rstan: 'CRAN'} + # - {os: ubuntu-latest, r: 'oldrel', rstan: 'CRAN'} - - {os: macOS-latest, r: 'release', rstan: 'Preview'} + # - {os: macOS-latest, r: 'release', rstan: 'Preview'} - {os: windows-latest, r: 'release', rstan: 'Preview'} env: R_REMOTES_NO_ERRORS_FROM_WARNINGS: true From 9a3d0a045da5a5c42e1671730987dab03aac93d2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 00:15:24 +1100 Subject: [PATCH 209/225] Fix remaining reference to target in stan functions --- src/stan_files/functions/mvmer_functions.stan | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/stan_files/functions/mvmer_functions.stan b/src/stan_files/functions/mvmer_functions.stan index f8a26f80f..e2ead710c 100644 --- a/src/stan_files/functions/mvmer_functions.stan +++ b/src/stan_files/functions/mvmer_functions.stan @@ -232,7 +232,7 @@ } /** - * Increment the target with the log-likelihood for the glmer submodel + * Evaluate the log-likelihood for the glmer submodel * * @param z_beta A vector of primitive parameters * @param prior_dist Integer, the type of prior distribution @@ -328,7 +328,6 @@ } return lp; /* else prior_dist is 0 and nothing is added */ - return target(); } /** From 8ff33812c6361c5bc50e6158db8850b27ba7d344 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 10:16:48 +1100 Subject: [PATCH 210/225] Solve NOTE about broken tve.Rd docs link --- R/stan_surv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 30a976336..dec4cc97d 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1306,7 +1306,7 @@ stan_surv <- function(formula, #' @return The exported \code{tve} function documented here just returns #' \code{x}. However, when called internally the \code{tve} function returns #' several other pieces of useful information. For the most part, these are -#' added to the formula element of the returned \code{\link{stanreg}} object +#' added to the formula element of the returned \code{\link{stanreg-objects}} #' (that is \code{object[["formula"]]} where \code{object} is the fitted #' model). Information added to the formula element of the \code{stanreg} #' object includes the following: From 4dc2c1f06ee12bed1769e7c170a02ad48bc20a95 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 10:29:18 +1100 Subject: [PATCH 211/225] Remove remaining test helpers --- tests/testthat/helpers/expect_survfit_jm.R | 1 - tests/testthat/helpers/get_tols_jm.R | 67 ---------------------- tests/testthat/helpers/recover_pars_jm.R | 35 ----------- 3 files changed, 103 deletions(-) delete mode 100644 tests/testthat/helpers/expect_survfit_jm.R delete mode 100644 tests/testthat/helpers/get_tols_jm.R delete mode 100644 tests/testthat/helpers/recover_pars_jm.R diff --git a/tests/testthat/helpers/expect_survfit_jm.R b/tests/testthat/helpers/expect_survfit_jm.R deleted file mode 100644 index 1b661489f..000000000 --- a/tests/testthat/helpers/expect_survfit_jm.R +++ /dev/null @@ -1 +0,0 @@ -expect_survfit <- function(x) expect_s3_class(x, "survfit.stanjm") diff --git a/tests/testthat/helpers/get_tols_jm.R b/tests/testthat/helpers/get_tols_jm.R deleted file mode 100644 index fb61090a0..000000000 --- a/tests/testthat/helpers/get_tols_jm.R +++ /dev/null @@ -1,67 +0,0 @@ -# Use the standard errors from a fitted 'comparison model' to obtain -# the tolerance for each parameter in the joint model -# Obtain parameter specific tolerances that can be used to assess the -# accuracy of parameter estimates in stan_jm models. The tolerances -# are calculated by taking the SE/SD for the parameter estimate in a -# "gold standard" model and multiplying this by the relevant element -# in the 'tolscales' argument. -# -# @param modLong The "gold standard" longitudinal model. Likely to be -# a model estimated using either {g}lmer or stan_{g}lmer. -# @param modEvent The "gold standard" event model. Likely to be a model -# estimated using coxph. -# @param toscales A named list with elements $lmer_fixef, $lmer_ranef, -# $glmer_fixef, $glmer_ranef, $event. -# @param idvar The name of the ID variable. Used to extract the SDs for -# group-specific terms that correspond to the individual/patient. -# -get_tols <- function(modLong, modEvent = NULL, tolscales, idvar = "id") { - - if (is.null(modEvent)) - modEvent <- modLong # if modLong is already a joint model - - if (class(modLong)[1] == "stanreg") { - fixef_nms <- names(fixef(modLong)) - fixef_ses <- modLong$ses[fixef_nms] - ranef_sds <- attr(VarCorr(modLong)[[idvar]], "stddev") - if (modLong$stan_function == "stan_lmer") { - fixef_tols <- tolscales$lmer_fixef * fixef_ses - ranef_tols <- tolscales$lmer_ranef * ranef_sds - } else if (modLong$stan_function == "stan_glmer") { - if (modLong$family$family == "gaussian") { - fixef_tols <- tolscales$lmer_fixef * fixef_ses - ranef_tols <- tolscales$lmer_ranef * ranef_sds - } else { - fixef_tols <- tolscales$glmer_fixef * fixef_ses - ranef_tols <- tolscales$glmer_ranef * ranef_sds - } - } - } else if (class(modLong)[1] %in% c("lmerMod", "glmerMod")) { - fixef_ses <- sqrt(diag(vcov(modLong))) - ranef_sds <- attr(VarCorr(modLong)[[idvar]], "stddev") - if (class(modLong)[1] == "lmerMod") { - fixef_tols <- tolscales$lmer_fixef * fixef_ses - ranef_tols <- tolscales$lmer_ranef * ranef_sds - } else if (class(modLong)[1] == "glmerMod") { - fixef_tols <- tolscales$glmer_fixef * fixef_ses - ranef_tols <- tolscales$glmer_ranef * ranef_sds - } - } - if ("(Intercept)" %in% names(fixef_tols)) - fixef_tols[["(Intercept)"]] <- 2 * fixef_tols[["(Intercept)"]] - if ("(Intercept)" %in% names(ranef_tols)) - ranef_tols[["(Intercept)"]] <- 2 * ranef_tols[["(Intercept)"]] - - if (class(modEvent)[1] == "coxph") { - event_ses <- summary(modEvent)$coefficients[, "se(coef)"] - } else event_ses <- NULL - event_tols <- if (!is.null(event_ses)) - tolscales$event * event_ses else NULL - if ("(Intercept)" %in% names(event_tols)) - event_tols[["(Intercept)"]] <- 2 * event_tols[["(Intercept)"]] - - ret <- Filter( - function(x) !is.null(x), - list(fixef = fixef_tols, ranef = ranef_tols, event = event_tols)) - return(ret) -} diff --git a/tests/testthat/helpers/recover_pars_jm.R b/tests/testthat/helpers/recover_pars_jm.R deleted file mode 100644 index fb9bfd376..000000000 --- a/tests/testthat/helpers/recover_pars_jm.R +++ /dev/null @@ -1,35 +0,0 @@ -# Recover parameter estimates and return a list with consistent -# parameter names for comparing stan_jm, stan_mvmer, stan_{g}lmer, -# {g}lmer, and coxph estimates -# -# @param modLong The fitted longitudinal model. Likely to be -# a model estimated using either {g}lmer or stan_{g}lmer. -# @param modEvent The fitted event model. Likely to be a model -# estimated using coxph. -# @param idvar The name of the ID variable. Used to extract the estimates -# for group-specific parameters that correspond to the individual/patient. -# -recover_pars <- function(modLong, modEvent = NULL, idvar = "id") { - - if (is.null(modEvent)) - modEvent <- modLong - - if (class(modLong)[1] %in% c("stanreg", "lmerMod", "glmerMod")) { - fixef_pars <- fixef(modLong) - ranef_pars <- ranef(modLong)[[idvar]] - } else if (class(modLong)[1] %in% c("stanjm", "stanmvreg")) { - fixef_pars <- fixef(modLong)[[1L]] - ranef_pars <- ranef(modLong)[[1L]][[idvar]] - } - - if (class(modEvent)[1] == "coxph") { - event_pars <- modEvent$coefficients - } else if (class(modEvent)[1] %in% c("stanjm", "stanmvreg")) { - event_pars <- fixef(modEvent)$Event - } else event_pars <- NULL - - ret <- Filter( - function(x) !is.null(x), - list(fixef = fixef_pars, ranef = ranef_pars, event = event_pars)) - return(ret) -} From b5af2c5d2a1bedd0a6a0123b35c853973fb0baf2 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 10:35:26 +1100 Subject: [PATCH 212/225] Add missing doc for prior_covariate in stan_surv.R --- R/stan_surv.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/stan_surv.R b/R/stan_surv.R index 970238faf..c1eb69540 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -44,6 +44,7 @@ #' #' @template args-dots #' @template args-priors +#' @template args-prior_covariance #' @template args-prior_PD #' @template args-algorithm #' @template args-adapt_delta From 1c2fb5c00559551a7010e4db8e0098aeb1fc28e7 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 10:43:36 +1100 Subject: [PATCH 213/225] Fix doc reference for S3 plot method on stansurv objects --- R/plots.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/plots.R b/R/plots.R index ed8d3fc47..7feb2f46f 100644 --- a/R/plots.R +++ b/R/plots.R @@ -186,6 +186,7 @@ plot.stanreg <- function(x, plotfun = "intervals", pars = NULL, # plot method for stansurv ---------------------------------------------- #' @rdname plot.stanreg +#' @method plot stansurv #' @export #' @templateVar cigeomArg ci_geom_args #' @template args-ci-geom-args From 47b7e02b0ee0c0ecccabb65fc1d053fa76743072 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 10:48:15 +1100 Subject: [PATCH 214/225] Fix undefined global reference to xlevs ... how did this not break the code up until now?? :explodinghead: --- R/pp_data.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/pp_data.R b/R/pp_data.R index 84e58b2e5..690f3184a 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -355,7 +355,7 @@ pp_data <- mf[, colnames(mf_s)] <- mf_s # construct time-varying predictor matrix - s <- make_s(formula, mf, xlevs = xlevs) + s <- make_s(formula, mf, xlevs = object$xlevs) if (all(is.na(pts))) { # if pts were all NA then replace the time-varying predictor From bda83b8f76cb985798f9cf67bd4d7b311401fb29 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 11:05:23 +1100 Subject: [PATCH 215/225] Try deal with the xlevs stuff --- R/pp_data.R | 2 +- R/stan_surv.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/pp_data.R b/R/pp_data.R index 690f3184a..126c5357a 100644 --- a/R/pp_data.R +++ b/R/pp_data.R @@ -355,7 +355,7 @@ pp_data <- mf[, colnames(mf_s)] <- mf_s # construct time-varying predictor matrix - s <- make_s(formula, mf, xlevs = object$xlevs) + s <- make_s(formula, mf) if (all(is.na(pts))) { # if pts were all NA then replace the time-varying predictor diff --git a/R/stan_surv.R b/R/stan_surv.R index c1eb69540..c0aa6690f 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -748,7 +748,7 @@ stan_surv <- function(formula, if (has_tve) { # time-varying predictor matrix - s_cpts <- make_s(formula, mf_cpts, xlevs = xlevs) + s_cpts <- make_s(formula, mf_cpts) smooth_map <- get_smooth_name(s_cpts, type = "smooth_map") smooth_idx <- get_idx_array(table(smooth_map)) S <- ncol(s_cpts) # number of tve coefficients From 46e8c90f88d3c52ee46ebd18c7d7fc397eafd4ea Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 11:06:27 +1100 Subject: [PATCH 216/225] Remove if condition from step that uploads artifacts --- .github/workflows/R-CMD-check.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index b2711b033..a2a5cc8a9 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -68,7 +68,7 @@ jobs: build_args: '"--no-build-vignettes"' - name: Upload check results - if: failure() + # if: failure() uses: actions/upload-artifact@main with: name: ${{ runner.os }}-r${{ matrix.config.r }}-results From 67478d4a19aea74414675a538c0b3b8e59441b54 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 31 Oct 2023 23:47:21 +1100 Subject: [PATCH 217/225] Fix inherits - broken due to breaking change in splines2 0.5 splines2 v0.5.0 made a breaking change, and the class was renamed from iSpline to ISpline, and the order of the class heirarchy was also changed. Same for their mSpline class, etc. --- R/stan_surv.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index c0aa6690f..815e7e73e 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -1732,8 +1732,8 @@ make_basis <- function(times, basehaz, integrate = FALSE) { basis_matrix <- function(times, basis, integrate = FALSE) { out <- predict(basis, times) if (integrate) { - stopifnot(inherits(basis, "mSpline")) - class(basis) <- c("matrix", "iSpline") + stopifnot(inherits(basis, "MSpline")) + class(basis) <- c("ISpline", "splines2", "matrix") out <- predict(basis, times) } aa(out) From 4320268b638d5572a9af19021d9afdce92159adc Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 1 Nov 2023 00:38:52 +1100 Subject: [PATCH 218/225] Don't offset sparse parts by -1L Copy behaviour from this commit https://github.com/stan-dev/rstanarm/commit/3c08d53df851faff831017374436bc53ec0ab98b --- R/stan_surv.R | 48 ++++++++++++++++++++++++------------------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/R/stan_surv.R b/R/stan_surv.R index 815e7e73e..25c65d191 100644 --- a/R/stan_surv.R +++ b/R/stan_surv.R @@ -882,17 +882,17 @@ stan_surv <- function(formula, w_icens = if (has_quadrature || !has_bars || nicens == 0) double(0) else parts_icens$w, w_delay = if (has_quadrature || !has_bars || ndelay == 0) double(0) else parts_delay$w, - v_event = if (has_quadrature || !has_bars || nevent == 0) integer(0) else parts_event$v - 1L, - v_lcens = if (has_quadrature || !has_bars || nlcens == 0) integer(0) else parts_lcens$v - 1L, - v_rcens = if (has_quadrature || !has_bars || nrcens == 0) integer(0) else parts_rcens$v - 1L, - v_icens = if (has_quadrature || !has_bars || nicens == 0) integer(0) else parts_icens$v - 1L, - v_delay = if (has_quadrature || !has_bars || ndelay == 0) integer(0) else parts_delay$v - 1L, - - u_event = if (has_quadrature || !has_bars || nevent == 0) integer(0) else parts_event$u - 1L, - u_lcens = if (has_quadrature || !has_bars || nlcens == 0) integer(0) else parts_lcens$u - 1L, - u_rcens = if (has_quadrature || !has_bars || nrcens == 0) integer(0) else parts_rcens$u - 1L, - u_icens = if (has_quadrature || !has_bars || nicens == 0) integer(0) else parts_icens$u - 1L, - u_delay = if (has_quadrature || !has_bars || ndelay == 0) integer(0) else parts_delay$u - 1L, + v_event = if (has_quadrature || !has_bars || nevent == 0) integer(0) else parts_event$v, + v_lcens = if (has_quadrature || !has_bars || nlcens == 0) integer(0) else parts_lcens$v, + v_rcens = if (has_quadrature || !has_bars || nrcens == 0) integer(0) else parts_rcens$v, + v_icens = if (has_quadrature || !has_bars || nicens == 0) integer(0) else parts_icens$v, + v_delay = if (has_quadrature || !has_bars || ndelay == 0) integer(0) else parts_delay$v, + + u_event = if (has_quadrature || !has_bars || nevent == 0) integer(0) else parts_event$u, + u_lcens = if (has_quadrature || !has_bars || nlcens == 0) integer(0) else parts_lcens$u, + u_rcens = if (has_quadrature || !has_bars || nrcens == 0) integer(0) else parts_rcens$u, + u_icens = if (has_quadrature || !has_bars || nicens == 0) integer(0) else parts_icens$u, + u_delay = if (has_quadrature || !has_bars || ndelay == 0) integer(0) else parts_delay$u, nnz_event = if (has_quadrature || !has_bars || nevent == 0) 0L else length(parts_event$w), nnz_lcens = if (has_quadrature || !has_bars || nlcens == 0) 0L else length(parts_lcens$w), @@ -959,19 +959,19 @@ stan_surv <- function(formula, w_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) double(0) else parts_qpts_icens$w, w_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) double(0) else parts_qpts_delay$w, - v_epts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_epts_event$v - 1L, - v_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_qpts_event$v - 1L, - v_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) integer(0) else parts_qpts_lcens$v - 1L, - v_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) integer(0) else parts_qpts_rcens$v - 1L, - v_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) integer(0) else parts_qpts_icens$v - 1L, - v_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) integer(0) else parts_qpts_delay$v - 1L, - - u_epts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_epts_event$u - 1L, - u_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_qpts_event$u - 1L, - u_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) integer(0) else parts_qpts_lcens$u - 1L, - u_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) integer(0) else parts_qpts_rcens$u - 1L, - u_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) integer(0) else parts_qpts_icens$u - 1L, - u_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) integer(0) else parts_qpts_delay$u - 1L, + v_epts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_epts_event$v, + v_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_qpts_event$v, + v_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) integer(0) else parts_qpts_lcens$v, + v_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) integer(0) else parts_qpts_rcens$v, + v_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) integer(0) else parts_qpts_icens$v, + v_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) integer(0) else parts_qpts_delay$v, + + u_epts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_epts_event$u, + u_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) integer(0) else parts_qpts_event$u, + u_qpts_lcens = if (!has_quadrature || !has_bars || qlcens == 0) integer(0) else parts_qpts_lcens$u, + u_qpts_rcens = if (!has_quadrature || !has_bars || qrcens == 0) integer(0) else parts_qpts_rcens$u, + u_qpts_icens = if (!has_quadrature || !has_bars || qicens == 0) integer(0) else parts_qpts_icens$u, + u_qpts_delay = if (!has_quadrature || !has_bars || qdelay == 0) integer(0) else parts_qpts_delay$u, nnz_epts_event = if (!has_quadrature || !has_bars || qevent == 0) 0L else length(parts_epts_event$w), nnz_qpts_event = if (!has_quadrature || !has_bars || qevent == 0) 0L else length(parts_qpts_event$w), From ed73436b282cdecf668437513143cebb31eb4f75 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 1 Nov 2023 09:58:18 +1100 Subject: [PATCH 219/225] Revert temporary changes to CI pipeline --- .github/workflows/R-CMD-check.yaml | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index a2a5cc8a9..1adf545cd 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -4,7 +4,6 @@ on: push: branches: - master - - survival_2_26_1 pull_request: branches: - master @@ -21,15 +20,15 @@ jobs: fail-fast: false matrix: config: - # - {os: macOS-latest, r: 'devel', rstan: 'CRAN'} - # - {os: macOS-latest, r: 'release', rstan: 'CRAN'} - # - {os: windows-latest, r: 'devel', rstan: 'CRAN'} + - {os: macOS-latest, r: 'devel', rstan: 'CRAN'} + - {os: macOS-latest, r: 'release', rstan: 'CRAN'} + - {os: windows-latest, r: 'devel', rstan: 'CRAN'} - {os: windows-latest, r: 'release', rstan: 'CRAN'} - # - {os: ubuntu-latest, r: 'devel', rstan: 'CRAN'} - # - {os: ubuntu-latest, r: 'release', rstan: 'CRAN'} - # - {os: ubuntu-latest, r: 'oldrel', rstan: 'CRAN'} + - {os: ubuntu-latest, r: 'devel', rstan: 'CRAN'} + - {os: ubuntu-latest, r: 'release', rstan: 'CRAN'} + - {os: ubuntu-latest, r: 'oldrel', rstan: 'CRAN'} - # - {os: macOS-latest, r: 'release', rstan: 'Preview'} + - {os: macOS-latest, r: 'release', rstan: 'Preview'} - {os: windows-latest, r: 'release', rstan: 'Preview'} env: R_REMOTES_NO_ERRORS_FROM_WARNINGS: true @@ -68,7 +67,7 @@ jobs: build_args: '"--no-build-vignettes"' - name: Upload check results - # if: failure() + if: failure() uses: actions/upload-artifact@main with: name: ${{ runner.os }}-r${{ matrix.config.r }}-results From e65cc107ca1c04d56a8adf945d2000eb482e244f Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Wed, 1 Nov 2023 12:35:07 +1100 Subject: [PATCH 220/225] Fix mispelling of context() in test_stan_surv.R --- tests/testthat/test_stan_surv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 380ad7ddc..129ed8fa5 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -34,7 +34,7 @@ TOLSCALES <- list( hr_fixef = 0.5 # how many SEs can stan_surv HRs be from coxph/stpm2 HRs ) -content("stan_surv") +context("stan_surv") eo <- function(...) { expect_output (...) } ee <- function(...) { expect_error (...) } From 3a7680f932cc9787b0a38bc5db07e0220c826a51 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 5 Nov 2023 15:55:30 +1100 Subject: [PATCH 221/225] Don't explicitly set knots at boundary splines2 became stricter and raises an error for internal knots on the boundary. So instead of making the internal knot 5 (max event time), let's make it 4 in these tests. Also a vector for qnodes makes no sense. So I'll remove this redundant test. --- tests/testthat/test_stan_surv.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 129ed8fa5..0a53dfd93 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -91,7 +91,6 @@ test_that("qnodes argument works", { es(up(testmod, qnodes = 15, basehaz = "bs")) ew(up(testmod, qnodes = 1), "is being ignored") - ew(up(testmod, qnodes = c(1,2)), "is being ignored") ew(up(testmod, qnodes = "wrong"), "is being ignored") ee(up(testmod, qnodes = 1, basehaz = "bs"), "7, 11 or 15") @@ -109,7 +108,7 @@ test_that("basehaz argument works", { es(up(testmod, basehaz = "weibull-aft")) dfl <- list(df = 5) - knl <- list(knots = c(1,3,5)) + knl <- list(knots = c(1,3,4)) es(up(testmod, basehaz = "ms", basehaz_ops = dfl)) es(up(testmod, basehaz = "ms", basehaz_ops = knl)) es(up(testmod, basehaz = "bs", basehaz_ops = dfl)) From f2b4d04b8f6d857029a87b2abb782bdb1d24818e Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 5 Nov 2023 15:58:20 +1100 Subject: [PATCH 222/225] Remove use of || in log_lik.R for stan_surv models Same as https://github.com/stan-dev/rstanarm/pull/594. But must have missed the use of it in log_lik.R --- R/log_lik.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/log_lik.R b/R/log_lik.R index 004f93036..960e902d6 100644 --- a/R/log_lik.R +++ b/R/log_lik.R @@ -410,7 +410,7 @@ ll_args.stansurv <- function(object, newdata = NULL, ...) { t_end <- make_t(y, type = "end") # exit time t_upp <- make_t(y, type = "upp") # upper time for interval censoring status <- make_d(y) - if (any(status < 0 || status > 3)) + if (any(status < 0 | status > 3)) stop2("Invalid status indicator in Surv object.") # delayed entry indicator for each row of data From 5e405c43d29f23c239c01f5a922c6a687b06cd0d Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Tue, 7 Nov 2023 22:34:07 +1100 Subject: [PATCH 223/225] Just try using larger sample sizes for the failing tests --- tests/testthat/test_stan_surv.R | 44 +++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test_stan_surv.R b/tests/testthat/test_stan_surv.R index 0a53dfd93..7c3c270ce 100644 --- a/tests/testthat/test_stan_surv.R +++ b/tests/testthat/test_stan_surv.R @@ -406,12 +406,14 @@ compare_surv <- function(data, basehaz = "weibull", ...) { info = basehaz) } +N_coxph <- 1000 + #---- exponential data set.seed(543634) -covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) +covs <- data.frame(id = 1:N_coxph, + X1 = rbinom(N_coxph, 1, 0.3), + X2 = rnorm (N_coxph, 2, 2.0)) dat <- simsurv(dist = "weibull", lambdas = 0.1, gammas = 1, @@ -424,9 +426,9 @@ compare_surv(data = dat, basehaz = "exp") #---- weibull data set.seed(543634) -covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) +covs <- data.frame(id = 1:N_coxph, + X1 = rbinom(N_coxph, 1, 0.3), + X2 = rnorm (N_coxph, 2, 2.0)) dat <- simsurv(dist = "weibull", lambdas = 0.1, gammas = 1.3, @@ -441,9 +443,9 @@ compare_surv(data = dat, basehaz = "bs") #---- gompertz data set.seed(45357) -covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) +covs <- data.frame(id = 1:N_coxph, + X1 = rbinom(N_coxph, 1, 0.3), + X2 = rnorm (N_coxph, 2, 2.0)) dat <- simsurv(dist = "gompertz", lambdas = 0.1, gammas = 0.05, @@ -479,12 +481,14 @@ compare_surv <- function(data, basehaz = "weibull-aft", ...) { info = basehaz) } +N_survreg <- 300 + #---- exponential data set.seed(543634) -covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) +covs <- data.frame(id = 1:N_survreg, + X1 = rbinom(N_survreg, 1, 0.3), + X2 = rnorm (N_survreg, 2, 2.0)) dat <- simsurv(dist = "weibull", lambdas = 0.1, gammas = 1, @@ -497,9 +501,9 @@ compare_surv(data = dat, basehaz = "exp-aft") #---- weibull data set.seed(543634) -covs <- data.frame(id = 1:300, - X1 = rbinom(300, 1, 0.3), - X2 = rnorm (300, 2, 2.0)) +covs <- data.frame(id = 1:N_survreg, + X1 = rbinom(N_survreg, 1, 0.3), + X2 = rnorm (N_survreg, 2, 2.0)) dat <- simsurv(dist = "weibull", lambdas = 0.1, gammas = 1.3, @@ -740,9 +744,11 @@ get_ests <- function(mod) { # simulate datasets set.seed(SEED) -dat <- make_data(n = 20, K = 50) -dat_delay <- make_data(n = 20, K = 50, delay = TRUE) -dat_icens <- make_data(n = 20, K = 50, icens = TRUE) +n <- 50 +K <- 100 +dat <- make_data(n = n, K = K) +dat_delay <- make_data(n = n, K = K, delay = TRUE) +dat_icens <- make_data(n = n, K = K, icens = TRUE) # formulas ff <- Surv(eventtime, status) ~ trt + (1 | site) # right cens @@ -759,7 +765,7 @@ o<-SW(m1 <- stan_surv(formula = ff, seed = SEED)) # fit the additional models -o<-SW(m2 <- up(m1, formula. = ff, data = dat, basehaz = "weibull")) +o<-SW(m2 <- up(m1, formula. = ff, data = dat, basehaz = "weibull")) o<-SW(m3 <- up(m1, formula. = ff, data = dat, basehaz = "gompertz")) o<-SW(m4 <- up(m1, formula. = ff, data = dat, basehaz = "ms")) o<-SW(m5 <- up(m1, formula. = ffd, data = dat_delay, basehaz = "exp")) From 590ba0aaab632c2f4dd18ce4e24f8fb0d1c4c510 Mon Sep 17 00:00:00 2001 From: Sam Brilleman Date: Sun, 11 Feb 2024 09:42:51 +1100 Subject: [PATCH 224/225] Try deal with reserved naming issue --- .../functions/hazard_functions.stan | 2 +- src/stan_files/surv.stan | 30 +++++++++---------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/stan_files/functions/hazard_functions.stan b/src/stan_files/functions/hazard_functions.stan index 06de10a5d..fa29e91b5 100644 --- a/src/stan_files/functions/hazard_functions.stan +++ b/src/stan_files/functions/hazard_functions.stan @@ -92,7 +92,7 @@ return - dot_product(qwts, exp(log_hazard)); // sum across all individuals } - vector quadrature_log_cdf(vector qwts, vector log_hazard, int qnodes, int N) { + vector quadrature_log_cdf1(vector qwts, vector log_hazard, int qnodes, int N) { int M = rows(log_hazard); vector[M] hazard = exp(log_hazard); matrix[N,qnodes] qwts_mat = to_matrix(qwts, N, qnodes); diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 8343d81d3..0558289c5 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -232,7 +232,7 @@ functions { return res; } - vector exponential_log_cdf(vector eta, vector t) { + vector exponential_log_cdf1(vector eta, vector t) { vector[rows(eta)] res; res = log(1 - exp(-t .* exp(eta))); return res; @@ -260,7 +260,7 @@ functions { return res; } - vector exponentialAFT_log_cdf(vector caf) { + vector exponentialAFT_log_cdf1(vector caf) { vector[rows(caf)] res; res = log(1 - exp(-caf)); return res; @@ -289,7 +289,7 @@ functions { return res; } - vector weibull_log_cdf(vector eta, vector t, real shape) { + vector weibull_log_cdf1(vector eta, vector t, real shape) { vector[rows(eta)] res; res = log(1 - exp(- pow_vec(t, shape) .* exp(eta))); return res; @@ -318,7 +318,7 @@ functions { return res; } - vector weibullAFT_log_cdf(vector caf, real shape) { + vector weibullAFT_log_cdf1(vector caf, real shape) { vector[rows(caf)] res; res = log(1 - exp(- pow_vec(caf, shape))); return res; @@ -347,7 +347,7 @@ functions { return res; } - vector gompertz_log_cdf(vector eta, vector t, real scale) { + vector gompertz_log_cdf1(vector eta, vector t, real scale) { vector[rows(eta)] res; res = log(1 - exp(inv(scale) * -(exp(scale * t) - 1) .* exp(eta))); return res; @@ -378,7 +378,7 @@ functions { return res; } - vector mspline_log_cdf(vector eta, matrix ibasis, vector coefs) { + vector mspline_log_cdf1(vector eta, matrix ibasis, vector coefs) { vector[rows(eta)] res; res = log(1 - exp(-(ibasis * coefs) .* exp(eta))); return res; @@ -873,7 +873,7 @@ model { if (type == 7) { // exponential AFT model if (nevent > 0) target += exponentialAFT_log_haz (af_event); if (nevent > 0) target += exponentialAFT_log_surv(caf_event); - if (nlcens > 0) target += exponentialAFT_log_cdf (caf_lcens); + if (nlcens > 0) target += exponentialAFT_log_cdf1(caf_lcens); if (nrcens > 0) target += exponentialAFT_log_surv(caf_rcens); if (nicens > 0) target += exponentialAFT_log_cdf2(caf_icenl, caf_icenu); if (ndelay > 0) target += -exponentialAFT_log_surv(caf_delay); @@ -881,7 +881,7 @@ model { real shape = coefs[1]; if (nevent > 0) target += weibullAFT_log_haz (af_event, caf_event, shape); if (nevent > 0) target += weibullAFT_log_surv(caf_event, shape); - if (nlcens > 0) target += weibullAFT_log_cdf (caf_lcens, shape); + if (nlcens > 0) target += weibullAFT_log_cdf1(caf_lcens, shape); if (nrcens > 0) target += weibullAFT_log_surv(caf_rcens, shape); if (nicens > 0) target += weibullAFT_log_cdf2(caf_icenl, caf_icenu, shape); if (ndelay > 0) target += -weibullAFT_log_surv(caf_delay, shape); @@ -896,7 +896,7 @@ model { if (type == 5) { // exponential model if (nevent > 0) target += exponential_log_haz (eta_event); if (nevent > 0) target += exponential_log_surv(eta_event, t_event); - if (nlcens > 0) target += exponential_log_cdf (eta_lcens, t_lcens); + if (nlcens > 0) target += exponential_log_cdf1(eta_lcens, t_lcens); if (nrcens > 0) target += exponential_log_surv(eta_rcens, t_rcens); if (nicens > 0) target += exponential_log_cdf2(eta_icens, t_icenl, t_icenu); if (ndelay > 0) target += -exponential_log_surv(eta_delay, t_delay); @@ -905,7 +905,7 @@ model { real shape = coefs[1]; if (nevent > 0) target += weibull_log_haz (eta_event, t_event, shape); if (nevent > 0) target += weibull_log_surv(eta_event, t_event, shape); - if (nlcens > 0) target += weibull_log_cdf (eta_lcens, t_lcens, shape); + if (nlcens > 0) target += weibull_log_cdf1(eta_lcens, t_lcens, shape); if (nrcens > 0) target += weibull_log_surv(eta_rcens, t_rcens, shape); if (nicens > 0) target += weibull_log_cdf2(eta_icens, t_icenl, t_icenu, shape); if (ndelay > 0) target += -weibull_log_surv(eta_delay, t_delay, shape); @@ -914,7 +914,7 @@ model { real scale = coefs[1]; if (nevent > 0) target += gompertz_log_haz (eta_event, t_event, scale); if (nevent > 0) target += gompertz_log_surv(eta_event, t_event, scale); - if (nlcens > 0) target += gompertz_log_cdf (eta_lcens, t_lcens, scale); + if (nlcens > 0) target += gompertz_log_cdf1(eta_lcens, t_lcens, scale); if (nrcens > 0) target += gompertz_log_surv(eta_rcens, t_rcens, scale); if (nicens > 0) target += gompertz_log_cdf2(eta_icens, t_icenl, t_icenu, scale); if (ndelay > 0) target += -gompertz_log_surv(eta_delay, t_delay, scale); @@ -922,7 +922,7 @@ model { else if (type == 4) { // M-splines, on haz scale if (nevent > 0) target += mspline_log_haz (eta_event, basis_event, ms_coefs); if (nevent > 0) target += mspline_log_surv(eta_event, ibasis_event, ms_coefs); - if (nlcens > 0) target += mspline_log_cdf (eta_lcens, ibasis_lcens, ms_coefs); + if (nlcens > 0) target += mspline_log_cdf1(eta_lcens, ibasis_lcens, ms_coefs); if (nrcens > 0) target += mspline_log_surv(eta_rcens, ibasis_rcens, ms_coefs); if (nicens > 0) target += mspline_log_cdf2(eta_icens, ibasis_icenl, ibasis_icenu, ms_coefs); if (ndelay > 0) target += -mspline_log_surv(eta_delay, ibasis_delay, ms_coefs); @@ -1054,7 +1054,7 @@ model { if (type == 7) { // exponential AFT model if (Nevent > 0) target += exponentialAFT_log_haz (af_event); if (Nevent > 0) target += exponentialAFT_log_surv(caf_event); - if (Nlcens > 0) target += exponentialAFT_log_cdf (caf_lcens); + if (Nlcens > 0) target += exponentialAFT_log_cdf1(caf_lcens); if (Nrcens > 0) target += exponentialAFT_log_surv(caf_rcens); if (Nicens > 0) target += exponentialAFT_log_cdf2(caf_icenl, caf_icenu); if (Ndelay > 0) target += -exponentialAFT_log_surv(caf_delay); @@ -1062,7 +1062,7 @@ model { real shape = coefs[1]; if (Nevent > 0) target += weibullAFT_log_haz (af_event, caf_event, shape); if (Nevent > 0) target += weibullAFT_log_surv(caf_event, shape); - if (Nlcens > 0) target += weibullAFT_log_cdf (caf_lcens, shape); + if (Nlcens > 0) target += weibullAFT_log_cdf1(caf_lcens, shape); if (Nrcens > 0) target += weibullAFT_log_surv(caf_rcens, shape); if (Nicens > 0) target += weibullAFT_log_cdf2(caf_icenl, caf_icenu, shape); if (Ndelay > 0) target += -weibullAFT_log_surv(caf_delay, shape); @@ -1136,7 +1136,7 @@ model { // increment target with log-lik contributions for event submodel if (Nevent > 0) target += lhaz_epts_event; if (qevent > 0) target += quadrature_log_surv(qwts_event, lhaz_qpts_event); - if (qlcens > 0) target += quadrature_log_cdf (qwts_lcens, lhaz_qpts_lcens, qnodes, Nlcens); + if (qlcens > 0) target += quadrature_log_cdf1(qwts_lcens, lhaz_qpts_lcens, qnodes, Nlcens); if (qrcens > 0) target += quadrature_log_surv(qwts_rcens, lhaz_qpts_rcens); if (qicens > 0) target += quadrature_log_cdf2(qwts_icenl, lhaz_qpts_icenl, qwts_icenu, lhaz_qpts_icenu, qnodes, Nicens); From 17ade30c7facd902c8c86896668d1bcc6e67af15 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Mon, 20 May 2024 12:01:06 +0300 Subject: [PATCH 225/225] Update deprecated array syntac --- src/stan_files/surv.stan | 98 ++++++++++++++++++++-------------------- 1 file changed, 49 insertions(+), 49 deletions(-) diff --git a/src/stan_files/surv.stan b/src/stan_files/surv.stan index 0558289c5..03492c9bf 100644 --- a/src/stan_files/surv.stan +++ b/src/stan_files/surv.stan @@ -418,14 +418,14 @@ data { int qicens; // num. quadrature points for rows w/ interval censoring int qdelay; // num. quadrature points for rows w/ delayed entry int nvars; // num. aux parameters for baseline hazard - int smooth_map[S]; // indexing of smooth sds for tve spline coefs - int smooth_idx[S > 0 ? max(smooth_map) : 0, 2]; + array[S] int smooth_map; // indexing of smooth sds for tve spline coefs + array[S > 0 ? max(smooth_map) : 0, 2] int smooth_idx; // dimensions for random efffects structure, see table 3 of // https://cran.r-project.org/web/packages/lme4/vignettes/lmer.pdf int t; // num. terms (maybe 0) with a | in the glmer formula - int p[t]; // num. variables on the LHS of each | - int l[t]; // num. levels for the factor(s) on the RHS of each | + array[t] int p; // num. variables on the LHS of each | + array[t] int l; // num. levels for the factor(s) on the RHS of each | int q; // conceptually equals \sum_{i=1}^t p_i \times l_i // log crude event rate / time (for centering linear predictor) @@ -489,17 +489,17 @@ data { vector[nnz_icens] w_icens; vector[nnz_delay] w_delay; - int v_event[nnz_event]; - int v_lcens[nnz_lcens]; - int v_rcens[nnz_rcens]; - int v_icens[nnz_icens]; - int v_delay[nnz_delay]; + array[nnz_event] int v_event; + array[nnz_lcens] int v_lcens; + array[nnz_rcens] int v_rcens; + array[nnz_icens] int v_icens; + array[nnz_delay] int v_delay; - int u_event[(t > 0 && nevent > 0) ? nevent + 1 : 0]; - int u_lcens[(t > 0 && nlcens > 0) ? nlcens + 1 : 0]; - int u_rcens[(t > 0 && nrcens > 0) ? nrcens + 1 : 0]; - int u_icens[(t > 0 && nicens > 0) ? nicens + 1 : 0]; - int u_delay[(t > 0 && ndelay > 0) ? ndelay + 1 : 0]; + array[(t > 0 && nevent > 0) ? nevent + 1 : 0] int u_event; + array[(t > 0 && nlcens > 0) ? nlcens + 1 : 0] int u_lcens; + array[(t > 0 && nrcens > 0) ? nrcens + 1 : 0] int u_rcens; + array[(t > 0 && nicens > 0) ? nicens + 1 : 0] int u_icens; + array[(t > 0 && ndelay > 0) ? ndelay + 1 : 0] int u_delay; // random effects structure, with quadrature // nnz: number of non-zero elements in the Z matrix @@ -520,19 +520,19 @@ data { vector[nnz_qpts_icens] w_qpts_icens; vector[nnz_qpts_delay] w_qpts_delay; - int v_epts_event[nnz_epts_event]; - int v_qpts_event[nnz_qpts_event]; - int v_qpts_lcens[nnz_qpts_lcens]; - int v_qpts_rcens[nnz_qpts_rcens]; - int v_qpts_icens[nnz_qpts_icens]; - int v_qpts_delay[nnz_qpts_delay]; + array[nnz_epts_event] int v_epts_event; + array[nnz_qpts_event] int v_qpts_event; + array[nnz_qpts_lcens] int v_qpts_lcens; + array[nnz_qpts_rcens] int v_qpts_rcens; + array[nnz_qpts_icens] int v_qpts_icens; + array[nnz_qpts_delay] int v_qpts_delay; - int u_epts_event[(t > 0 && Nevent > 0) ? Nevent + 1 : 0]; - int u_qpts_event[(t > 0 && qevent > 0) ? qevent + 1 : 0]; - int u_qpts_lcens[(t > 0 && qlcens > 0) ? qlcens + 1 : 0]; - int u_qpts_rcens[(t > 0 && qrcens > 0) ? qrcens + 1 : 0]; - int u_qpts_icens[(t > 0 && qicens > 0) ? qicens + 1 : 0]; - int u_qpts_delay[(t > 0 && qdelay > 0) ? qdelay + 1 : 0]; + array[(t > 0 && Nevent > 0) ? Nevent + 1 : 0] int u_epts_event; + array[(t > 0 && qevent > 0) ? qevent + 1 : 0] int u_qpts_event; + array[(t > 0 && qlcens > 0) ? qlcens + 1 : 0] int u_qpts_lcens; + array[(t > 0 && qrcens > 0) ? qrcens + 1 : 0] int u_qpts_rcens; + array[(t > 0 && qicens > 0) ? qicens + 1 : 0] int u_qpts_icens; + array[(t > 0 && qdelay > 0) ? qdelay + 1 : 0] int u_qpts_delay; // basis matrices for M-splines / I-splines, without quadrature matrix[nevent,nvars] basis_event; // at event time @@ -637,8 +637,8 @@ data { int len_theta_L; // length of the theta_L vector int len_concentration; int len_regularization; - real concentration[len_concentration]; - real regularization[len_regularization]; + array[len_concentration] real concentration; + array[len_regularization] real regularization; int special_case; // is the only term (1|group) } @@ -649,23 +649,23 @@ transformed data { int sc = special_case; - int V_event[sc ? t : 0, nevent] = make_V(nevent, sc ? t : 0, v_event); - int V_lcens[sc ? t : 0, nlcens] = make_V(nlcens, sc ? t : 0, v_lcens); - int V_rcens[sc ? t : 0, nrcens] = make_V(nrcens, sc ? t : 0, v_rcens); - int V_icens[sc ? t : 0, nicens] = make_V(nicens, sc ? t : 0, v_icens); - int V_delay[sc ? t : 0, ndelay] = make_V(ndelay, sc ? t : 0, v_delay); + array[sc ? t : 0, nevent] int V_event = make_V(nevent, sc ? t : 0, v_event); + array[sc ? t : 0, nlcens] int V_lcens = make_V(nlcens, sc ? t : 0, v_lcens); + array[sc ? t : 0, nrcens] int V_rcens = make_V(nrcens, sc ? t : 0, v_rcens); + array[sc ? t : 0, nicens] int V_icens = make_V(nicens, sc ? t : 0, v_icens); + array[sc ? t : 0, ndelay] int V_delay = make_V(ndelay, sc ? t : 0, v_delay); - int V_epts_event[sc ? t : 0, Nevent] = make_V(Nevent, sc ? t : 0, v_epts_event); - int V_qpts_event[sc ? t : 0, qevent] = make_V(qevent, sc ? t : 0, v_qpts_event); - int V_qpts_lcens[sc ? t : 0, qlcens] = make_V(qlcens, sc ? t : 0, v_qpts_lcens); - int V_qpts_rcens[sc ? t : 0, qrcens] = make_V(qrcens, sc ? t : 0, v_qpts_rcens); - int V_qpts_icens[sc ? t : 0, qicens] = make_V(qicens, sc ? t : 0, v_qpts_icens); - int V_qpts_delay[sc ? t : 0, qdelay] = make_V(qdelay, sc ? t : 0, v_qpts_delay); + array[sc ? t : 0, Nevent] int V_epts_event = make_V(Nevent, sc ? t : 0, v_epts_event); + array[sc ? t : 0, qevent] int V_qpts_event = make_V(qevent, sc ? t : 0, v_qpts_event); + array[sc ? t : 0, qlcens] int V_qpts_lcens = make_V(qlcens, sc ? t : 0, v_qpts_lcens); + array[sc ? t : 0, qrcens] int V_qpts_rcens = make_V(qrcens, sc ? t : 0, v_qpts_rcens); + array[sc ? t : 0, qicens] int V_qpts_icens = make_V(qicens, sc ? t : 0, v_qpts_icens); + array[sc ? t : 0, qdelay] int V_qpts_delay = make_V(qdelay, sc ? t : 0, v_qpts_delay); int pos = 1; int len_z_T = 0; int len_rho = sum(p) - t; - real delta[len_concentration]; + array[len_concentration] real delta; for (i in 1:t) { if (p[i] > 1) { @@ -687,7 +687,7 @@ parameters { vector[K] z_beta; // intercept - real gamma[has_intercept == 1]; + array[has_intercept == 1] real gamma; // unscaled basehaz parameters // exp model: nvars = 0, ie. no aux parameter @@ -712,11 +712,11 @@ parameters { vector[t] tau; // parameters for priors - real global[hs]; - vector[hs > 0 ? K : 0] local[hs]; - real caux[hs > 0]; - vector[K] mix[prior_dist == 5 || prior_dist == 6]; - real ool[prior_dist == 6]; + array[hs] real global; + array[hs] vector[hs > 0 ? K : 0] local; + array[hs > 0] real caux; + array[prior_dist == 5 || prior_dist == 6] vector[K] mix; + array[prior_dist == 6] real ool; } transformed parameters { @@ -822,7 +822,7 @@ model { if (nrcens > 0) eta_rcens += log_crude_event_rate; if (nicens > 0) eta_icens += log_crude_event_rate; if (ndelay > 0) eta_delay += log_crude_event_rate; - + // add on intercept to linear predictor if (has_intercept == 1) { if (nevent > 0) eta_event += gamma[1]; @@ -984,8 +984,8 @@ model { if (qrcens > 0) eta_qpts_rcens += log_crude_event_rate; if (qicens > 0) eta_qpts_icenl += log_crude_event_rate; if (qicens > 0) eta_qpts_icenu += log_crude_event_rate; - if (qdelay > 0) eta_qpts_delay += log_crude_event_rate; - + if (qdelay > 0) eta_qpts_delay += log_crude_event_rate; + // add on intercept to linear predictor if (has_intercept == 1) { if (Nevent > 0) eta_epts_event += gamma[1];