{"id":32199392,"url":"https://github.com/boennecd/mmcif","last_synced_at":"2026-02-19T07:31:01.126Z","repository":{"id":38614686,"uuid":"457342612","full_name":"boennecd/mmcif","owner":"boennecd","description":"Fits the mixed cumulative incidence function models suggested by Cederkvist et al (2018; https://doi.org/10.1093%2Fbiostatistics%2Fkxx072) which decomposes within cluster dependence of risk and timing.","archived":false,"fork":false,"pushed_at":"2022-11-15T17:26:20.000Z","size":5471,"stargazers_count":0,"open_issues_count":0,"forks_count":0,"subscribers_count":1,"default_branch":"main","last_synced_at":"2025-10-22T03:34:17.069Z","etag":null,"topics":["competing-risk","composite-likelihood","mixed-models","sandwich-estimator","survival-analysis"],"latest_commit_sha":null,"homepage":"","language":"HTML","has_issues":true,"has_wiki":null,"has_pages":null,"mirror_url":null,"source_name":null,"license":"gpl-3.0","status":null,"scm":"git","pull_requests_enabled":true,"icon_url":"https://github.com/boennecd.png","metadata":{"files":{"readme":"README.md","changelog":null,"contributing":null,"funding":null,"license":"LICENSE.md","code_of_conduct":null,"threat_model":null,"audit":null,"citation":null,"codeowners":null,"security":null,"support":null}},"created_at":"2022-02-09T12:08:19.000Z","updated_at":"2022-11-15T17:23:37.000Z","dependencies_parsed_at":"2023-01-21T08:45:27.091Z","dependency_job_id":null,"html_url":"https://github.com/boennecd/mmcif","commit_stats":null,"previous_names":[],"tags_count":3,"template":false,"template_full_name":null,"purl":"pkg:github/boennecd/mmcif","repository_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmmcif","tags_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmmcif/tags","releases_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmmcif/releases","manifests_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmmcif/manifests","owner_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/owners/boennecd","download_url":"https://codeload.github.com/boennecd/mmcif/tar.gz/refs/heads/main","sbom_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories/boennecd%2Fmmcif/sbom","scorecard":null,"host":{"name":"GitHub","url":"https://github.com","kind":"github","repositories_count":286080680,"owners_count":29606798,"icon_url":"https://github.com/github.png","version":null,"created_at":"2022-05-30T11:31:42.601Z","updated_at":"2026-02-19T06:47:36.664Z","status":"ssl_error","status_checked_at":"2026-02-19T06:45:47.551Z","response_time":117,"last_error":"SSL_connect returned=1 errno=0 peeraddr=140.82.121.5:443 state=error: unexpected eof while reading","robots_txt_status":"success","robots_txt_updated_at":"2025-07-24T06:49:26.215Z","robots_txt_url":"https://github.com/robots.txt","online":false,"can_crawl_api":true,"host_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub","repositories_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repositories","repository_names_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/repository_names","owners_url":"https://repos.ecosyste.ms/api/v1/hosts/GitHub/owners"}},"keywords":["competing-risk","composite-likelihood","mixed-models","sandwich-estimator","survival-analysis"],"created_at":"2025-10-22T03:14:48.146Z","updated_at":"2026-02-19T07:31:01.108Z","avatar_url":"https://github.com/boennecd.png","language":"HTML","funding_links":[],"categories":[],"sub_categories":[],"readme":"\n# MMCIF: Mixed Multivariate Cumulative Incidence Functions\n\n[![R-CMD-check](https://github.com/boennecd/mmcif/workflows/R-CMD-check/badge.svg)](https://github.com/boennecd/mmcif/actions)\n[![](https://www.r-pkg.org/badges/version/mmcif)](https://CRAN.R-project.org/package=mmcif)\n[![CRAN RStudio mirror\ndownloads](http://cranlogs.r-pkg.org/badges/mmcif)](https://CRAN.R-project.org/package=mmcif)\n\nThis package provides an implementation of the model introduced by\nCederkvist et al. (2018) to model within-cluster dependence of both risk\nand timing in competing risk. For interested readers, a vignette on\ncomputational details can be found by calling\n`vignette(\"mmcif-comp-details\", \"mmcif\")`.\n\n## Installation\n\nThe package can be installed from Github by calling\n\n``` r\nlibrary(remotes)\ninstall_github(\"boennecd/mmcif\", build_vignettes = TRUE)\n```\n\nThe code benefits from being build with automatic vectorization so\nhaving e.g.  `-O3` in the `CXX17FLAGS` flags in your Makevars file may\nbe useful.\n\n## The Model\n\nThe conditional cumulative incidence functions for cause\n![k](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;k\n\"k\") of individual\n![j](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;j\n\"j\") in cluster\n![i](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;i\n\"i\") is\n\n \n![\\\\begin{align\\*} F\\_{kij}(t\\\\mid \\\\vec u\\_i, \\\\vec\\\\eta\\_i) \u0026=\n\\\\pi\\_k(\\\\vec z\\_{ij}, \\\\vec u\\_i) \\\\Phi(-\\\\vec\nx\\_{ij}(t)^\\\\top\\\\vec\\\\gamma\\_k - \\\\eta\\_{ik}) \\\\\\\\ \\\\pi\\_k(\\\\vec\nz\\_{ij}, \\\\vec u\\_i) \u0026= \\\\frac{\\\\exp(\\\\vec z\\_{ij}^\\\\top\\\\vec\\\\beta\\_k +\nu\\_{ik})}{1 + \\\\sum\\_{l = 1}^K\\\\exp(\\\\vec z\\_{ij}^\\\\top\\\\vec\\\\beta\\_l +\nu\\_{il})} \\\\\\\\ \\\\begin{pmatrix} \\\\vec U\\_i \\\\\\\\ \\\\vec\\\\eta\\_i\n\\\\end{pmatrix} \u0026\\\\sim\nN^{(2K)}(\\\\vec 0;\\\\Sigma).\\\\end{align\\*}](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cbegin%7Balign%2A%7D%20F_%7Bkij%7D%28t%5Cmid%20%5Cvec%20u_i%2C%20%5Cvec%5Ceta_i%29%20%26%3D%20%5Cpi_k%28%5Cvec%20z_%7Bij%7D%2C%20%5Cvec%20u_i%29%20%5CPhi%28-%5Cvec%20x_%7Bij%7D%28t%29%5E%5Ctop%5Cvec%5Cgamma_k%20-%20%5Ceta_%7Bik%7D%29%20%5C%5C%20%5Cpi_k%28%5Cvec%20z_%7Bij%7D%2C%20%5Cvec%20u_i%29%20%26%3D%20%5Cfrac%7B%5Cexp%28%5Cvec%20z_%7Bij%7D%5E%5Ctop%5Cvec%5Cbeta_k%20%2B%20u_%7Bik%7D%29%7D%7B1%20%2B%20%5Csum_%7Bl%20%3D%201%7D%5EK%5Cexp%28%5Cvec%20z_%7Bij%7D%5E%5Ctop%5Cvec%5Cbeta_l%20%2B%20u_%7Bil%7D%29%7D%20%5C%5C%20%5Cbegin%7Bpmatrix%7D%20%5Cvec%20U_i%20%5C%5C%20%5Cvec%5Ceta_i%20%5Cend%7Bpmatrix%7D%20%26%5Csim%20N%5E%7B%282K%29%7D%28%5Cvec%200%3B%5CSigma%29.%5Cend%7Balign%2A%7D\n\"\\\\begin{align*} F_{kij}(t\\\\mid \\\\vec u_i, \\\\vec\\\\eta_i) \u0026= \\\\pi_k(\\\\vec z_{ij}, \\\\vec u_i) \\\\Phi(-\\\\vec x_{ij}(t)^\\\\top\\\\vec\\\\gamma_k - \\\\eta_{ik}) \\\\\\\\ \\\\pi_k(\\\\vec z_{ij}, \\\\vec u_i) \u0026= \\\\frac{\\\\exp(\\\\vec z_{ij}^\\\\top\\\\vec\\\\beta_k + u_{ik})}{1 + \\\\sum_{l = 1}^K\\\\exp(\\\\vec z_{ij}^\\\\top\\\\vec\\\\beta_l + u_{il})} \\\\\\\\ \\\\begin{pmatrix} \\\\vec U_i \\\\\\\\ \\\\vec\\\\eta_i \\\\end{pmatrix} \u0026\\\\sim N^{(2K)}(\\\\vec 0;\\\\Sigma).\\\\end{align*}\") \n\nwhere there are\n![K](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;K\n\"K\") competing risks. The ![\\\\vec\nx\\_{ij}(t)^\\\\top\\\\vec\\\\gamma\\_k](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20x_%7Bij%7D%28t%29%5E%5Ctop%5Cvec%5Cgamma_k\n\"\\\\vec x_{ij}(t)^\\\\top\\\\vec\\\\gamma_k\")’s for the trajectory must be\nconstrained to be monotonically decreasing in\n![t](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;t\n\"t\"). The covariates for the trajectory in this package are defined as\n\n \n![\\\\vec x\\_{ij}(t) = (\\\\vec h(t)^\\\\top, \\\\vec\nz\\_{ij}^\\\\top)^\\\\top](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20x_%7Bij%7D%28t%29%20%3D%20%28%5Cvec%20h%28t%29%5E%5Ctop%2C%20%5Cvec%20z_%7Bij%7D%5E%5Ctop%29%5E%5Ctop\n\"\\\\vec x_{ij}(t) = (\\\\vec h(t)^\\\\top, \\\\vec z_{ij}^\\\\top)^\\\\top\") \n\nfor a spline basis ![\\\\vec\nh](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20h\n\"\\\\vec h\") and known covariates ![\\\\vec\nz\\_{ij}](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20z_%7Bij%7D\n\"\\\\vec z_{ij}\") which are also used in the risk part of the model.\n\n## Example\n\nWe start with a simple example where there are ![K\n= 2](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;K%20%3D%202\n\"K = 2\") competing risks and\n\n \n![\\\\begin{align\\*} \\\\vec x\\_{ij}(t) \u0026=\n\\\\left(\\\\text{arcthan}\\\\left(\\\\frac{t -\n\\\\delta/2}{\\\\delta/2}\\\\right), 1, a\\_{ij}, b\\_{ij}\\\\right) \\\\\\\\ a\\_{ij}\n\u0026\\\\sim N(0, 1) \\\\\\\\\nb\\_{ij} \u0026\\\\sim \\\\text{Unif}(-1, 1)\\\\\\\\ \\\\vec z\\_{ij} \u0026= (1, a\\_{ij},\nb\\_{ij})\n\\\\end{align\\*}](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cbegin%7Balign%2A%7D%20%5Cvec%20x_%7Bij%7D%28t%29%20%26%3D%20%5Cleft%28%5Ctext%7Barcthan%7D%5Cleft%28%5Cfrac%7Bt%20-%20%5Cdelta%2F2%7D%7B%5Cdelta%2F2%7D%5Cright%29%2C%201%2C%20a_%7Bij%7D%2C%20b_%7Bij%7D%5Cright%29%20%5C%5C%20a_%7Bij%7D%20%26%5Csim%20N%280%2C%201%29%20%5C%5C%0A%20b_%7Bij%7D%20%26%5Csim%20%5Ctext%7BUnif%7D%28-1%2C%201%29%5C%5C%20%5Cvec%20z_%7Bij%7D%20%26%3D%20%281%2C%20a_%7Bij%7D%2C%20b_%7Bij%7D%29%20%5Cend%7Balign%2A%7D\n\"\\\\begin{align*} \\\\vec x_{ij}(t) \u0026= \\\\left(\\\\text{arcthan}\\\\left(\\\\frac{t - \\\\delta/2}{\\\\delta/2}\\\\right), 1, a_{ij}, b_{ij}\\\\right) \\\\\\\\ a_{ij} \u0026\\\\sim N(0, 1) \\\\\\\\\n b_{ij} \u0026\\\\sim \\\\text{Unif}(-1, 1)\\\\\\\\ \\\\vec z_{ij} \u0026= (1, a_{ij}, b_{ij}) \\\\end{align*}\") \n\nWe set the parameters below and plot the conditional cumulative\nincidence functions when the random effects are zero and the covariates\nare zero, ![a\\_{ij} = b\\_{ij}\n= 0](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;a_%7Bij%7D%20%3D%20b_%7Bij%7D%20%3D%200\n\"a_{ij} = b_{ij} = 0\").\n\n``` r\n# assign model parameters\nn_causes \u003c- 2L\ndelta \u003c- 2\n\n# set the betas\ncoef_risk \u003c- c(.67, 1, .1, -.4, .25, .3) |\u003e \n matrix(ncol = n_causes)\n\n# set the gammas\ncoef_traject \u003c- c(-.8, -.45, .8, .4, -1.2, .15, .25, -.2) |\u003e \n matrix(ncol = n_causes)\n\n# plot the conditional cumulative incidence functions when random effects and \n# covariates are all zero\nlocal({\n probs \u003c- exp(coef_risk[1, ]) / (1 + sum(exp(coef_risk[1, ])))\n par(mar = c(5, 5, 1, 1), mfcol = c(1, 2))\n \n for(i in 1:2){\n plot(\\(x) probs[i] * pnorm(\n -coef_traject[1, i] * atanh((x - delta / 2) / (delta / 2)) - \n coef_traject[2, i]),\n xlim = c(0, delta), ylim = c(0, 1), bty = \"l\", xlab = \"Time\", \n ylab = sprintf(\"Cumulative incidence; cause %d\", i),\n yaxs = \"i\", xaxs = \"i\")\n grid()\n }\n})\n```\n\n\u003cimg src=\"man/figures/README-assign_model_parameters-1.png\" width=\"100%\" /\u003e\n\n``` r\n\n# set the covariance matrix\nSigma \u003c- c(0.306, 0.008, -0.138, 0.197, 0.008, 0.759, 0.251, \n-0.25, -0.138, 0.251, 0.756, -0.319, 0.197, -0.25, -0.319, 0.903) |\u003e \n matrix(2L * n_causes)\n```\n\nNext, we assign a function to simulate clusters. The cluster sizes are\nuniformly sampled from one to the maximum size. The censoring times are\ndrawn from a uniform distribution from zero to\n![3\\\\delta](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;3%5Cdelta\n\"3\\\\delta\").\n\n``` r\nlibrary(mvtnorm)\n\n# simulates a data set with a given number of clusters and maximum number of \n# observations per cluster\nsim_dat \u003c- \\(n_clusters, max_cluster_size){\n stopifnot(max_cluster_size \u003e 0,\n n_clusters \u003e 0)\n \n cluster_id \u003c- 0L\n apply(rmvnorm(n_clusters, sigma = Sigma), 1, \\(rng_effects){\n U \u003c- head(rng_effects, n_causes)\n eta \u003c- tail(rng_effects, n_causes)\n \n n_obs \u003c- sample.int(max_cluster_size, 1L)\n cluster_id \u003c\u003c- cluster_id + 1L\n \n # draw the cause\n covs \u003c- cbind(a = rnorm(n_obs), b = runif(n_obs, -1))\n Z \u003c- cbind(1, covs)\n \n cond_logits_exp \u003c- exp(Z %*% coef_risk + rep(U, each = n_obs)) |\u003e \n cbind(1)\n cond_probs \u003c- cond_logits_exp / rowSums(cond_logits_exp)\n cause \u003c- apply(cond_probs, 1, \n \\(prob) sample.int(n_causes + 1L, 1L, prob = prob))\n \n # compute the observed time if needed\n obs_time \u003c- mapply(\\(cause, idx){\n if(cause \u003e n_causes)\n return(delta)\n \n # can likely be done smarter but this is more general\n coefs \u003c- coef_traject[, cause]\n offset \u003c- sum(Z[idx, ] * coefs[-1]) + eta[cause]\n rng \u003c- runif(1)\n eps \u003c- .Machine$double.eps\n root \u003c- uniroot(\n \\(x) rng - pnorm(\n -coefs[1] * atanh((x - delta / 2) / (delta / 2)) - offset), \n c(eps^2, delta * (1 - eps)), tol = 1e-12)$root\n }, cause, 1:n_obs)\n \n cens \u003c- runif(n_obs, max = 3 * delta)\n has_finite_trajectory_prob \u003c- cause \u003c= n_causes\n is_censored \u003c- which(!has_finite_trajectory_prob | cens \u003c obs_time)\n \n if(length(is_censored) \u003e 0){\n obs_time[is_censored] \u003c- pmin(delta, cens[is_censored])\n cause[is_censored] \u003c- n_causes + 1L\n }\n \n data.frame(covs, cause, time = obs_time, cluster_id)\n }, simplify = FALSE) |\u003e \n do.call(what = rbind)\n}\n```\n\nWe then sample a data set.\n\n``` r\n# sample a data set\nset.seed(8401828)\nn_clusters \u003c- 1000L\nmax_cluster_size \u003c- 5L\ndat \u003c- sim_dat(n_clusters, max_cluster_size = max_cluster_size)\n\n# show some stats\nNROW(dat) # number of individuals\n#\u003e [1] 2962\ntable(dat$cause) # distribution of causes (3 is censored)\n#\u003e \n#\u003e 1 2 3 \n#\u003e 1249 542 1171\n\n# distribution of observed times by cause\ntapply(dat$time, dat$cause, quantile, \n probs = seq(0, 1, length.out = 11), na.rm = TRUE)\n#\u003e $`1`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 1.615e-05 4.918e-03 2.737e-02 9.050e-02 2.219e-01 4.791e-01 8.506e-01 1.358e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.744e+00 1.953e+00 2.000e+00 \n#\u003e \n#\u003e $`2`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.001448 0.050092 0.157119 0.276072 0.431094 0.669010 0.964643 1.336520 \n#\u003e 80% 90% 100% \n#\u003e 1.607221 1.863063 1.993280 \n#\u003e \n#\u003e $`3`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.002123 0.246899 0.577581 1.007699 1.526068 2.000000 2.000000 2.000000 \n#\u003e 80% 90% 100% \n#\u003e 2.000000 2.000000 2.000000\n```\n\nThen we setup the C++ object to do the computation.\n\n``` r\nlibrary(mmcif)\ncomp_obj \u003c- mmcif_data(\n ~ a + b, dat, cause = cause, time = time, cluster_id = cluster_id,\n max_time = delta, spline_df = 4L)\n```\n\nThe `mmcif_data` function does not work with\n\n \n![h(t) = \\\\text{arcthan}\\\\left(\\\\frac{t -\n\\\\delta/2}{\\\\delta/2}\\\\right)](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;h%28t%29%20%3D%20%5Ctext%7Barcthan%7D%5Cleft%28%5Cfrac%7Bt%20-%20%5Cdelta%2F2%7D%7B%5Cdelta%2F2%7D%5Cright%29\n\"h(t) = \\\\text{arcthan}\\\\left(\\\\frac{t - \\\\delta/2}{\\\\delta/2}\\\\right)\") \n\nbut instead with ![\\\\vec\ng(h(t))](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20g%28h%28t%29%29\n\"\\\\vec g(h(t))\") where ![\\\\vec\ng](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20g\n\"\\\\vec g\") returns a natural cubic spline basis functions. The knots are\nbased on quantiles of\n![h(t)](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;h%28t%29\n\"h(t)\") evaluated on the event times. The knots differ for each type of\ncompeting risk. The degrees of freedom of the splines is controlled with\nthe `spline_df` argument. There is a `constraints` element on the object\nreturned by the `mmcif_data` function which contains matrices that\nensures that the ![\\\\vec\nx\\_{ij}(t)^\\\\top\\\\vec\\\\gamma\\_k](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20x_%7Bij%7D%28t%29%5E%5Ctop%5Cvec%5Cgamma_k\n\"\\\\vec x_{ij}(t)^\\\\top\\\\vec\\\\gamma_k\")s are monotonically decreasing if\n![C\\\\vec\\\\zeta \\\u003e\n\\\\vec 0](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;C%5Cvec%5Czeta%20%3E%20%5Cvec%200\n\"C\\\\vec\\\\zeta \\\u003e \\\\vec 0\") where\n![C](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;C\n\"C\") is one of matrices and\n![\\\\vec\\\\zeta](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%5Czeta\n\"\\\\vec\\\\zeta\") is the concatenated vector of model parameters.\n\nThe time to compute the log composite likelihood is illustrated below.\n\n``` r\nNCOL(comp_obj$pair_indices) # the number of pairs in the composite likelihood\n#\u003e [1] 3911\nlength(comp_obj$singletons) # the number of clusters with one observation\n#\u003e [1] 202\n\n# we need to find the combination of the spline bases that yield a straight \n# line to construct the true values using the splines. You can skip this\ncomb_slope \u003c- sapply(comp_obj$spline, \\(spline){\n boundary_knots \u003c- spline$boundary_knots\n pts \u003c- seq(boundary_knots[1], boundary_knots[2], length.out = 1000)\n lm.fit(cbind(1, spline$expansion(pts)), pts)$coef\n})\n\n# assign a function to compute the log composite likelihood\nll_func \u003c- \\(par, n_threads = 1L)\n mmcif_logLik(\n comp_obj, par = par, n_threads = n_threads, is_log_chol = FALSE)\n\n# the log composite likelihood at the true parameters\ncoef_traject_spline \u003c- \n rbind(comb_slope[-1, ] * rep(coef_traject[1, ], each = NROW(comb_slope) - 1), \n coef_traject[2, ] + comb_slope[1, ] * coef_traject[1, ],\n coef_traject[-(1:2), ])\ntrue_values \u003c- c(coef_risk, coef_traject_spline, Sigma)\nll_func(true_values)\n#\u003e [1] -7087\n\n# check the time to compute the log composite likelihood\nbench::mark(\n `one thread` = ll_func(n_threads = 1L, true_values),\n `two threads` = ll_func(n_threads = 2L, true_values),\n `three threads` = ll_func(n_threads = 3L, true_values),\n `four threads` = ll_func(n_threads = 4L, true_values), \n min_time = 4)\n#\u003e # A tibble: 4 × 6\n#\u003e expression min median `itr/sec` mem_alloc `gc/sec`\n#\u003e \u003cbch:expr\u003e \u003cbch:tm\u003e \u003cbch:tm\u003e \u003cdbl\u003e \u003cbch:byt\u003e \u003cdbl\u003e\n#\u003e 1 one thread 44ms 45.4ms 21.9 0B 0\n#\u003e 2 two threads 23ms 23.3ms 42.7 0B 0\n#\u003e 3 three threads 15.6ms 15.8ms 62.8 0B 0\n#\u003e 4 four threads 11.9ms 12.2ms 79.7 0B 0\n\n# next, we compute the gradient of the log composite likelihood at the true \n# parameters. First we assign a few functions to verify the result. You can \n# skip these\nupper_to_full \u003c- \\(x){\n dim \u003c- (sqrt(8 * length(x) + 1) - 1) / 2\n out \u003c- matrix(0, dim, dim)\n out[upper.tri(out, TRUE)] \u003c- x\n out[lower.tri(out)] \u003c- t(out)[lower.tri(out)]\n out\n}\nd_upper_to_full \u003c- \\(x){\n dim \u003c- (sqrt(8 * length(x) + 1) - 1) / 2\n out \u003c- matrix(0, dim, dim)\n out[upper.tri(out, TRUE)] \u003c- x\n out[upper.tri(out)] \u003c- out[upper.tri(out)] / 2\n out[lower.tri(out)] \u003c- t(out)[lower.tri(out)]\n out\n}\n\n# then we can compute the gradient with the function from the package and with \n# numerical differentiation\ngr_func \u003c- function(par, n_threads = 1L)\n mmcif_logLik_grad(comp_obj, par, n_threads = n_threads, is_log_chol = FALSE)\ngr_package \u003c- gr_func(true_values)\n\ntrue_values_upper \u003c- \n c(coef_risk, coef_traject_spline, Sigma[upper.tri(Sigma, TRUE)])\ngr_num \u003c- numDeriv::grad(\n \\(x) ll_func(c(head(x, -10), upper_to_full(tail(x, 10)))), \n true_values_upper, method = \"simple\")\n\n# they are very close but not exactly equal as expected (this is due to the \n# adaptive quadrature)\nrbind(\n `Numerical gradient` = \n c(head(gr_num, -10), d_upper_to_full(tail(gr_num, 10))), \n `Gradient package` = gr_package)\n#\u003e [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]\n#\u003e Numerical gradient -98.12 -35.08 -34.63 48.15 -5.095 65.07 54.22 -43.89 -27.01\n#\u003e Gradient package -98.03 -35.02 -34.61 48.15 -5.050 65.09 54.26 -43.86 -26.99\n#\u003e [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [,18]\n#\u003e Numerical gradient -25.23 -36.50 -69.74 -60.26 -66.81 42.02 14.85 -7.650 -2.324\n#\u003e Gradient package -25.21 -36.43 -69.63 -60.22 -66.80 42.04 14.86 -7.641 -2.294\n#\u003e [,19] [,20] [,21] [,22] [,23] [,24] [,25] [,26] [,27]\n#\u003e Numerical gradient -5.068 -43.15 10.28 -1.492 4.406 0.2705 -1.492 10.41 -0.2874\n#\u003e Gradient package -5.024 -43.13 10.27 -1.464 4.420 0.2806 -1.464 10.86 -0.3570\n#\u003e [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36]\n#\u003e Numerical gradient -4.417 4.406 -0.2874 -36.46 6.307 0.2705 -4.417 6.307 8.955\n#\u003e Gradient package -4.402 4.420 -0.3570 -36.42 6.311 0.2806 -4.402 6.311 8.967\n\n# check the time to compute the gradient of the log composite likelihood\nbench::mark(\n `one thread` = gr_func(n_threads = 1L, true_values),\n `two threads` = gr_func(n_threads = 2L, true_values),\n `three threads` = gr_func(n_threads = 3L, true_values),\n `four threads` = gr_func(n_threads = 4L, true_values), \n min_time = 4)\n#\u003e # A tibble: 4 × 6\n#\u003e expression min median `itr/sec` mem_alloc `gc/sec`\n#\u003e \u003cbch:expr\u003e \u003cbch:tm\u003e \u003cbch:tm\u003e \u003cdbl\u003e \u003cbch:byt\u003e \u003cdbl\u003e\n#\u003e 1 one thread 68.8ms 69.9ms 14.2 336B 0\n#\u003e 2 two threads 35.8ms 36.5ms 27.1 336B 0\n#\u003e 3 three threads 24.5ms 24.8ms 40.3 336B 0\n#\u003e 4 four threads 18.9ms 19.3ms 51.1 336B 0\n```\n\n#### Optimization\n\nThen we optimize the parameters.\n\n``` r\n# find the starting values\nsystem.time(start \u003c- mmcif_start_values(comp_obj, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 0.084 0.008 0.026\n\n# the maximum likelihood without the random effects. Note that this is not \n# comparable with the composite likelihood\nattr(start, \"logLik\")\n#\u003e [1] -2650\n\n# examples of using log_chol and log_chol_inv\nlog_chol(Sigma)\n#\u003e [1] -0.59209 0.01446 -0.13801 -0.24947 0.29229 -0.24852 0.35613 -0.29291\n#\u003e [9] -0.18532 -0.21077\nstopifnot(all.equal(Sigma, log_chol(Sigma) |\u003e log_chol_inv()))\n\n# set true values\ntruth \u003c- c(coef_risk, coef_traject_spline, log_chol(Sigma))\n\n# we can verify that the gradient is correct\ngr_package \u003c- mmcif_logLik_grad(\n comp_obj, truth, n_threads = 4L, is_log_chol = TRUE)\ngr_num \u003c- numDeriv::grad(\n mmcif_logLik, truth, object = comp_obj, n_threads = 4L, is_log_chol = TRUE, \n method = \"simple\")\n\nrbind(`Numerical gradient` = gr_num, `Gradient package` = gr_package)\n#\u003e [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]\n#\u003e Numerical gradient -98.12 -35.08 -34.63 48.15 -5.095 65.07 54.22 -43.89 -27.01\n#\u003e Gradient package -98.03 -35.02 -34.61 48.15 -5.050 65.09 54.26 -43.86 -26.99\n#\u003e [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [,18]\n#\u003e Numerical gradient -25.23 -36.50 -69.74 -60.26 -66.81 42.02 14.85 -7.650 -2.324\n#\u003e Gradient package -25.21 -36.43 -69.63 -60.22 -66.80 42.04 14.86 -7.641 -2.294\n#\u003e [,19] [,20] [,21] [,22] [,23] [,24] [,25] [,26] [,27]\n#\u003e Numerical gradient -5.068 -43.15 5.159 -4.346 17.90 27.54 -25.51 -46.20 3.408\n#\u003e Gradient package -5.024 -43.13 5.150 -4.263 18.55 27.55 -25.61 -46.14 3.422\n#\u003e [,28] [,29] [,30]\n#\u003e Numerical gradient -9.259 6.518 11.75\n#\u003e Gradient package -9.233 6.520 11.77\n\n# optimize the log composite likelihood\nsystem.time(fit \u003c- mmcif_fit(start$upper, comp_obj, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 46.676 0.019 11.704\n\n# the log composite likelihood at different points\nmmcif_logLik(comp_obj, truth, n_threads = 4L, is_log_chol = TRUE)\n#\u003e [1] -7087\nmmcif_logLik(comp_obj, start$upper, n_threads = 4L, is_log_chol = TRUE)\n#\u003e [1] -7572\n-fit$value\n#\u003e [1] -7050\n```\n\nWe may reduce the estimation time by using a different number of\nquadrature nodes starting with fewer nodes successively updating the\nfits as shown below.\n\n``` r\n# the number of nodes we used\nlength(comp_obj$ghq_data[[1]])\n#\u003e [1] 5\n\n# with successive updates\nghq_lists \u003c- lapply(\n setNames(c(2L, 6L), c(2L, 6L)), \n \\(n_nodes) \n fastGHQuad::gaussHermiteData(n_nodes) |\u003e \n with(list(node = x, weight = w)))\n\nsystem.time(\n fits \u003c- mmcif_fit(\n start$upper, comp_obj, n_threads = 4L, ghq_data = ghq_lists))\n#\u003e user system elapsed \n#\u003e 39.285 0.012 9.831\n\n# compare the estimates\nrbind(sapply(fits, `[[`, \"par\") |\u003e t(), \n `Previous` = fit$par)\n#\u003e cause1:risk:(Intercept) cause1:risk:a cause1:risk:b\n#\u003e 0.5584 0.9124 0.08503\n#\u003e 0.5854 0.9494 0.08946\n#\u003e Previous 0.5868 0.9495 0.08984\n#\u003e cause2:risk:(Intercept) cause2:risk:a cause2:risk:b cause1:spline1\n#\u003e -0.4267 0.1942 0.4920 -2.751\n#\u003e -0.4068 0.2085 0.5040 -2.761\n#\u003e Previous -0.4088 0.2086 0.5051 -2.761\n#\u003e cause1:spline2 cause1:spline3 cause1:spline4\n#\u003e -3.624 -6.512 -4.968\n#\u003e -3.636 -6.536 -4.983\n#\u003e Previous -3.636 -6.536 -4.983\n#\u003e cause1:traject:(Intercept) cause1:traject:a cause1:traject:b\n#\u003e 2.782 0.7863 0.3197\n#\u003e 2.789 0.7898 0.3207\n#\u003e Previous 2.789 0.7898 0.3207\n#\u003e cause2:spline1 cause2:spline2 cause2:spline3 cause2:spline4\n#\u003e -2.819 -3.233 -6.063 -4.771\n#\u003e -2.890 -3.310 -6.214 -4.881\n#\u003e Previous -2.890 -3.309 -6.213 -4.880\n#\u003e cause2:traject:(Intercept) cause2:traject:a cause2:traject:b\n#\u003e 3.326 0.2420 -0.3430\n#\u003e 3.365 0.2468 -0.3479\n#\u003e Previous 3.363 0.2468 -0.3477\n#\u003e vcov:risk1:risk1 vcov:risk1:risk2 vcov:risk2:risk2 vcov:risk1:traject1\n#\u003e -1.0779 -0.26819 -0.3546 -0.18162\n#\u003e -0.4792 0.07051 -0.1160 -0.09138\n#\u003e Previous -0.4770 0.08131 -0.1043 -0.09116\n#\u003e vcov:risk2:traject1 vcov:traject1:traject1 vcov:risk1:traject2\n#\u003e 0.2717 -0.2781 0.4359\n#\u003e 0.2791 -0.2546 0.2575\n#\u003e Previous 0.2768 -0.2536 0.2575\n#\u003e vcov:risk2:traject2 vcov:traject1:traject2 vcov:traject2:traject2\n#\u003e -0.4860 -0.03015 -0.2906\n#\u003e -0.4972 -0.10351 -0.1518\n#\u003e Previous -0.4939 -0.10619 -0.1505\n\nprint(fits[[length(fits)]]$value, digits = 10)\n#\u003e [1] 7050.314423\nprint(fit $value, digits = 10)\n#\u003e [1] 7050.351508\n```\n\nThen we compute the sandwich estimator. The Hessian is currently\ncomputed with numerical differentiation which is why it takes a while.\n\n``` r\nsystem.time(sandwich_est \u003c- mmcif_sandwich(comp_obj, fit$par, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 23.754 0.009 5.953\n\n# setting order equal to zero yield no Richardson extrapolation and just\n# standard symmetric difference quotient. This is less precise but faster \nsystem.time(sandwich_est_simple \u003c- \n mmcif_sandwich(comp_obj, fit$par, n_threads = 4L, order = 0L))\n#\u003e user system elapsed \n#\u003e 4.935 0.000 1.236\n```\n\n#### Estimates\n\nWe show the estimated and true the conditional cumulative incidence\nfunctions (the dashed curves are the estimates) when the random effects\nare zero and the covariates are zero, ![a\\_{ij} = b\\_{ij}\n= 0](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;a_%7Bij%7D%20%3D%20b_%7Bij%7D%20%3D%200\n\"a_{ij} = b_{ij} = 0\").\n\n``` r\nlocal({\n # get the estimates\n coef_risk_est \u003c- fit$par[comp_obj$indices$coef_risk] |\u003e \n matrix(ncol = n_causes)\n coef_traject_time_est \u003c- fit$par[comp_obj$indices$coef_trajectory_time] |\u003e \n matrix(ncol = n_causes)\n coef_traject_est \u003c- fit$par[comp_obj$indices$coef_trajectory] |\u003e \n matrix(ncol = n_causes)\n coef_traject_intercept_est \u003c- coef_traject_est[5, ]\n \n # compute the risk probabilities \n probs \u003c- exp(coef_risk[1, ]) / (1 + sum(exp(coef_risk[1, ])))\n probs_est \u003c- exp(coef_risk_est[1, ]) / (1 + sum(exp(coef_risk_est[1, ])))\n \n # plot the estimated and true conditional cumulative incidence functions. The\n # estimates are the dashed lines\n par(mar = c(5, 5, 1, 1), mfcol = c(1, 2))\n pts \u003c- seq(1e-8, delta * (1 - 1e-8), length.out = 1000)\n \n for(i in 1:2){\n true_vals \u003c- probs[i] * pnorm(\n -coef_traject[1, i] * atanh((pts - delta / 2) / (delta / 2)) - \n coef_traject[2, i])\n \n estimates \u003c- probs_est[i] * pnorm(\n -comp_obj$time_expansion(pts, cause = i) %*% coef_traject_time_est[, i] - \n coef_traject_intercept_est[i]) |\u003e drop()\n \n matplot(pts, cbind(true_vals, estimates), xlim = c(0, delta), \n ylim = c(0, 1), bty = \"l\", xlab = \"Time\", lty = c(1, 2),\n ylab = sprintf(\"Cumulative incidence; cause %d\", i),\n yaxs = \"i\", xaxs = \"i\", type = \"l\", col = \"black\")\n grid()\n }\n})\n```\n\n\u003cimg src=\"man/figures/README-compare_estimated_incidence_funcs-1.png\" width=\"100%\" /\u003e\n\nFurther illustrations of the estimated model are given below.\n\n``` r\n# the number of call we made\nfit$counts\n#\u003e function gradient \n#\u003e 438 269\nfit$outer.iterations\n#\u003e [1] 3\n\n# compute the standard errors from the sandwich estimator\nSEs \u003c- diag(sandwich_est) |\u003e sqrt()\nSEs_simple \u003c- diag(sandwich_est_simple) |\u003e sqrt()\n\n# compare the estimates with the true values\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$coef_risk],\n `Standard errors` = SEs[comp_obj$indices$coef_risk],\n `Standard errors simple` = SEs_simple[comp_obj$indices$coef_risk],\n Truth = truth[comp_obj$indices$coef_risk])\n#\u003e cause1:risk:(Intercept) cause1:risk:a cause1:risk:b\n#\u003e Estimate AGHQ 0.58676 0.94946 0.08984\n#\u003e Standard errors 0.07241 0.06901 0.10193\n#\u003e Standard errors simple 0.07241 0.06901 0.10193\n#\u003e Truth 0.67000 1.00000 0.10000\n#\u003e cause2:risk:(Intercept) cause2:risk:a cause2:risk:b\n#\u003e Estimate AGHQ -0.40878 0.20863 0.5051\n#\u003e Standard errors 0.09896 0.07073 0.1233\n#\u003e Standard errors simple 0.09896 0.07073 0.1233\n#\u003e Truth -0.40000 0.25000 0.3000\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$coef_trajectory],\n `Standard errors` = SEs[comp_obj$indices$coef_trajectory],\n `Standard errors simple` = SEs_simple[comp_obj$indices$coef_trajectory],\n Truth = truth[comp_obj$indices$coef_trajectory])\n#\u003e cause1:spline1 cause1:spline2 cause1:spline3\n#\u003e Estimate AGHQ -2.7613 -3.6362 -6.5362\n#\u003e Standard errors 0.1115 0.1320 0.2122\n#\u003e Standard errors simple 0.1116 0.1321 0.2122\n#\u003e Truth -2.8546 -3.5848 -6.5119\n#\u003e cause1:spline4 cause1:traject:(Intercept)\n#\u003e Estimate AGHQ -4.9826 2.7890\n#\u003e Standard errors 0.1573 0.1048\n#\u003e Standard errors simple 0.1573 0.1048\n#\u003e Truth -4.9574 2.8655\n#\u003e cause1:traject:a cause1:traject:b cause2:spline1\n#\u003e Estimate AGHQ 0.78980 0.32069 -2.8896\n#\u003e Standard errors 0.05136 0.06089 0.2251\n#\u003e Standard errors simple 0.05136 0.06089 0.2250\n#\u003e Truth 0.80000 0.40000 -2.5969\n#\u003e cause2:spline2 cause2:spline3 cause2:spline4\n#\u003e Estimate AGHQ -3.3089 -6.2127 -4.8797\n#\u003e Standard errors 0.2291 0.4477 0.3179\n#\u003e Standard errors simple 0.2290 0.4473 0.3176\n#\u003e Truth -3.3416 -6.0232 -4.6611\n#\u003e cause2:traject:(Intercept) cause2:traject:a\n#\u003e Estimate AGHQ 3.3634 0.24684\n#\u003e Standard errors 0.2574 0.06955\n#\u003e Standard errors simple 0.2572 0.06954\n#\u003e Truth 3.1145 0.25000\n#\u003e cause2:traject:b\n#\u003e Estimate AGHQ -0.3477\n#\u003e Standard errors 0.1059\n#\u003e Standard errors simple 0.1059\n#\u003e Truth -0.2000\n\nn_vcov \u003c- (2L * n_causes * (2L * n_causes + 1L)) %/% 2L\nSigma\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.306 0.008 -0.138 0.197\n#\u003e [2,] 0.008 0.759 0.251 -0.250\n#\u003e [3,] -0.138 0.251 0.756 -0.319\n#\u003e [4,] 0.197 -0.250 -0.319 0.903\nlog_chol_inv(tail(fit$par, n_vcov))\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.38517 0.05046 -0.05658 0.1598\n#\u003e [2,] 0.05046 0.81841 0.24202 -0.4241\n#\u003e [3,] -0.05658 0.24202 0.68717 -0.2426\n#\u003e [4,] 0.15978 -0.42407 -0.24261 1.0616\n\n# on the log Cholesky scale\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$vcov_upper],\n `Standard errors` = SEs[comp_obj$indices$vcov_upper],\n `Standard errors simple` = SEs_simple[comp_obj$indices$vcov_upper],\n Truth = truth[comp_obj$indices$vcov_upper])\n#\u003e vcov:risk1:risk1 vcov:risk1:risk2 vcov:risk2:risk2\n#\u003e Estimate AGHQ -0.4770 0.08131 -0.1043\n#\u003e Standard errors 0.2079 0.23574 0.1577\n#\u003e Standard errors simple 0.2079 0.23573 0.1577\n#\u003e Truth -0.5921 0.01446 -0.1380\n#\u003e vcov:risk1:traject1 vcov:risk2:traject1\n#\u003e Estimate AGHQ -0.09116 0.2768\n#\u003e Standard errors 0.14510 0.1155\n#\u003e Standard errors simple 0.14510 0.1155\n#\u003e Truth -0.24947 0.2923\n#\u003e vcov:traject1:traject1 vcov:risk1:traject2\n#\u003e Estimate AGHQ -0.2536 0.2575\n#\u003e Standard errors 0.1064 0.2402\n#\u003e Standard errors simple 0.1064 0.2402\n#\u003e Truth -0.2485 0.3561\n#\u003e vcov:risk2:traject2 vcov:traject1:traject2\n#\u003e Estimate AGHQ -0.4939 -0.1062\n#\u003e Standard errors 0.2011 0.1501\n#\u003e Standard errors simple 0.2011 0.1501\n#\u003e Truth -0.2929 -0.1853\n#\u003e vcov:traject2:traject2\n#\u003e Estimate AGHQ -0.1505\n#\u003e Standard errors 0.1871\n#\u003e Standard errors simple 0.1870\n#\u003e Truth -0.2108\n\n# on the original covariance matrix scale\nvcov_est \u003c- log_chol_inv(tail(fit$par, n_vcov))\nvcov_est[lower.tri(vcov_est)] \u003c- NA_real_\nvcov_SE \u003c- matrix(NA_real_, NROW(vcov_est), NCOL(vcov_est))\nvcov_SE[upper.tri(vcov_SE, TRUE)] \u003c- \n attr(sandwich_est, \"res vcov\") |\u003e diag() |\u003e sqrt() |\u003e \n tail(n_vcov)\n\nvcov_show \u003c- cbind(Estimates = vcov_est, NA, SEs = vcov_SE) \ncolnames(vcov_show) \u003c- \n c(rep(\"Est.\", NCOL(vcov_est)), \"\", rep(\"SE\", NCOL(vcov_est)))\nprint(vcov_show, na.print = \"\")\n#\u003e Est. Est. Est. Est. SE SE SE SE\n#\u003e [1,] 0.3852 0.05046 -0.05658 0.1598 0.1602 0.1509 0.08933 0.1506\n#\u003e [2,] 0.81841 0.24202 -0.4241 0.2723 0.11034 0.1815\n#\u003e [3,] 0.68717 -0.2426 0.11579 0.1033\n#\u003e [4,] 1.0616 0.2819\n\nSigma # the true values\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.306 0.008 -0.138 0.197\n#\u003e [2,] 0.008 0.759 0.251 -0.250\n#\u003e [3,] -0.138 0.251 0.756 -0.319\n#\u003e [4,] 0.197 -0.250 -0.319 0.903\n```\n\n#### Marginal Measures\n\nThe `mmcif_pd_univariate` function is provided to compute the marginal\nCIFs, the derivative of the marginal CIFs, and the marginal survival\nprobability.\n\n``` r\n# compute the univariate marginal CIFs\nex_dat \u003c- data.frame(a = c(-.5, .25), b = c(.1, .8))\n\ncompute_cif \u003c- \\(cause, time = .25){\n mmcif_pd_univariate(\n fit$par, comp_obj, newdata = ex_dat[1, ], cause = cause, \n time = time, type = \"cumulative\")\n}\n\nm_cifs \u003c- sapply(1:2, compute_cif)\nm_cifs\n#\u003e [1] 0.21531 0.06461\n\n# these match with the survival probability \nm_surv \u003c- compute_cif(3L)\nall.equal(m_surv, 1 - sum(m_cifs))\n#\u003e [1] TRUE\n\n# we can also get the derivative of the marginal CIFs\ncompute_dens \u003c- \\(cause, time = .25){\n mmcif_pd_univariate(\n fit$par, comp_obj, newdata = ex_dat[1, ], cause = cause, \n time = time, type = \"derivative\")\n}\n\ncompute_dens(2L)\n#\u003e [1] 0.1823\n\n# they integrate to the CIFS\nint_m_cifs \u003c- sapply(\n 1:2, \\(cause) \n integrate(Vectorize(compute_dens), 1e-12, .25, rel.tol = 1e-10, \n cause = cause)$value)\nall.equal(int_m_cifs, m_cifs) # ~ the same\n#\u003e [1] \"Mean relative difference: 1.106e-06\"\n\n# we can compute a marginal cause-specific hazard using these\nlocal({\n tis \u003c- seq(1e-2, 2 - 1e-2, length.out = 200)\n pd_wrap \u003c- \\(ti, type, cause)\n mmcif_pd_univariate(\n fit$par, comp_obj, newdata = ex_dat[1, ], cause = cause, \n time = ti, type = type, use_log = TRUE)\n \n log_m_survs \u003c- sapply(tis, pd_wrap, type = \"cumulative\", cause = 3L)\n log_dens \u003c- sapply(tis, pd_wrap, type = \"derivative\", cause = 2L)\n \n par(mar = c(5, 5, 1, 1))\n hazs \u003c- exp(log_dens - log_m_survs)\n plot(tis, hazs, xlab = \"Time\", type = \"l\", bty = \"l\",\n ylab = \"Marginal hazard\", ylim = range(0, hazs))\n grid()\n})\n```\n\n\u003cimg src=\"man/figures/README-show_mmcif_pd_univariate-1.png\" width=\"100%\" /\u003e\n\nThere is a bivariate version as well. This gives the marginal bivaraite\nCIFs, marginal survival probabilities, the marginal density, and\nmixtures thereof as illustrated below.\n\n``` r\n# wrapper to simplify calls to mmcif_pd_bivariate\nmmcif_pd_bivariate_wrap \u003c- \\(time = c(.25, 1.33), cause, type){\n mmcif_pd_bivariate(\n fit$par, comp_obj, newdata = ex_dat, cause = cause, \n time = time, ghq_data = ghq_lists[[2]], type = type)\n}\n\n# compute all configurations except for the double censored one\n(cause_combs \u003c- cbind(rep(1:3, each = 3), rep(1:3, 3)))\n#\u003e [,1] [,2]\n#\u003e [1,] 1 1\n#\u003e [2,] 1 2\n#\u003e [3,] 1 3\n#\u003e [4,] 2 1\n#\u003e [5,] 2 2\n#\u003e [6,] 2 3\n#\u003e [7,] 3 1\n#\u003e [8,] 3 2\n#\u003e [9,] 3 3\ncause_combs \u003c- cause_combs[rowSums(cause_combs) \u003c 6L, ]\nm_cifs \u003c- apply(cause_combs, 1, \\(cause){\n mmcif_pd_bivariate_wrap(cause = cause, type = c(\"cumulative\", \"cumulative\"))\n})\nm_cifs\n#\u003e [1] 0.09724 0.02519 0.09289 0.01221 0.02629 0.02612 0.21444 0.12867\n\n# we can recover the probability of both being censored\nm_surv \u003c- mmcif_pd_bivariate_wrap(\n cause = c(3L, 3L), type = c(\"cumulative\", \"cumulative\"))\nall.equal(m_surv, 1 - sum(m_cifs))\n#\u003e [1] TRUE\n\n# we can also compute the derivative of a CIF in one argument and the CIF in the \n# other\nmmcif_pd_bivariate_wrap(cause = c(1L, 1L), type = c(\"derivative\", \"cumulative\"))\n#\u003e [1] 0.07968\n\n# we can also compute the derivative in both\nmmcif_pd_bivariate_wrap(cause = c(1L, 1L), type = c(\"derivative\", \"derivative\"))\n#\u003e [1] 0.03915\n\n# they integrate numerically to roughly the right value\n(combs_to_test \u003c- cause_combs[!apply(cause_combs == 3, 1L, any), ])\n#\u003e [,1] [,2]\n#\u003e [1,] 1 1\n#\u003e [2,] 1 2\n#\u003e [3,] 2 1\n#\u003e [4,] 2 2\napply(combs_to_test, 1, \\(cause){\n # compute the CIF numerically and compute the relative error\n f1 \u003c- Vectorize(\n \\(x, cause1, type1){\n mmcif_pd_bivariate(\n fit$par, comp_obj, newdata = ex_dat, cause = c(cause1, cause[2]), \n time = c(x, 1.33), ghq_data = ghq_lists[[2]], \n type = c(type1, \"cumulative\"))\n }, vectorize.args = \"x\")\n \n int_val \u003c- integrate(\n f1, 1e-8, .25, cause1 = cause[1], type1 = \"derivative\", \n rel.tol = 1e-10)$value\n func_out \u003c- f1(.25, cause[1], \"cumulative\")\n err1 \u003c- (func_out - int_val) / int_val\n \n # do the same for the other argument\n f2 \u003c- Vectorize(\n \\(x, cause2, type2){\n mmcif_pd_bivariate(\n fit$par, comp_obj, newdata = ex_dat, cause = c(cause[1], cause2), \n time = c(.25, x), ghq_data = ghq_lists[[2]], \n type = c(\"cumulative\", type2))\n }, vectorize.args = \"x\")\n \n int_val \u003c- integrate(\n f2, 1e-8, 1.33, cause2 = cause[2], type2 = \"derivative\", \n rel.tol = 1e-10)$value\n func_out \u003c- f2(1.33, cause[2], \"cumulative\")\n err2 \u003c- (func_out - int_val) / int_val\n \n # return the relative errors\n c(err1, err2)\n}) # ~ tiny relative errors\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 4.448e-07 2.96e-07 3.800e-08 -5.398e-07\n#\u003e [2,] 5.409e-08 4.85e-07 9.375e-08 -7.684e-07\n\n# we can also do the check with one CIF and one derivative\napply(combs_to_test, 1, \\(cause){\n # compute the cif numerically\n f1 \u003c- Vectorize(\n \\(x, cause1, type1){\n mmcif_pd_bivariate(\n fit$par, comp_obj, newdata = ex_dat, cause = c(cause1, cause[2]), \n time = c(x, 1.33), ghq_data = ghq_lists[[2]], \n type = c(type1, \"derivative\"))\n }, vectorize.args = \"x\")\n \n int_val \u003c- integrate(\n f1, 1e-8, .25, cause1 = cause[1], type1 = \"derivative\", rel.tol = 1e-10)$value\n func_out \u003c- f1(.25, cause[1], \"cumulative\")\n err1 \u003c- (func_out - int_val) / int_val\n \n # do the same for the other argument\n f2 \u003c- Vectorize(\n \\(x, cause2, type2){\n mmcif_pd_bivariate(\n fit$par, comp_obj, newdata = ex_dat, cause = c(cause[1], cause2), \n time = c(.25, x), ghq_data = ghq_lists[[2]], \n type = c(\"derivative\", type2))\n }, vectorize.args = \"x\")\n \n int_val \u003c- integrate(\n f2, 1e-8, 1.33, cause2 = cause[2], type2 = \"derivative\", \n rel.tol = 1e-10)$value\n func_out \u003c- f2(1.33, cause[2], \"cumulative\")\n err2 \u003c- (func_out - int_val) / int_val\n \n # return the relative errors\n c(err1, err2)\n})\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 8.270e-08 3.573e-07 -7.029e-08 -1.120e-07\n#\u003e [2,] 8.151e-08 2.964e-07 1.580e-07 -3.787e-07\n```\n\nFinally, there is also function to compute the marginal density, CIF,\nsurvival probability or hazard conditional on the outcome of another\nindividual.\n\n``` r\n# define two wrapper to simplify the calls to mmcif_pd_univariate and \n# mmcif_pd_cond\ncompute_uncond \u003c- Vectorize(\n \\(time, cause, type){\n mmcif_pd_univariate(\n fit$par, comp_obj, newdata = ex_dat[1, ], cause = cause, \n time = time, type = type)\n }, \"time\")\n\ncompute_cond \u003c- Vectorize(\n \\(time, cause, type){\n mmcif_pd_cond(\n fit$par, comp_obj, newdata = ex_dat, cause = c(2L, cause), \n time = c(.25, time), type_obs = type, type_cond = \"cumulative\", \n which_cond = 1L)\n }, \"time\")\n\n# the conditional figures are the dashed curves\nlocal({\n tis \u003c- seq(1e-2, 2 - 1e-2, length.out = 200)\n cifs \u003c- cbind(compute_uncond(tis, 2L, \"cumulative\"),\n compute_cond(tis, 2L, \"cumulative\"))\n derivs \u003c- cbind(compute_uncond(tis, 2L, \"derivative\"),\n compute_cond(tis, 2L, \"derivative\"))\n\n par(mar = c(5, 5, 1, 1)) \n matplot(tis, cifs, type = \"l\", lty = 1:2, col = \"black\", bty = \"l\", \n xlab = \"Time\", ylab = \"Marginal CIF\")\n grid()\n\n matplot(tis, derivs, type = \"l\", lty = 1:2, col = \"black\", bty = \"l\", \n xlab = \"Time\", ylab = \"Marginal derivatives\")\n grid()\n \n # do the same for the hazard\n hazs_cond \u003c- compute_cond(tis, 2L, \"hazard\")\n hazs_uncond \u003c- \n compute_uncond(tis, \"derivative\", cause = 2L) / \n compute_uncond(tis, \"cumulative\", cause = 3L)\n \n matplot(tis, cbind(hazs_uncond, hazs_cond), type = \"l\", lty = 1:2, \n col = \"black\", bty = \"l\", xlab = \"Time\", ylab = \"Marginal hazards\")\n grid()\n})\n```\n\n\u003cimg src=\"man/figures/README-show_mmcif_pd_cond-1.png\" width=\"100%\" /\u003e\u003cimg src=\"man/figures/README-show_mmcif_pd_cond-2.png\" width=\"100%\" /\u003e\u003cimg src=\"man/figures/README-show_mmcif_pd_cond-3.png\" width=\"100%\" /\u003e\n\n``` r\n# we can check a standard equality\ncond_surv \u003c- compute_cond(.25, cause = 3L, type = \"cumulative\")\ncond_deriv \u003c- compute_cond(.25, cause = 1L, type = \"derivative\")\ncond_haz \u003c- compute_cond(.25, cause = 1L, type = \"hazard\")\nall.equal(cond_surv * cond_haz, cond_deriv)\n#\u003e [1] TRUE\n\n# the conditional derivative integrates to the conditional CIF\nnum_cumulative \u003c- integrate(\n compute_cond, 1e-8, .25, cause = 1L, type = \"derivative\", \n rel.tol = 1e-10)$value\nall.equal(num_cumulative, compute_cond(.25, cause = 1L, type = \"cumulative\"))\n#\u003e [1] \"Mean relative difference: 3.475e-07\"\n```\n\n### Delayed Entry\n\nWe extend the previous example to the setting where there may be delayed\nentry (left truncation). Thus, we assign a new simulation function. The\ndelayed entry is sampled by sampling a random variable from the uniform\ndistribution on -1 to 1 and taking the entry time as being the maximum\nof this variable and zero.\n\n``` r\nlibrary(mvtnorm)\n\n# simulates a data set with a given number of clusters and maximum number of \n# observations per cluster\nsim_dat \u003c- \\(n_clusters, max_cluster_size){\n stopifnot(max_cluster_size \u003e 0,\n n_clusters \u003e 0)\n \n cluster_id \u003c- 0L\n replicate(n_clusters, simplify = FALSE, {\n n_obs \u003c- sample.int(max_cluster_size, 1L)\n cluster_id \u003c\u003c- cluster_id + 1L\n \n # draw the covariates and the left truncation time\n covs \u003c- cbind(a = rnorm(n_obs), b = runif(n_obs, -1))\n Z \u003c- cbind(1, covs)\n \n delayed_entry \u003c- pmax(runif(n_obs, -1), 0)\n cens \u003c- rep(-Inf, n_obs)\n while(all(cens \u003c= delayed_entry))\n cens \u003c- runif(n_obs, max = 3 * delta)\n \n successful_sample \u003c- FALSE\n while(!successful_sample){\n rng_effects \u003c- rmvnorm(1, sigma = Sigma) |\u003e drop()\n U \u003c- head(rng_effects, n_causes)\n eta \u003c- tail(rng_effects, n_causes)\n \n # draw the cause\n cond_logits_exp \u003c- exp(Z %*% coef_risk + rep(U, each = n_obs)) |\u003e \n cbind(1)\n cond_probs \u003c- cond_logits_exp / rowSums(cond_logits_exp)\n cause \u003c- apply(cond_probs, 1, \n \\(prob) sample.int(n_causes + 1L, 1L, prob = prob))\n \n # compute the observed time if needed\n obs_time \u003c- mapply(\\(cause, idx){\n if(cause \u003e n_causes)\n return(delta)\n \n # can likely be done smarter but this is more general\n coefs \u003c- coef_traject[, cause]\n offset \u003c- sum(Z[idx, ] * coefs[-1]) + eta[cause]\n rng \u003c- runif(1)\n eps \u003c- .Machine$double.eps\n root \u003c- uniroot(\n \\(x) rng - pnorm(\n -coefs[1] * atanh((x - delta / 2) / (delta / 2)) - offset), \n c(eps^2, delta * (1 - eps)), tol = 1e-12)$root\n }, cause, 1:n_obs)\n \n keep \u003c- which(pmin(obs_time, cens) \u003e delayed_entry)\n successful_sample \u003c- length(keep) \u003e 0\n if(!successful_sample)\n next\n \n has_finite_trajectory_prob \u003c- cause \u003c= n_causes\n is_censored \u003c- which(!has_finite_trajectory_prob | cens \u003c obs_time)\n \n if(length(is_censored) \u003e 0){\n obs_time[is_censored] \u003c- pmin(delta, cens[is_censored])\n cause[is_censored] \u003c- n_causes + 1L\n }\n }\n \n data.frame(covs, cause, time = obs_time, cluster_id, delayed_entry)[keep, ]\n }) |\u003e \n do.call(what = rbind)\n}\n```\n\nWe sample a data set using the new simulation function.\n\n``` r\n# sample a data set\nset.seed(51312406)\nn_clusters \u003c- 1000L\nmax_cluster_size \u003c- 5L\ndat \u003c- sim_dat(n_clusters, max_cluster_size = max_cluster_size)\n\n# show some stats\nNROW(dat) # number of individuals\n#\u003e [1] 2524\ntable(dat$cause) # distribution of causes (3 is censored)\n#\u003e \n#\u003e 1 2 3 \n#\u003e 976 435 1113\n\n# distribution of observed times by cause\ntapply(dat$time, dat$cause, quantile, \n probs = seq(0, 1, length.out = 11), na.rm = TRUE)\n#\u003e $`1`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 1.389e-06 1.155e-02 6.302e-02 2.279e-01 5.696e-01 9.796e-01 1.312e+00 1.650e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.887e+00 1.981e+00 2.000e+00 \n#\u003e \n#\u003e $`2`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.002019 0.090197 0.280351 0.429229 0.658360 0.906824 1.180597 1.409366 \n#\u003e 80% 90% 100% \n#\u003e 1.674830 1.877513 1.996200 \n#\u003e \n#\u003e $`3`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.005216 0.462201 0.836501 1.188546 1.599797 2.000000 2.000000 2.000000 \n#\u003e 80% 90% 100% \n#\u003e 2.000000 2.000000 2.000000\n\n# distribution of the left truncation time\nquantile(dat$delayed_entry, probs = seq(0, 1, length.out = 11))\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 7.271e-05 2.151e-01 \n#\u003e 80% 90% 100% \n#\u003e 4.463e-01 7.110e-01 9.990e-01\n```\n\n#### Optimization\n\nNext, we fit the model as before but this time we pass the delayed entry\ntime.\n\n``` r\nlibrary(mmcif)\ncomp_obj \u003c- mmcif_data(\n ~ a + b, dat, cause = cause, time = time, cluster_id = cluster_id, \n max_time = delta, spline_df = 4L, left_trunc = delayed_entry)\n\n# we need to find the combination of the spline bases that yield a straight \n# line to construct the true values using the splines. You can skip this\ncomb_slope \u003c- sapply(comp_obj$spline, \\(spline){\n boundary_knots \u003c- spline$boundary_knots\n pts \u003c- seq(boundary_knots[1], boundary_knots[2], length.out = 1000)\n lm.fit(cbind(1, spline$expansion(pts)), pts)$coef\n})\n\ncoef_traject_spline \u003c- \n rbind(comb_slope[-1, ] * rep(coef_traject[1, ], each = NROW(comb_slope) - 1), \n coef_traject[2, ] + comb_slope[1, ] * coef_traject[1, ],\n coef_traject[-(1:2), ])\n \n# set true values\ntruth \u003c- c(coef_risk, coef_traject_spline, log_chol(Sigma))\n\n# find the starting values\nsystem.time(start \u003c- mmcif_start_values(comp_obj, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 0.056 0.000 0.017\n\n# we can verify that the gradient is correct again\ngr_package \u003c- mmcif_logLik_grad(\n comp_obj, truth, n_threads = 4L, is_log_chol = TRUE)\ngr_num \u003c- numDeriv::grad(\n mmcif_logLik, truth, object = comp_obj, n_threads = 4L, is_log_chol = TRUE, \n method = \"simple\")\n\nrbind(`Numerical gradient` = gr_num, `Gradient package` = gr_package)\n#\u003e [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]\n#\u003e Numerical gradient -47.71 -8.791 6.978 7.570 7.152 6.220 5.934 8.550 -28.05\n#\u003e Gradient package -47.65 -8.753 6.991 7.571 7.179 6.233 5.957 8.573 -28.04\n#\u003e [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [,18]\n#\u003e Numerical gradient 18.37 -47.03 86.44 2.075 -45.32 -17.03 13.93 17.29 -20.57\n#\u003e Gradient package 18.38 -46.99 86.50 2.098 -45.31 -17.02 13.93 17.30 -20.55\n#\u003e [,19] [,20] [,21] [,22] [,23] [,24] [,25] [,26] [,27]\n#\u003e Numerical gradient 20.15 -1.487 6.760 -5.759 -2.593 -14.53 20.44 -9.739 5.922\n#\u003e Gradient package 20.18 -1.479 6.753 -5.687 -2.036 -14.53 20.37 -9.701 5.931\n#\u003e [,28] [,29] [,30]\n#\u003e Numerical gradient -10.99 -14.59 4.312\n#\u003e Gradient package -10.97 -14.59 4.324\n\n# optimize the log composite likelihood\nsystem.time(fit \u003c- mmcif_fit(start$upper, comp_obj, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 49.872 0.012 12.473\n\n# the log composite likelihood at different points\nmmcif_logLik(comp_obj, truth, n_threads = 4L, is_log_chol = TRUE)\n#\u003e [1] -4745\nmmcif_logLik(comp_obj, start$upper, n_threads = 4L, is_log_chol = TRUE)\n#\u003e [1] -5077\n-fit$value\n#\u003e [1] -4724\n```\n\nThen we compute the sandwich estimator. The Hessian is currently\ncomputed with numerical differentiation which is why it takes a while.\n\n``` r\nsystem.time(sandwich_est \u003c- mmcif_sandwich(comp_obj, fit$par, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 41.487 0.004 10.394\n\n# setting order equal to zero yield no Richardson extrapolation and just\n# standard symmetric difference quotient. This is less precise but faster \nsystem.time(sandwich_est_simple \u003c- \n mmcif_sandwich(comp_obj, fit$par, n_threads = 4L, order = 0L))\n#\u003e user system elapsed \n#\u003e 9.521 0.000 2.386\n```\n\n#### Estimates\n\nWe show the estimated and true the conditional cumulative incidence\nfunctions (the dashed curves are the estimates) when the random effects\nare zero and the covariates are zero, ![a\\_{ij} = b\\_{ij}\n= 0](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;a_%7Bij%7D%20%3D%20b_%7Bij%7D%20%3D%200\n\"a_{ij} = b_{ij} = 0\").\n\n``` r\nlocal({\n # get the estimates\n coef_risk_est \u003c- fit$par[comp_obj$indices$coef_risk] |\u003e \n matrix(ncol = n_causes)\n coef_traject_time_est \u003c- fit$par[comp_obj$indices$coef_trajectory_time] |\u003e \n matrix(ncol = n_causes)\n coef_traject_est \u003c- fit$par[comp_obj$indices$coef_trajectory] |\u003e \n matrix(ncol = n_causes)\n coef_traject_intercept_est \u003c- coef_traject_est[5, ]\n \n # compute the risk probabilities \n probs \u003c- exp(coef_risk[1, ]) / (1 + sum(exp(coef_risk[1, ])))\n probs_est \u003c- exp(coef_risk_est[1, ]) / (1 + sum(exp(coef_risk_est[1, ])))\n \n # plot the estimated and true conditional cumulative incidence functions. The\n # estimates are the dashed lines\n par(mar = c(5, 5, 1, 1), mfcol = c(1, 2))\n pts \u003c- seq(1e-8, delta * (1 - 1e-8), length.out = 1000)\n \n for(i in 1:2){\n true_vals \u003c- probs[i] * pnorm(\n -coef_traject[1, i] * atanh((pts - delta / 2) / (delta / 2)) - \n coef_traject[2, i])\n \n estimates \u003c- probs_est[i] * pnorm(\n -comp_obj$time_expansion(pts, cause = i) %*% coef_traject_time_est[, i] - \n coef_traject_intercept_est[i]) |\u003e drop()\n \n matplot(pts, cbind(true_vals, estimates), xlim = c(0, delta), \n ylim = c(0, 1), bty = \"l\", xlab = \"Time\", lty = c(1, 2),\n ylab = sprintf(\"Cumulative incidence; cause %d\", i),\n yaxs = \"i\", xaxs = \"i\", type = \"l\", col = \"black\")\n grid()\n }\n})\n```\n\n\u003cimg src=\"man/figures/README-delayed_compare_estimated_incidence_funcs-1.png\" width=\"100%\" /\u003e\n\nFurther illustrations of the estimated model are given below.\n\n``` r\n# the number of call we made\nfit$counts\n#\u003e function gradient \n#\u003e 232 190\nfit$outer.iterations\n#\u003e [1] 3\n\n# compute the standard errors from the sandwich estimator\nSEs \u003c- diag(sandwich_est) |\u003e sqrt()\nSEs_simple \u003c- diag(sandwich_est_simple) |\u003e sqrt()\n\n# compare the estimates with the true values\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$coef_risk],\n `Standard errors` = SEs[comp_obj$indices$coef_risk],\n `Standard errors simple` = SEs_simple[comp_obj$indices$coef_risk],\n Truth = truth[comp_obj$indices$coef_risk])\n#\u003e cause1:risk:(Intercept) cause1:risk:a cause1:risk:b\n#\u003e Estimate AGHQ 0.57747 0.98262 0.1391\n#\u003e Standard errors 0.07592 0.08423 0.1053\n#\u003e Standard errors simple 0.07592 0.08423 0.1053\n#\u003e Truth 0.67000 1.00000 0.1000\n#\u003e cause2:risk:(Intercept) cause2:risk:a cause2:risk:b\n#\u003e Estimate AGHQ -0.4139 0.23007 0.3440\n#\u003e Standard errors 0.1033 0.07872 0.1175\n#\u003e Standard errors simple 0.1033 0.07872 0.1175\n#\u003e Truth -0.4000 0.25000 0.3000\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$coef_trajectory],\n `Standard errors` = SEs[comp_obj$indices$coef_trajectory],\n `Standard errors simple` = SEs_simple[comp_obj$indices$coef_trajectory],\n Truth = truth[comp_obj$indices$coef_trajectory])\n#\u003e cause1:spline1 cause1:spline2 cause1:spline3\n#\u003e Estimate AGHQ -2.9825 -3.625 -6.6752\n#\u003e Standard errors 0.1641 0.165 0.3374\n#\u003e Standard errors simple 0.1641 0.165 0.3373\n#\u003e Truth -3.0513 -3.666 -6.6720\n#\u003e cause1:spline4 cause1:traject:(Intercept)\n#\u003e Estimate AGHQ -4.7854 2.5959\n#\u003e Standard errors 0.2232 0.1503\n#\u003e Standard errors simple 0.2231 0.1503\n#\u003e Truth -4.8560 2.6778\n#\u003e cause1:traject:a cause1:traject:b cause2:spline1\n#\u003e Estimate AGHQ 0.88400 0.40159 -2.6765\n#\u003e Standard errors 0.06576 0.07497 0.2108\n#\u003e Standard errors simple 0.06575 0.07497 0.2109\n#\u003e Truth 0.80000 0.40000 -2.7771\n#\u003e cause2:spline2 cause2:spline3 cause2:spline4\n#\u003e Estimate AGHQ -3.1360 -5.6399 -4.1479\n#\u003e Standard errors 0.1890 0.4011 0.2565\n#\u003e Standard errors simple 0.1892 0.4010 0.2565\n#\u003e Truth -3.3481 -6.2334 -4.6450\n#\u003e cause2:traject:(Intercept) cause2:traject:a\n#\u003e Estimate AGHQ 2.6923 0.24584\n#\u003e Standard errors 0.2251 0.06472\n#\u003e Standard errors simple 0.2251 0.06472\n#\u003e Truth 3.0259 0.25000\n#\u003e cause2:traject:b\n#\u003e Estimate AGHQ -0.1689\n#\u003e Standard errors 0.1198\n#\u003e Standard errors simple 0.1198\n#\u003e Truth -0.2000\n\nn_vcov \u003c- (2L * n_causes * (2L * n_causes + 1L)) %/% 2L\nSigma\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.306 0.008 -0.138 0.197\n#\u003e [2,] 0.008 0.759 0.251 -0.250\n#\u003e [3,] -0.138 0.251 0.756 -0.319\n#\u003e [4,] 0.197 -0.250 -0.319 0.903\nlog_chol_inv(tail(fit$par, n_vcov))\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.33651 -0.1471 -0.07113 0.1426\n#\u003e [2,] -0.14711 0.3690 0.41898 -0.1071\n#\u003e [3,] -0.07113 0.4190 0.72053 -0.4198\n#\u003e [4,] 0.14263 -0.1071 -0.41981 0.5897\n\n# on the log Cholesky scale\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$vcov_upper],\n `Standard errors` = SEs[comp_obj$indices$vcov_upper],\n `Standard errors simple` = SEs_simple[comp_obj$indices$vcov_upper],\n Truth = truth[comp_obj$indices$vcov_upper])\n#\u003e vcov:risk1:risk1 vcov:risk1:risk2 vcov:risk2:risk2\n#\u003e Estimate AGHQ -0.5446 -0.25359 -0.5942\n#\u003e Standard errors 0.2753 0.22883 0.3426\n#\u003e Standard errors simple 0.2753 0.22875 0.3423\n#\u003e Truth -0.5921 0.01446 -0.1380\n#\u003e vcov:risk1:traject1 vcov:risk2:traject1\n#\u003e Estimate AGHQ -0.1226 0.7027\n#\u003e Standard errors 0.1953 0.1763\n#\u003e Standard errors simple 0.1953 0.1761\n#\u003e Truth -0.2495 0.2923\n#\u003e vcov:traject1:traject1 vcov:risk1:traject2\n#\u003e Estimate AGHQ -0.7763 0.2459\n#\u003e Standard errors 0.5252 0.2157\n#\u003e Standard errors simple 0.5238 0.2156\n#\u003e Truth -0.2485 0.3561\n#\u003e vcov:risk2:traject2 vcov:traject1:traject2\n#\u003e Estimate AGHQ -0.08115 -0.7230\n#\u003e Standard errors 0.28621 0.1277\n#\u003e Standard errors simple 0.28583 0.1277\n#\u003e Truth -0.29291 -0.1853\n#\u003e vcov:traject2:traject2\n#\u003e Estimate AGHQ -6.7371\n#\u003e Standard errors 1.5913\n#\u003e Standard errors simple 1.5629\n#\u003e Truth -0.2108\n\n# on the original covariance matrix scale\nvcov_est \u003c- log_chol_inv(tail(fit$par, n_vcov))\nvcov_est[lower.tri(vcov_est)] \u003c- NA_real_\nvcov_SE \u003c- matrix(NA_real_, NROW(vcov_est), NCOL(vcov_est))\nvcov_SE[upper.tri(vcov_SE, TRUE)] \u003c- \n attr(sandwich_est, \"res vcov\") |\u003e diag() |\u003e sqrt() |\u003e \n tail(n_vcov)\n\nvcov_show \u003c- cbind(Estimates = vcov_est, NA, SEs = vcov_SE) \ncolnames(vcov_show) \u003c- \n c(rep(\"Est.\", NCOL(vcov_est)), \"\", rep(\"SE\", NCOL(vcov_est)))\nprint(vcov_show, na.print = \"\")\n#\u003e Est. Est. Est. Est. SE SE SE SE\n#\u003e [1,] 0.3365 -0.1471 -0.07113 0.1426 0.1853 0.1173 0.1135 0.1319\n#\u003e [2,] 0.3690 0.41898 -0.1071 0.1661 0.1142 0.1396\n#\u003e [3,] 0.72053 -0.4198 0.1473 0.1278\n#\u003e [4,] 0.5897 0.1845\n\nSigma # the true values\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.306 0.008 -0.138 0.197\n#\u003e [2,] 0.008 0.759 0.251 -0.250\n#\u003e [3,] -0.138 0.251 0.756 -0.319\n#\u003e [4,] 0.197 -0.250 -0.319 0.903\n```\n\n### Delayed Entry with Different Strata\n\nWe may allow for different transformations for groups of individuals.\nSpecifically, we can replace the covariates for the trajectory\n\n \n![\\\\vec x\\_{ij}(t) = (\\\\vec h(t)^\\\\top, \\\\vec\nz\\_{ij}^\\\\top)^\\\\top](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20x_%7Bij%7D%28t%29%20%3D%20%28%5Cvec%20h%28t%29%5E%5Ctop%2C%20%5Cvec%20z_%7Bij%7D%5E%5Ctop%29%5E%5Ctop\n\"\\\\vec x_{ij}(t) = (\\\\vec h(t)^\\\\top, \\\\vec z_{ij}^\\\\top)^\\\\top\") \n\nwith\n\n \n![\\\\vec x\\_{ij}(t) = (\\\\vec h\\_{l\\_{ij}}(t)^\\\\top, \\\\vec\nz\\_{ij}^\\\\top)^\\\\top](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;%5Cvec%20x_%7Bij%7D%28t%29%20%3D%20%28%5Cvec%20h_%7Bl_%7Bij%7D%7D%28t%29%5E%5Ctop%2C%20%5Cvec%20z_%7Bij%7D%5E%5Ctop%29%5E%5Ctop\n\"\\\\vec x_{ij}(t) = (\\\\vec h_{l_{ij}}(t)^\\\\top, \\\\vec z_{ij}^\\\\top)^\\\\top\") \n\nwhere there are\n![L](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;L\n\"L\") strata each having their own spline basis\n![h\\_{l}(t)](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;h_%7Bl%7D%28t%29\n\"h_{l}(t)\") and\n![l\\_{ij}](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;l_%7Bij%7D\n\"l_{ij}\") is the strata that observation\n![j](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;j\n\"j\") in cluster\n![i](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;i\n\"i\") is in. This is supported in the package using the `strata` argument\nof `mmcif_data`. We illustrate this by extending the previous example.\nFirst, we assign new model parameters and plot the cumulative incidence\nfunctions as before but for each strata.\n\n``` r\n# assign model parameters\nn_causes \u003c- 2L\ndelta \u003c- 2\n\n# set the betas\ncoef_risk \u003c- c(.9, 1, .1, -.2, .5, 0, 0, 0, .5,\n -.4, .25, .3, 0, .5, .25, 1.5, -.25, 0) |\u003e \n matrix(ncol = n_causes)\n\n# set the gammas\ncoef_traject \u003c- c(-.8, -.45, -1, -.1, -.5, -.4, \n .8, .4, 0, .4, 0, .4, \n -1.2, .15, -.4, -.15, -.5, -.25, \n .25, -.2, 0, -.2, .25, 0) |\u003e \n matrix(ncol = n_causes)\n\n# plot the conditional cumulative incidence functions when random effects and \n# covariates are all zero\nlocal({\n for(strata in 1:3 - 1L){\n probs \u003c- exp(coef_risk[1 + strata * 3, ]) / \n (1 + sum(exp(coef_risk[1 + strata * 3, ])))\n par(mar = c(5, 5, 1, 1), mfcol = c(1, 2))\n \n for(i in 1:2){\n plot(\\(x) probs[i] * pnorm(\n -coef_traject[1 + strata * 2, i] * \n atanh((x - delta / 2) / (delta / 2)) - \n coef_traject[2 + strata * 2, i]),\n xlim = c(0, delta), ylim = c(0, 1), bty = \"l\", \n xlab = sprintf(\"Time; strata %d\", strata + 1L), \n ylab = sprintf(\"Cumulative incidence; cause %d\", i),\n yaxs = \"i\", xaxs = \"i\")\n grid()\n }\n }\n})\n```\n\n\u003cimg src=\"man/figures/README-strata_assign_model_parameters-1.png\" width=\"100%\" /\u003e\u003cimg src=\"man/figures/README-strata_assign_model_parameters-2.png\" width=\"100%\" /\u003e\u003cimg src=\"man/figures/README-strata_assign_model_parameters-3.png\" width=\"100%\" /\u003e\n\n``` r\n# the probabilities of each strata\nstrata_prob \u003c- c(.2, .5, .3)\n\n# set the covariance matrix\nSigma \u003c- c(0.306, 0.008, -0.138, 0.197, 0.008, 0.759, 0.251, \n-0.25, -0.138, 0.251, 0.756, -0.319, 0.197, -0.25, -0.319, 0.903) |\u003e \n matrix(2L * n_causes)\n```\n\nThen we define a simulation function.\n\n``` r\nlibrary(mvtnorm)\n\n# simulates a data set with a given number of clusters and maximum number of \n# observations per cluster\nsim_dat \u003c- \\(n_clusters, max_cluster_size){\n stopifnot(max_cluster_size \u003e 0,\n n_clusters \u003e 0)\n \n cluster_id \u003c- 0L\n replicate(n_clusters, simplify = FALSE, {\n n_obs \u003c- sample.int(max_cluster_size, 1L)\n cluster_id \u003c\u003c- cluster_id + 1L\n strata \u003c- sample.int(length(strata_prob), 1L, prob = strata_prob)\n \n # keep only the relevant parameters\n coef_risk \u003c- coef_risk[1:3 + (strata - 1L) * 3, ]\n coef_traject \u003c- coef_traject[\n c(1:2 + (strata - 1L) * 2L, 1:2 + 6L + (strata - 1L) * 2L), ]\n \n # draw the covariates and the left truncation time\n covs \u003c- cbind(a = rnorm(n_obs), b = runif(n_obs, -1))\n Z \u003c- cbind(1, covs)\n \n delayed_entry \u003c- pmax(runif(n_obs, -1), 0)\n cens \u003c- rep(-Inf, n_obs)\n while(all(cens \u003c= delayed_entry))\n cens \u003c- runif(n_obs, max = 3 * delta)\n \n successful_sample \u003c- FALSE\n while(!successful_sample){\n rng_effects \u003c- rmvnorm(1, sigma = Sigma) |\u003e drop()\n U \u003c- head(rng_effects, n_causes)\n eta \u003c- tail(rng_effects, n_causes)\n \n # draw the cause\n cond_logits_exp \u003c- exp(Z %*% coef_risk + rep(U, each = n_obs)) |\u003e \n cbind(1)\n cond_probs \u003c- cond_logits_exp / rowSums(cond_logits_exp)\n cause \u003c- apply(cond_probs, 1, \n \\(prob) sample.int(n_causes + 1L, 1L, prob = prob))\n \n # compute the observed time if needed\n obs_time \u003c- mapply(\\(cause, idx){\n if(cause \u003e n_causes)\n return(delta)\n \n # can likely be done smarter but this is more general\n coefs \u003c- coef_traject[, cause]\n offset \u003c- sum(Z[idx, ] * coefs[-1]) + eta[cause]\n rng \u003c- runif(1)\n eps \u003c- .Machine$double.eps\n root \u003c- uniroot(\n \\(x) rng - pnorm(\n -coefs[1] * atanh((x - delta / 2) / (delta / 2)) - offset), \n c(eps^2, delta * (1 - eps)), tol = 1e-12)$root\n }, cause, 1:n_obs)\n \n keep \u003c- which(pmin(obs_time, cens) \u003e delayed_entry)\n successful_sample \u003c- length(keep) \u003e 0\n if(!successful_sample)\n next\n \n has_finite_trajectory_prob \u003c- cause \u003c= n_causes\n is_censored \u003c- which(!has_finite_trajectory_prob | cens \u003c obs_time)\n \n if(length(is_censored) \u003e 0){\n obs_time[is_censored] \u003c- pmin(delta, cens[is_censored])\n cause[is_censored] \u003c- n_causes + 1L\n }\n }\n \n data.frame(covs, cause, time = obs_time, cluster_id, delayed_entry, \n strata)[keep, ]\n }) |\u003e \n do.call(what = rbind) |\u003e\n transform(strata = factor(sprintf(\"s%d\", strata)))\n}\n```\n\nWe sample a data set using the new simulation function.\n\n``` r\n# sample a data set\nset.seed(14712915)\nn_clusters \u003c- 1000L\nmax_cluster_size \u003c- 5L\ndat \u003c- sim_dat(n_clusters, max_cluster_size = max_cluster_size)\n\n# show some stats\nNROW(dat) # number of individuals\n#\u003e [1] 2518\ntable(dat$cause) # distribution of causes (3 is censored)\n#\u003e \n#\u003e 1 2 3 \n#\u003e 639 791 1088\n\n# distribution of observed times by cause\ntapply(dat$time, dat$cause, quantile, \n probs = seq(0, 1, length.out = 11), na.rm = TRUE)\n#\u003e $`1`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 2.491e-06 2.254e-02 1.257e-01 3.135e-01 6.053e-01 9.441e-01 1.229e+00 1.553e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.809e+00 1.949e+00 2.000e+00 \n#\u003e \n#\u003e $`2`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 2.161e-10 1.023e-03 1.815e-02 1.198e-01 3.706e-01 8.523e-01 1.432e+00 1.802e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.959e+00 1.998e+00 2.000e+00 \n#\u003e \n#\u003e $`3`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.0001885 0.4570257 0.8623890 1.2217385 1.6003899 2.0000000 2.0000000 2.0000000 \n#\u003e 80% 90% 100% \n#\u003e 2.0000000 2.0000000 2.0000000\n\n# within strata\ntapply(dat$time, interaction(dat$cause, dat$strata), quantile, \n probs = seq(0, 1, length.out = 11), na.rm = TRUE)\n#\u003e $`1.s1`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.0001022 0.0239065 0.1246552 0.3120237 0.6869977 0.8928432 1.2835877 1.6481640 \n#\u003e 80% 90% 100% \n#\u003e 1.9030874 1.9707153 1.9998886 \n#\u003e \n#\u003e $`2.s1`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.006063 0.092698 0.286631 0.468654 0.698025 0.919033 1.131461 1.396541 \n#\u003e 80% 90% 100% \n#\u003e 1.707284 1.868491 1.977970 \n#\u003e \n#\u003e $`3.s1`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.004763 0.567089 0.903437 1.294739 1.601904 2.000000 2.000000 2.000000 \n#\u003e 80% 90% 100% \n#\u003e 2.000000 2.000000 2.000000 \n#\u003e \n#\u003e $`1.s2`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.001513 0.062654 0.194127 0.367494 0.598768 0.971182 1.203544 1.424611 \n#\u003e 80% 90% 100% \n#\u003e 1.665483 1.868098 1.995039 \n#\u003e \n#\u003e $`2.s2`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 2.161e-10 2.177e-04 5.389e-03 4.520e-02 2.077e-01 6.665e-01 1.506e+00 1.866e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.979e+00 1.999e+00 2.000e+00 \n#\u003e \n#\u003e $`3.s2`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.008548 0.474137 0.889173 1.314717 1.692051 2.000000 2.000000 2.000000 \n#\u003e 80% 90% 100% \n#\u003e 2.000000 2.000000 2.000000 \n#\u003e \n#\u003e $`1.s3`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 2.491e-06 1.177e-03 1.072e-02 5.403e-02 4.041e-01 9.582e-01 1.250e+00 1.783e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.974e+00 1.994e+00 2.000e+00 \n#\u003e \n#\u003e $`2.s3`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 7.133e-07 1.678e-03 1.950e-02 1.115e-01 4.179e-01 9.793e-01 1.575e+00 1.855e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.970e+00 1.997e+00 2.000e+00 \n#\u003e \n#\u003e $`3.s3`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.0001885 0.4129234 0.6988777 1.0541778 1.3786664 1.7758420 2.0000000 2.0000000 \n#\u003e 80% 90% 100% \n#\u003e 2.0000000 2.0000000 2.0000000\n\n# distribution of strata\ntable(dat$strata)\n#\u003e \n#\u003e s1 s2 s3 \n#\u003e 577 1233 708\n\n# distribution of the left truncation time\nquantile(dat$delayed_entry, probs = seq(0, 1, length.out = 11))\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% 80% 90% 100% \n#\u003e 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.1752 0.4210 0.6772 0.9998\n```\n\n#### Optimization\n\nNext, we fit the model as before but this time we with strata specific\nfixed effects and transformations.\n\n``` r\nlibrary(mmcif)\ncomp_obj \u003c- mmcif_data(\n ~ strata + (a + b) : strata - 1, dat, cause = cause, time = time, \n cluster_id = cluster_id, max_time = delta, spline_df = 4L, \n left_trunc = delayed_entry, strata = strata)\n```\n\n``` r\n# we need to find the combination of the spline bases that yield a straight \n# line to construct the true values using the splines. You can skip this\ncomb_slope \u003c- sapply(comp_obj$spline, \\(spline){\n boundary_knots \u003c- spline$boundary_knots\n pts \u003c- seq(boundary_knots[1], boundary_knots[2], length.out = 1000)\n lm.fit(cbind(1, spline$expansion(pts)), pts)$coef\n})\n\ncoef_traject_spline \u003c- lapply(1:length(unique(dat$strata)), function(strata){\n slopes \u003c- coef_traject[1 + (strata - 1) * 2, ]\n comb_slope[-1, ] * rep(slopes, each = NROW(comb_slope) - 1)\n}) |\u003e \n do.call(what = rbind)\n\ncoef_traject_spline_fixef \u003c- lapply(1:length(unique(dat$strata)), function(strata){\n slopes \u003c- coef_traject[1 + (strata - 1) * 2, ]\n intercepts \u003c- coef_traject[2 + (strata - 1) * 2, ]\n \n fixefs \u003c- coef_traject[7:8 + (strata - 1) * 2, ]\n \n rbind(intercepts + comb_slope[1, ] * slopes,\n fixefs)\n}) |\u003e \n do.call(what = rbind)\n\ncoef_traject_spline \u003c- rbind(coef_traject_spline, coef_traject_spline_fixef)\n\n# handle that model.matrix in mmcif_data gives a different permutation of \n# the parameters\npermu \u003c- c(seq(1, 7, by = 3), seq(2, 8, by = 3), seq(3, 9, by = 3))\n\n# set true values\ntruth \u003c- c(coef_risk[permu, ], \n coef_traject_spline[c(1:12, permu + 12L), ], \n log_chol(Sigma))\n\n# find the starting values\nsystem.time(start \u003c- mmcif_start_values(comp_obj, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 0.244 0.000 0.067\n\n# we can verify that the gradient is correct again\ngr_package \u003c- mmcif_logLik_grad(\n comp_obj, truth, n_threads = 4L, is_log_chol = TRUE)\ngr_num \u003c- numDeriv::grad(\n mmcif_logLik, truth, object = comp_obj, n_threads = 4L, is_log_chol = TRUE, \n method = \"simple\")\n\nrbind(`Numerical gradient` = gr_num, `Gradient package` = gr_package)\n#\u003e [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]\n#\u003e Numerical gradient -27.70 0.5557 3.167 -4.275 -7.888 20.91 -15.67 -9.176 -22.88\n#\u003e Gradient package -27.69 0.5710 3.177 -4.267 -7.870 20.92 -15.66 -9.169 -22.87\n#\u003e [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [,18]\n#\u003e Numerical gradient 12.02 7.579 -9.007 10.10 24.54 -36.43 23.52 -11.57 18.89\n#\u003e Gradient package 12.02 7.605 -9.003 10.11 24.56 -36.42 23.52 -11.56 18.90\n#\u003e [,19] [,20] [,21] [,22] [,23] [,24] [,25] [,26] [,27]\n#\u003e Numerical gradient -1.542 12.25 10.04 -16.47 15.99 -18.4 -10.09 -3.850 15.52\n#\u003e Gradient package -1.535 12.26 10.04 -16.47 16.00 -18.4 -10.09 -3.849 15.52\n#\u003e [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36]\n#\u003e Numerical gradient 10.30 9.963 0.2325 25.19 -16.82 48.57 10.18 -9.259 7.031\n#\u003e Gradient package 10.31 9.965 0.2378 25.21 -16.80 48.57 10.20 -9.239 7.035\n#\u003e [,37] [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46]\n#\u003e Numerical gradient 2.899 2.786 7.047 6.840 6.110 2.291 -2.23 -28.18 37.46 4.682\n#\u003e Gradient package 2.904 2.793 7.049 6.842 6.111 2.291 -2.23 -28.17 37.47 4.686\n#\u003e [,47] [,48] [,49] [,50] [,51] [,52] [,53] [,54] [,55]\n#\u003e Numerical gradient -28.41 27.85 15.31 -1.697 -0.3346 13.87 -4.902 42.64 23\n#\u003e Gradient package -28.40 27.86 15.32 -1.693 -0.3308 13.87 -4.888 42.66 23\n#\u003e [,56] [,57] [,58] [,59] [,60] [,61] [,62] [,63] [,64]\n#\u003e Numerical gradient 47.49 -29.17 13.91 26.06 -8.109 -0.2252 12.53 -5.330 25.06\n#\u003e Gradient package 47.52 -29.14 13.92 26.07 -8.102 -0.2216 12.57 -5.194 25.06\n#\u003e [,65] [,66] [,67] [,68] [,69] [,70]\n#\u003e Numerical gradient -29.12 -10.13 -0.9177 19.73 -5.218 17.82\n#\u003e Gradient package -29.14 -10.11 -0.9119 19.72 -5.214 17.84\n\n# optimize the log composite likelihood\nsystem.time(fit \u003c- mmcif_fit(start$upper, comp_obj, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 53.143 0.004 13.288\n\n# the log composite likelihood at different points\nmmcif_logLik(comp_obj, truth, n_threads = 4L, is_log_chol = TRUE)\n#\u003e [1] -3188\nmmcif_logLik(comp_obj, start$upper, n_threads = 4L, is_log_chol = TRUE)\n#\u003e [1] -3454\n-fit$value\n#\u003e [1] -3113\n```\n\nThen we compute the sandwich estimator. The Hessian is currently\ncomputed with numerical differentiation which is why it takes a while.\n\n``` r\nsystem.time(sandwich_est \u003c- mmcif_sandwich(comp_obj, fit$par, n_threads = 4L))\n#\u003e user system elapsed \n#\u003e 83.819 0.007 20.975\n\n# setting order equal to zero yield no Richardson extrapolation and just\n# standard symmetric difference quotient. This is less precise but faster \nsystem.time(sandwich_est_simple \u003c- \n mmcif_sandwich(comp_obj, fit$par, n_threads = 4L, order = 0L))\n#\u003e user system elapsed \n#\u003e 19.09 0.00 4.80\n```\n\n#### Estimates\n\nWe show the estimated and true the conditional cumulative incidence\nfunctions (the dashed curves are the estimates) when the random effects\nare zero and the covariates are zero, ![a\\_{ij} = b\\_{ij}\n= 0](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;a_%7Bij%7D%20%3D%20b_%7Bij%7D%20%3D%200\n\"a_{ij} = b_{ij} = 0\").\n\n``` r\nlocal({\n # get the estimates\n coef_risk_est \u003c- fit$par[comp_obj$indices$coef_risk] |\u003e \n matrix(ncol = n_causes)\n coef_traject_time_est \u003c- fit$par[comp_obj$indices$coef_trajectory_time] |\u003e \n matrix(ncol = n_causes)\n coef_traject_est \u003c- fit$par[comp_obj$indices$coef_trajectory] |\u003e \n matrix(ncol = n_causes)\n \n for(strata in 1:3 - 1L){\n # compute the risk probabilities \n probs \u003c- exp(coef_risk[1 + strata * 3, ]) / \n (1 + sum(exp(coef_risk[1 + strata * 3, ])))\n probs_est \u003c- exp(coef_risk_est[1 + strata, ]) / \n (1 + sum(exp(coef_risk_est[1 + strata, ])))\n \n # plot the estimated and true conditional cumulative incidence functions. The\n # estimates are the dashed lines\n par(mar = c(5, 5, 1, 1), mfcol = c(1, 2))\n pts \u003c- seq(1e-8, delta * (1 - 1e-8), length.out = 1000)\n \n for(i in 1:2){\n true_vals \u003c- probs[i] * pnorm(\n -coef_traject[1 + strata * 2, i] * \n atanh((pts - delta / 2) / (delta / 2)) - \n coef_traject[2 + strata * 2, i])\n \n estimates \u003c- probs_est[i] * pnorm(\n -comp_obj$time_expansion(pts, cause = i, which_strata = strata + 1L) %*% \n coef_traject_time_est[, i] - \n coef_traject_est[13 + strata, i]) |\u003e drop()\n \n matplot(pts, cbind(true_vals, estimates), xlim = c(0, delta), \n ylim = c(0, 1), bty = \"l\", \n xlab = sprintf(\"Time; strata %d\", strata + 1L), lty = c(1, 2),\n ylab = sprintf(\"Cumulative incidence; cause %d\", i),\n yaxs = \"i\", xaxs = \"i\", type = \"l\", col = \"black\")\n grid()\n }\n }\n})\n```\n\n\u003cimg src=\"man/figures/README-strata_compare_estimated_incidence_funcs-1.png\" width=\"100%\" /\u003e\u003cimg src=\"man/figures/README-strata_compare_estimated_incidence_funcs-2.png\" width=\"100%\" /\u003e\u003cimg src=\"man/figures/README-strata_compare_estimated_incidence_funcs-3.png\" width=\"100%\" /\u003e\n\nFurther illustrations of the estimated model are given below.\n\n``` r\n# the number of call we made\nfit$counts\n#\u003e function gradient \n#\u003e 275 202\nfit$outer.iterations\n#\u003e [1] 3\n\n# compute the standard errors from the sandwich estimator\nSEs \u003c- diag(sandwich_est) |\u003e sqrt()\nSEs_simple \u003c- diag(sandwich_est_simple) |\u003e sqrt()\n\n# compare the estimates with the true values\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$coef_risk],\n `Standard errors` = SEs[comp_obj$indices$coef_risk],\n `Standard errors simple` = SEs_simple[comp_obj$indices$coef_risk],\n Truth = truth[comp_obj$indices$coef_risk])\n#\u003e cause1:risk:stratas1 cause1:risk:stratas2\n#\u003e Estimate AGHQ 0.7923 -0.1759\n#\u003e Standard errors 0.1630 0.1172\n#\u003e Standard errors simple 0.1630 0.1172\n#\u003e Truth 0.9000 -0.2000\n#\u003e cause1:risk:stratas3 cause1:risk:stratas1:a\n#\u003e Estimate AGHQ 0.001269 1.0592\n#\u003e Standard errors 0.197074 0.1606\n#\u003e Standard errors simple 0.197072 0.1606\n#\u003e Truth 0.000000 1.0000\n#\u003e cause1:risk:stratas2:a cause1:risk:stratas3:a\n#\u003e Estimate AGHQ 0.53805 0.03489\n#\u003e Standard errors 0.09333 0.14148\n#\u003e Standard errors simple 0.09333 0.14148\n#\u003e Truth 0.50000 0.00000\n#\u003e cause1:risk:stratas1:b cause1:risk:stratas2:b\n#\u003e Estimate AGHQ 0.05839 -0.1338\n#\u003e Standard errors 0.24080 0.1515\n#\u003e Standard errors simple 0.24080 0.1515\n#\u003e Truth 0.10000 0.0000\n#\u003e cause1:risk:stratas3:b cause2:risk:stratas1\n#\u003e Estimate AGHQ 0.09211 -0.2901\n#\u003e Standard errors 0.30169 0.1932\n#\u003e Standard errors simple 0.30169 0.1932\n#\u003e Truth 0.50000 -0.4000\n#\u003e cause2:risk:stratas2 cause2:risk:stratas3\n#\u003e Estimate AGHQ 0.06883 1.450\n#\u003e Standard errors 0.11723 0.162\n#\u003e Standard errors simple 0.11723 0.162\n#\u003e Truth 0.00000 1.500\n#\u003e cause2:risk:stratas1:a cause2:risk:stratas2:a\n#\u003e Estimate AGHQ 0.3512 0.5659\n#\u003e Standard errors 0.1696 0.1021\n#\u003e Standard errors simple 0.1696 0.1021\n#\u003e Truth 0.2500 0.5000\n#\u003e cause2:risk:stratas3:a cause2:risk:stratas1:b\n#\u003e Estimate AGHQ -0.3922 0.7425\n#\u003e Standard errors 0.1274 0.2507\n#\u003e Standard errors simple 0.1274 0.2507\n#\u003e Truth -0.2500 0.3000\n#\u003e cause2:risk:stratas2:b cause2:risk:stratas3:b\n#\u003e Estimate AGHQ 0.07194 0.0682\n#\u003e Standard errors 0.16243 0.2369\n#\u003e Standard errors simple 0.16243 0.2369\n#\u003e Truth 0.25000 0.0000\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$coef_trajectory],\n `Standard errors` = SEs[comp_obj$indices$coef_trajectory],\n `Standard errors simple` = SEs_simple[comp_obj$indices$coef_trajectory],\n Truth = truth[comp_obj$indices$coef_trajectory])\n#\u003e cause1:stratas1:spline1 cause1:stratas1:spline2\n#\u003e Estimate AGHQ -3.2010 -3.5607\n#\u003e Standard errors 0.2427 0.2601\n#\u003e Standard errors simple 0.2428 0.2602\n#\u003e Truth -2.8430 -3.3002\n#\u003e cause1:stratas1:spline3 cause1:stratas1:spline4\n#\u003e Estimate AGHQ -6.7795 -5.1280\n#\u003e Standard errors 0.4561 0.2910\n#\u003e Standard errors simple 0.4561 0.2911\n#\u003e Truth -6.2296 -4.5237\n#\u003e cause1:stratas2:spline1 cause1:stratas2:spline2\n#\u003e Estimate AGHQ -3.7158 -4.5710\n#\u003e Standard errors 0.3601 0.3229\n#\u003e Standard errors simple 0.3609 0.3235\n#\u003e Truth -3.5537 -4.1252\n#\u003e cause1:stratas2:spline3 cause1:stratas2:spline4\n#\u003e Estimate AGHQ -8.5852 -6.2917\n#\u003e Standard errors 0.7571 0.4279\n#\u003e Standard errors simple 0.7585 0.4281\n#\u003e Truth -7.7871 -5.6546\n#\u003e cause1:stratas3:spline1 cause1:stratas3:spline2\n#\u003e Estimate AGHQ -1.7813 -2.0843\n#\u003e Standard errors 0.2582 0.2723\n#\u003e Standard errors simple 0.2583 0.2724\n#\u003e Truth -1.7769 -2.0626\n#\u003e cause1:stratas3:spline3 cause1:stratas3:spline4\n#\u003e Estimate AGHQ -4.0289 -3.0246\n#\u003e Standard errors 0.3674 0.2751\n#\u003e Standard errors simple 0.3674 0.2752\n#\u003e Truth -3.8935 -2.8273\n#\u003e cause1:traject:stratas1 cause1:traject:stratas2\n#\u003e Estimate AGHQ 2.8064 3.6768\n#\u003e Standard errors 0.2388 0.3796\n#\u003e Standard errors simple 0.2389 0.3803\n#\u003e Truth 2.4724 3.5529\n#\u003e cause1:traject:stratas3 cause1:traject:stratas1:a\n#\u003e Estimate AGHQ 1.7957 0.8952\n#\u003e Standard errors 0.2393 0.1052\n#\u003e Standard errors simple 0.2393 0.1052\n#\u003e Truth 1.4265 0.8000\n#\u003e cause1:traject:stratas2:a cause1:traject:stratas3:a\n#\u003e Estimate AGHQ -0.01428 -0.1030\n#\u003e Standard errors 0.10678 0.1968\n#\u003e Standard errors simple 0.10678 0.1968\n#\u003e Truth 0.00000 0.0000\n#\u003e cause1:traject:stratas1:b cause1:traject:stratas2:b\n#\u003e Estimate AGHQ 0.4838 0.4796\n#\u003e Standard errors 0.1813 0.1592\n#\u003e Standard errors simple 0.1813 0.1592\n#\u003e Truth 0.4000 0.4000\n#\u003e cause1:traject:stratas3:b cause2:stratas1:spline1\n#\u003e Estimate AGHQ 0.5816 -5.761\n#\u003e Standard errors 0.2325 2.134\n#\u003e Standard errors simple 0.2325 2.187\n#\u003e Truth 0.4000 -7.489\n#\u003e cause2:stratas1:spline2 cause2:stratas1:spline3\n#\u003e Estimate AGHQ -7.035 -14.726\n#\u003e Standard errors 1.473 4.730\n#\u003e Standard errors simple 1.506 4.828\n#\u003e Truth -8.627 -16.185\n#\u003e cause2:stratas1:spline4 cause2:stratas2:spline1\n#\u003e Estimate AGHQ -16.473 -2.8102\n#\u003e Standard errors 2.939 0.2073\n#\u003e Standard errors simple 2.939 0.2073\n#\u003e Truth -11.545 -2.4964\n#\u003e cause2:stratas2:spline2 cause2:stratas2:spline3\n#\u003e Estimate AGHQ -2.9688 -5.8040\n#\u003e Standard errors 0.2003 0.3985\n#\u003e Standard errors simple 0.2003 0.3984\n#\u003e Truth -2.8756 -5.3949\n#\u003e cause2:stratas2:spline4 cause2:stratas3:spline1\n#\u003e Estimate AGHQ -4.3456 -3.3808\n#\u003e Standard errors 0.2495 0.2145\n#\u003e Standard errors simple 0.2495 0.2147\n#\u003e Truth -3.8482 -3.1205\n#\u003e cause2:stratas3:spline2 cause2:stratas3:spline3\n#\u003e Estimate AGHQ -3.8469 -7.5452\n#\u003e Standard errors 0.1953 0.4057\n#\u003e Standard errors simple 0.1955 0.4061\n#\u003e Truth -3.5945 -6.7437\n#\u003e cause2:stratas3:spline4 cause2:traject:stratas1\n#\u003e Estimate AGHQ -5.1459 5.845\n#\u003e Standard errors 0.2331 2.183\n#\u003e Standard errors simple 0.2332 2.238\n#\u003e Truth -4.8103 7.839\n#\u003e cause2:traject:stratas2 cause2:traject:stratas3\n#\u003e Estimate AGHQ 2.4703 3.3416\n#\u003e Standard errors 0.2028 0.2059\n#\u003e Standard errors simple 0.2028 0.2060\n#\u003e Truth 2.4130 2.9538\n#\u003e cause2:traject:stratas1:a cause2:traject:stratas2:a\n#\u003e Estimate AGHQ 0.7082 0.1265\n#\u003e Standard errors 0.1865 0.0823\n#\u003e Standard errors simple 0.1864 0.0823\n#\u003e Truth 0.2500 0.0000\n#\u003e cause2:traject:stratas3:a cause2:traject:stratas1:b\n#\u003e Estimate AGHQ 0.20878 0.115\n#\u003e Standard errors 0.07843 0.244\n#\u003e Standard errors simple 0.07843 0.244\n#\u003e Truth 0.25000 -0.200\n#\u003e cause2:traject:stratas2:b cause2:traject:stratas3:b\n#\u003e Estimate AGHQ -0.009036 -0.1022\n#\u003e Standard errors 0.139463 0.1222\n#\u003e Standard errors simple 0.139463 0.1222\n#\u003e Truth -0.200000 0.0000\n\nn_vcov \u003c- (2L * n_causes * (2L * n_causes + 1L)) %/% 2L\nSigma\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.306 0.008 -0.138 0.197\n#\u003e [2,] 0.008 0.759 0.251 -0.250\n#\u003e [3,] -0.138 0.251 0.756 -0.319\n#\u003e [4,] 0.197 -0.250 -0.319 0.903\nlog_chol_inv(tail(fit$par, n_vcov))\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.542728 0.18194 -0.007323 0.29914\n#\u003e [2,] 0.181944 0.72815 0.209301 0.04277\n#\u003e [3,] -0.007323 0.20930 0.942073 -0.32357\n#\u003e [4,] 0.299137 0.04277 -0.323574 1.14963\n\n# on the log Cholesky scale\nrbind(`Estimate AGHQ` = fit$par[comp_obj$indices$vcov_upper],\n `Standard errors` = SEs[comp_obj$indices$vcov_upper],\n `Standard errors simple` = SEs_simple[comp_obj$indices$vcov_upper],\n Truth = truth[comp_obj$indices$vcov_upper])\n#\u003e vcov:risk1:risk1 vcov:risk1:risk2 vcov:risk2:risk2\n#\u003e Estimate AGHQ -0.3056 0.24697 -0.2024\n#\u003e Standard errors 0.1951 0.24672 0.1543\n#\u003e Standard errors simple 0.1951 0.24671 0.1543\n#\u003e Truth -0.5921 0.01446 -0.1380\n#\u003e vcov:risk1:traject1 vcov:risk2:traject1\n#\u003e Estimate AGHQ -0.00994 0.2593\n#\u003e Standard errors 0.20102 0.1760\n#\u003e Standard errors simple 0.20101 0.1760\n#\u003e Truth -0.24947 0.2923\n#\u003e vcov:traject1:traject1 vcov:risk1:traject2\n#\u003e Estimate AGHQ -0.0669 0.4060\n#\u003e Standard errors 0.1073 0.2190\n#\u003e Standard errors simple 0.1074 0.2190\n#\u003e Truth -0.2485 0.3561\n#\u003e vcov:risk2:traject2 vcov:traject1:traject2\n#\u003e Estimate AGHQ -0.07042 -0.3221\n#\u003e Standard errors 0.23721 0.1872\n#\u003e Standard errors simple 0.23720 0.1872\n#\u003e Truth -0.29291 -0.1853\n#\u003e vcov:traject2:traject2\n#\u003e Estimate AGHQ -0.06618\n#\u003e Standard errors 0.15167\n#\u003e Standard errors simple 0.15168\n#\u003e Truth -0.21077\n\n# on the original covariance matrix scale\nvcov_est \u003c- log_chol_inv(tail(fit$par, n_vcov))\nvcov_est[lower.tri(vcov_est)] \u003c- NA_real_\nvcov_SE \u003c- matrix(NA_real_, NROW(vcov_est), NCOL(vcov_est))\nvcov_SE[upper.tri(vcov_SE, TRUE)] \u003c- \n attr(sandwich_est, \"res vcov\") |\u003e diag() |\u003e sqrt() |\u003e \n tail(n_vcov)\n\nvcov_show \u003c- cbind(Estimates = vcov_est, NA, SEs = vcov_SE) \ncolnames(vcov_show) \u003c- \n c(rep(\"Est.\", NCOL(vcov_est)), \"\", rep(\"SE\", NCOL(vcov_est)))\nprint(vcov_show, na.print = \"\")\n#\u003e Est. Est. Est. Est. SE SE SE SE\n#\u003e [1,] 0.5427 0.1819 -0.007323 0.29914 0.2118 0.1987 0.1481 0.1564\n#\u003e [2,] 0.7282 0.209301 0.04277 0.2558 0.1589 0.1937\n#\u003e [3,] 0.942073 -0.32357 0.1865 0.1662\n#\u003e [4,] 1.14963 0.2150\n\nSigma # the true values\n#\u003e [,1] [,2] [,3] [,4]\n#\u003e [1,] 0.306 0.008 -0.138 0.197\n#\u003e [2,] 0.008 0.759 0.251 -0.250\n#\u003e [3,] -0.138 0.251 0.756 -0.319\n#\u003e [4,] 0.197 -0.250 -0.319 0.903\n```\n\n## Three Cause Example\n\nIn this section, we show an example with ![K\n= 3](https://latex.codecogs.com/png.image?%5Cdpi%7B110%7D\u0026space;%5Cbg_white\u0026space;K%20%3D%203\n\"K = 3\") causes. First, we assign the parameters and plot the cumulative\nincidence functions when the random effects are zero and the covariates\nare zero.\n\n``` r\n# assign model parameters\nn_causes \u003c- 3L\ndelta \u003c- 2\n\n# set the betas\ncoef_risk \u003c- c(.67, 1, .1, -.4, .25, .3, 0.56, -0.2, 0.14) |\u003e \n matrix(ncol = n_causes)\n\n# set the gammas\ncoef_traject \u003c- c(-.8, -.45, .8, .4, -1.2, .15, .25, -.2, \n -0.6, -0.38, 0.66, -0.64) |\u003e \n matrix(ncol = n_causes)\n\n# plot the conditional cumulative incidence functions when random effects and \n# covariates are all zero\nlocal({\n probs \u003c- exp(coef_risk[1, ]) / (1 + sum(exp(coef_risk[1, ])))\n par(mar = c(5, 5, 1, 1), mfcol = c(2, 2))\n \n for(i in 1:3){\n plot(\\(x) probs[i] * pnorm(\n -coef_traject[1, i] * atanh((x - delta / 2) / (delta / 2)) - \n coef_traject[2, i]),\n xlim = c(0, delta), ylim = c(0, 1), bty = \"l\", xlab = \"Time\", \n ylab = sprintf(\"Cumulative incidence; cause %d\", i),\n yaxs = \"i\", xaxs = \"i\")\n grid()\n }\n})\n# set the covariance matrix\nSigma \u003c- c(0.637, -0.19, 0.261, -0.203, 0.186, -0.085, -0.19, 0.348, -0.16, -0.089, -0.166, -0.048, 0.261, -0.16, 0.312, -0.022, 0.089, -0.149, -0.203, -0.089, -0.022, 0.246, -0.09, 0.031, 0.186, -0.166, 0.089, -0.09, 0.402, -0.077, -0.085, -0.048, -0.149, 0.031, -0.077, 0.602) |\u003e \n matrix(2L * n_causes)\n```\n\n\u003cimg src=\"man/figures/README-three_assign_model_parameters-1.png\" width=\"100%\" /\u003e\n\nThen we assign a simulation function like before with delayed entry but\nwith the additional cause.\n\n``` r\nlibrary(mvtnorm)\n\n# simulates a data set with a given number of clusters and maximum number of \n# observations per cluster\nsim_dat \u003c- \\(n_clusters, max_cluster_size){\n stopifnot(max_cluster_size \u003e 0,\n n_clusters \u003e 0)\n \n cluster_id \u003c- 0L\n replicate(n_clusters, simplify = FALSE, {\n n_obs \u003c- sample.int(max_cluster_size, 1L)\n cluster_id \u003c\u003c- cluster_id + 1L\n \n # draw the covariates and the left truncation time\n covs \u003c- cbind(a = rnorm(n_obs), b = runif(n_obs, -1))\n Z \u003c- cbind(1, covs)\n \n delayed_entry \u003c- pmax(runif(n_obs, -1), 0)\n cens \u003c- rep(-Inf, n_obs)\n while(all(cens \u003c= delayed_entry))\n cens \u003c- runif(n_obs, max = 3 * delta)\n \n successful_sample \u003c- FALSE\n while(!successful_sample){\n rng_effects \u003c- rmvnorm(1, sigma = Sigma) |\u003e drop()\n U \u003c- head(rng_effects, n_causes)\n eta \u003c- tail(rng_effects, n_causes)\n \n # draw the cause\n cond_logits_exp \u003c- exp(Z %*% coef_risk + rep(U, each = n_obs)) |\u003e \n cbind(1)\n cond_probs \u003c- cond_logits_exp / rowSums(cond_logits_exp)\n cause \u003c- apply(cond_probs, 1, \n \\(prob) sample.int(n_causes + 1L, 1L, prob = prob))\n \n # compute the observed time if needed\n obs_time \u003c- mapply(\\(cause, idx){\n if(cause \u003e n_causes)\n return(delta)\n \n # can likely be done smarter but this is more general\n coefs \u003c- coef_traject[, cause]\n offset \u003c- sum(Z[idx, ] * coefs[-1]) + eta[cause]\n rng \u003c- runif(1)\n eps \u003c- .Machine$double.eps\n root \u003c- uniroot(\n \\(x) rng - pnorm(\n -coefs[1] * atanh((x - delta / 2) / (delta / 2)) - offset), \n c(eps^2, delta * (1 - eps)), tol = 1e-12)$root\n }, cause, 1:n_obs)\n \n keep \u003c- which(pmin(obs_time, cens) \u003e delayed_entry)\n successful_sample \u003c- length(keep) \u003e 0\n if(!successful_sample)\n next\n \n has_finite_trajectory_prob \u003c- cause \u003c= n_causes\n is_censored \u003c- which(!has_finite_trajectory_prob | cens \u003c obs_time)\n \n if(length(is_censored) \u003e 0){\n obs_time[is_censored] \u003c- pmin(delta, cens[is_censored])\n cause[is_censored] \u003c- n_causes + 1L\n }\n }\n \n data.frame(covs, cause, time = obs_time, cluster_id, delayed_entry)[keep, ]\n }) |\u003e \n do.call(what = rbind)\n}\n```\n\nWe then sample a data set, setup the C++ object to do the computation,\nfit the model and compute the sandwich estimator.\n\n``` r\n# sample a data set\nset.seed(8401828)\nn_clusters \u003c- 1000L\nmax_cluster_size \u003c- 5L\ndat \u003c- sim_dat(n_clusters, max_cluster_size = max_cluster_size)\n\n# show some stats\nNROW(dat) # number of individuals\n#\u003e [1] 2436\ntable(dat$cause) # distribution of causes (4 is censored)\n#\u003e \n#\u003e 1 2 3 4 \n#\u003e 786 284 600 766\n\n# distribution of observed times by cause\ntapply(dat$time, dat$cause, quantile, \n probs = seq(0, 1, length.out = 11), na.rm = TRUE)\n#\u003e $`1`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 1.208e-05 2.442e-02 1.202e-01 3.211e-01 5.966e-01 9.704e-01 1.347e+00 1.625e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.848e+00 1.970e+00 2.000e+00 \n#\u003e \n#\u003e $`2`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.008254 0.167846 0.273404 0.474006 0.660235 0.847364 1.170765 1.356371 \n#\u003e 80% 90% 100% \n#\u003e 1.583251 1.779544 1.986833 \n#\u003e \n#\u003e $`3`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 2.183e-09 5.804e-04 4.394e-03 2.310e-02 1.124e-01 3.283e-01 7.082e-01 1.266e+00 \n#\u003e 80% 90% 100% \n#\u003e 1.744e+00 1.953e+00 2.000e+00 \n#\u003e \n#\u003e $`4`\n#\u003e 0% 10% 20% 30% 40% 50% 60% 70% \n#\u003e 0.001316 0.373174 0.756691 1.046705 1.352014 1.712767 2.000000 2.000000 \n#\u003e 80% 90% 100% \n#\u003e 2.000000 2.000000 2.000000\n```\n\n#### Optimization\n\n``` r\nlibrary(mmcif)\ncomp_obj \u003c- mmcif_data(\n ~ a + b, dat, cause = cause, time = time, cluster_id = cluster_id,\n max_time = delta, spline_df = 4L, left_trunc = delayed_entry)\n```\n\n``` r\nNCOL(comp_obj$pair_indices) # the number of pairs in the composite likelihood\n#\u003e [1] 2543\nlength(comp_obj$singletons) # the number of clusters with one observation\n#\u003e [1] 306\n\n# we need to find the combination of the spline bases that yield a straight \n# line to construct the true values using the splines. You can skip this\ncomb_slope \u003c- sapply(comp_obj$spline, \\(spline){\n boundary_knots \u003c- spline$boundary_knots\n pts \u003c- seq(boundary_knots[1], boundary_knots[2], length.out = 1000)\n lm.fit(cbind(1, spline$expansion(pts)), pts)$coef\n})\n\n# assign a function to compute the log composite likelihood\nll_func \u003c- \\(par, n_threads = 1L)\n mmcif_logLik(\n comp_obj, par = par, n_threads = n_threads, is_log_chol = FALSE)\n\n# the log composite likelihood at the true parameters\ncoef_traject_spline \u003c- \n rbind(comb_slope[-1, ] * rep(coef_traject[1, ], each = NROW(comb_slope) - 1), \n coef_traject[2, ] + comb_slope[1, ] * coef_traject[1, ],\n coef_traject[-(1:2), ])\ntrue_values \u003c- c(coef_risk, coef_traject_spline, Sigma)\nll_func(true_values)\n#\u003e [1] -4785\n\n# check the time to compute the log composite likelihood\nbench::mark(\n `one thread` = ll_func(n_threads = 1L, true_values),\n `two threads` = ll_func(n_threads = 2L, true_values),\n `three threads` = ll_func(n_threads = 3L, true_values),\n `four threads` = ll_func(n_threads = 4L, true_values), \n min_time = 4)\n#\u003e # A tibble: 4 × 6\n#\u003e expression min median `itr/sec` mem_alloc `gc/sec`\n#\u003e \u003cbch:expr\u003e \u003cbch:tm\u003e \u003cbch:tm\u003e \u003cdbl\u003e \u003cbch:byt\u003e \u003cdbl\u003e\n#\u003e 1 one thread 292.2ms 299ms 3.33 0B 0\n#\u003e 2 two threads 154.1ms 155ms 6.38 0B 0\n#\u003e 3 three threads 106.5ms 115ms 8.66 0B 0\n#\u003e 4 four threads 89.1ms 91ms 10.9 0B 0\n\n# next, we compute the gradient of the log composite likelihood at the true \n# parameters. First we assign a few functions to verify the result. You can \n# skip these\nupper_to_full \u003c- \\(x){\n dim \u003c- (sqrt(8 * length(x) + 1) - 1) / 2\n out \u003c- matrix(0, dim, dim)\n out[upper.tri(out, TRUE)] \u003c- x\n out[lower.tri(out)] \u003c- t(out)[lower.tri(out)]\n out\n}\nd_upper_to_full \u003c- \\(x){\n dim \u003c- (sqrt(8 * length(x) + 1) - 1) / 2\n out \u003c- matrix(0, dim, dim)\n out[upper.tri(out, TRUE)] \u003c- x\n out[upper.tri(out)] \u003c- out[upper.tri(out)] / 2\n out[lower.tri(out)] \u003c- t(out)[lower.tri(out)]\n out\n}\n\n# then we can compute the gradient with the function from the package and with \n# numerical differentiation\ngr_func \u003c- function(par, n_threads = 1L)\n mmcif_logLik_grad(comp_obj, par, n_threads = n_threads, is_log_chol = FALSE)\ngr_package \u003c- gr_func(true_values)\n\ntrue_values_upper \u003c- \n c(coef_risk, coef_traject_spline, Sigma[upper.tri(Sigma, TRUE)])\ngr_num \u003c- numDeriv::grad(\n \\(x) ll_func(c(head(x, -21), upper_to_full(tail(x, 21)))), \n true_values_upper, method = \"simple\")\n\n# they are very close but not exactly equal as expected (this is due to the \n# adaptive quadrature)\nrbind(\n `Numerical gradient` = \n c(head(gr_num, -21), d_upper_to_full(tail(gr_num, 21))), \n `Gradient package` = gr_package)\n#\u003e [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]\n#\u003e Numerical gradient -12.31 31.09 -7.838 -10.01 -4.852 8.847 30.30 26.62 8.099\n#\u003e Gradient package -12.27 31.12 -7.826 -9.99 -4.831 8.855 30.34 26.65 8.112\n#\u003e [,10] [,11] [,12] [,13] [,14] [,15] [,16] [,17] [,18]\n#\u003e Numerical gradient -26.43 -22.79 -36.52 33.58 -140.7 -114.7 64.62 -42.28 42.93\n#\u003e Gradient package -26.40 -22.77 -36.51 33.59 -140.6 -114.6 64.64 -42.26 42.94\n#\u003e [,19] [,20] [,21] [,22] [,23] [,24] [,25] [,26]\n#\u003e Numerical gradient -46.17 1.290 -43.46 -24.32 -14.81 -12.04 -0.6390 -30.67\n#\u003e Gradient package -46.16 1.296 -43.44 -24.30 -14.80 -12.02 -0.6251 -30.66\n#\u003e [,27] [,28] [,29] [,30] [,31] [,32] [,3","project_url":"https://awesome.ecosyste.ms/api/v1/projects/github.com%2Fboennecd%2Fmmcif","html_url":"https://awesome.ecosyste.ms/projects/github.com%2Fboennecd%2Fmmcif","lists_url":"https://awesome.ecosyste.ms/api/v1/projects/github.com%2Fboennecd%2Fmmcif/lists"}