├── .Rbuildignore ├── .Rproj.user └── 650594D1 │ ├── cpp-definition-cache │ ├── pcs │ ├── files-pane.pper │ ├── source-pane.pper │ ├── windowlayoutstate.pper │ └── workbench-pane.pper │ ├── saved_source_markers │ └── sdb │ ├── per │ ├── t │ │ ├── 441A7E9 │ │ ├── 680830F5 │ │ ├── 7AB74853 │ │ ├── 93BE7D02 │ │ ├── C7160C89 │ │ ├── D0257DA6 │ │ └── F461245 │ └── u │ │ └── D80A67CC │ └── prop │ ├── 57742131 │ ├── 1CDB4DDC │ ├── 1ED51FA1 │ ├── 2257E678 │ ├── 3582BADD │ ├── 36E5C93E │ ├── 66C5BD8C │ ├── 71382EBB │ ├── 7357ADA4 │ ├── 970E7439 │ ├── 99478E9E │ ├── A3AB6BAE │ ├── AA9B5996 │ ├── BE84F276 │ ├── C2A885FC │ ├── D5A1AB2D │ ├── F64CC370 │ ├── FEA27AD7 │ └── INDEX ├── .gitattributes ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── JM.Rproj ├── NAMESPACE ├── R ├── H.longAFTWB.R ├── H.longPC.R ├── H.longSplinePH.R ├── H.longWB.R ├── HessLongPH.R ├── HessSurvPH.R ├── LogLik.phGH.R ├── LogLik.piecewiseGH.R ├── LogLik.splineGH.R ├── LogLik.weibullAFTGH.R ├── LogLik.weibullGH.R ├── MI.fixed.times.R ├── MI.random.times.R ├── ModelMats.R ├── S.b.R ├── Score.phGH.R ├── Score.piecewiseGH.R ├── Score.splineGH.R ├── Score.weibullAFTGH.R ├── Score.weibullGH.R ├── anova.jointModel.R ├── aucJM.R ├── aucJM.coxph.R ├── aucJM.jointModel.R ├── cd.R ├── cd.vec.R ├── chol.transf.R ├── coef.flexCPH.R ├── coef.jointModel.R ├── coef.summary.jointModel.R ├── coef.weibull.frailty.R ├── confint.jointModel.R ├── crLong.R ├── cumHaz.R ├── dataLM.R ├── dbs.R ├── deriv.D.R ├── dmvnorm.R ├── dmvt.R ├── dns.R ├── dropAttr.R ├── dynCJM.R ├── dynCJM.coxph.R ├── dynCJM.jointModel.R ├── fd.vec.R ├── fitted.jointModel.R ├── fixef.jointModel.R ├── flexCPH.R ├── flexCPH.fit.R ├── fn.R ├── format.perc2.R ├── gauher.R ├── gaussKronrod.R ├── globals.R ├── gr.R ├── gr.longAFTWB.R ├── gr.longPC.R ├── gr.longPH.R ├── gr.longSplinePH.R ├── gr.longWB.R ├── gr.survAFTWB.R ├── gr.survPC.R ├── gr.survPH.R ├── gr.survSplinePH.R ├── gr.survWB.R ├── ibs.R ├── initial.surv.R ├── initial.survOld.R ├── ins.R ├── jacobian.R ├── jacobian2.R ├── jointModel.R ├── log.posterior.b.R ├── log.posterior.b2.R ├── logLik.flexCPH.R ├── logLik.jointModel.R ├── logLik.weibull.frailty.R ├── makepredictcall.dbs.R ├── makepredictcall.dns.R ├── makepredictcall.ibs.R ├── makepredictcall.ins.R ├── marginal_coefs.R ├── nearPD.R ├── opt.longAFTWB.R ├── opt.longPC.R ├── opt.longPH.R ├── opt.longSplinePH.R ├── opt.longWB.R ├── opt.survAFTWB.R ├── opt.survPC.R ├── opt.survPH.R ├── opt.survSplinePH.R ├── opt.survWB.R ├── phGH.fit.R ├── piecewiseAFTGH.fit.R ├── piecewiseExp.ph.R ├── piecewisePHGH.fit.R ├── plot.flexCPH.R ├── plot.jointModel.R ├── plot.rocJM.R ├── plot.survfitJM.R ├── posterior.b.R ├── prederrJM.R ├── prederrJM.coxph.R ├── prederrJM.jointModel.R ├── predict.b.R ├── predict.jointModel.R ├── print.aov.jointModel.R ├── print.aucJM.R ├── print.dynCJM.R ├── print.flexCPH.R ├── print.jointModel.R ├── print.prederrJM.R ├── print.rocJM.R ├── print.summary.flexCPH.R ├── print.summary.jointModel.R ├── print.summary.weibull.frailty.R ├── print.survfitJM.R ├── print.wald.strata.R ├── print.weibull.frailty.R ├── ranef.jointModel.R ├── residuals.jointModel.R ├── rmvt.R ├── rocJM.R ├── simulate.jointModel.R ├── simulateJM.R ├── splinePHGH.fit.R ├── splinePHLaplace.fit.R ├── summary.flexCPH.R ├── summary.jointModel.R ├── summary.weibull.frailty.R ├── survfitJM.R ├── survfitJM.jointModel.R ├── update.logLik.Laplace.R ├── vcov.flexCPH.R ├── vcov.jointModel.R ├── vcov.weibull.frailty.R ├── wald.strata.R ├── weibull.frailty.R ├── weibull.frailty.fit.R ├── weibullAFTGH.fit.R ├── weibullPHGH.fit.R └── xtable.jointModel.R ├── README.md ├── data ├── aids.id.rda ├── aids.rda ├── pbc2.id.rda ├── pbc2.rda ├── prothro.rda └── prothros.rda ├── inst ├── CITATION └── NEWS └── man ├── DerivIntSplines.Rd ├── JM.Rd ├── aids.Rd ├── anova.Rd ├── aucJM.Rd ├── coef.Rd ├── crLong.Rd ├── dynCJM.Rd ├── fitted.Rd ├── jointModel.Rd ├── jointModelObject.Rd ├── pbc.Rd ├── piecewiseExp.ph.Rd ├── plot-rocJM.Rd ├── plot-survfitJM.Rd ├── plot.Rd ├── prederrJM.Rd ├── predict.Rd ├── prothro.Rd ├── ranef.Rd ├── residuals.Rd ├── rocJM.Rd ├── simulate.Rd ├── summary.weibull.frailty.Rd ├── survfitJM.Rd ├── wald.strata.Rd ├── weibull.frailty.Rd └── xtable.Rd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ -------------------------------------------------------------------------------- /.Rproj.user/650594D1/cpp-definition-cache: -------------------------------------------------------------------------------- 1 | [ 2 | ] -------------------------------------------------------------------------------- /.Rproj.user/650594D1/pcs/files-pane.pper: -------------------------------------------------------------------------------- 1 | { 2 | "path" : "C:/Users/Dimitris/Documents/PackagesGitHub/JM/man", 3 | "sortOrder" : [ 4 | { 5 | "ascending" : true, 6 | "columnIndex" : 2 7 | } 8 | ] 9 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/pcs/source-pane.pper: -------------------------------------------------------------------------------- 1 | { 2 | "activeTab" : 2 3 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/pcs/windowlayoutstate.pper: -------------------------------------------------------------------------------- 1 | { 2 | "left" : { 3 | "panelheight" : 955, 4 | "splitterpos" : 397, 5 | "topwindowstate" : "NORMAL", 6 | "windowheight" : 993 7 | }, 8 | "right" : { 9 | "panelheight" : 955, 10 | "splitterpos" : 595, 11 | "topwindowstate" : "NORMAL", 12 | "windowheight" : 993 13 | } 14 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/pcs/workbench-pane.pper: -------------------------------------------------------------------------------- 1 | { 2 | "TabSet1" : 0, 3 | "TabSet2" : 0 4 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/saved_source_markers: -------------------------------------------------------------------------------- 1 | {"active_set":"","sets":[]} -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/per/t/C7160C89: -------------------------------------------------------------------------------- 1 | { 2 | "contents" : "library(\"MASS\")\nlibrary(\"nlme\")\nlibrary(\"splines\")\nlibrary(\"survival\")\nlibrary(\"lattice\")\nlibrary(\"devtools\")\nsourceDir <- function(path, ...) {\n for (nm in list.files(path, pattern = \"[.][RrSsQq]$\")) {\n source(file.path(path, nm), ...)\n }\n}\nsourceDir(file.path(getwd(), \"R\")); rm(sourceDir)\n\ndata(pbc2, package = \"JM\")\ndata(pbc2.id, package = \"JM\")\ndata(aids, package = \"JM\")\ndata(aids.id, package = \"JM\")\ndata(prothro, package = \"JM\")\ndata(prothros, package = \"JM\")\n\n#############################################\n\n# PBC\npbc2$status2 <- as.numeric(pbc2$status != \"alive\")\npbc2.id$status2 <- as.numeric(pbc2.id$status != \"alive\")\npbc2$serBilirD <- 1 * (pbc2$serBilir > 1.8)\npbc2$edemaBase <- with(pbc2, ave(edema, id, FUN = function (x) x[1]))\nlmeFit <- lme(log(serBilir) ~ ns(year, 2),\n random = ~ ns(year, 2) | id, data = pbc2)\n#lmeFit <- lme(log(serBilir) ~ edemaBase + year + drug + I(year^2) + age + year:edemaBase + drug:year + I(year^2):drug,\n# random = ~ year | id, data = pbc2)\nsurvFit <- coxph(Surv(years, status2) ~ 1, data = pbc2.id, x = TRUE)\n\n\n# AIDS\nlmeFit <- lme(CD4 ~ obstime + gender + drug, data = aids, \n random = ~ obstime | patient)\n#survFit <- coxph(Surv(Time, death) ~ drug + gender, data = aids.id, x = TRUE)\nsurvFit <- coxph(Surv(start, stop, event) ~ drug + gender + cluster(patient), \n data = aids, x = TRUE, model = TRUE)\naids.id$start <- runif(nrow(aids.id), 0, 1) # left-truncation\naids.id$stop <- aids.id$Time\nsurvFit <- coxph(Surv(start, stop, event) ~ drug + gender + cluster(patient), \n data = aids.id, x = TRUE, model = TRUE)\n\n\nlmeObject = lmeFit\nsurvObject = survFit\ntimeVar = \"year\" #\"obstime\"\nparam = \"td-value\"\nextraForm = NULL\ntransFun = NULL\ndensLong = NULL\nbaseHaz = \"P-splines\" # \"regression-splines\"\nlag = 0\ninit = NULL\npriors = NULL\ncontrol = list()\ndf.RE = NULL\nscales = NULL\nestimateWeightFun = FALSE\nweightFun <- function (u, parms, t.max) {\n #num <- dnorm(x = u, sd = parms)\n #den <- pnorm(q = c(0, t.max), sd = parms)\n #num / (den[2L] - den[1L])\n exp(- parms * u)\n}\npriors = list(priorR.invD = diag(2))\n\n\ninitials = initial.values\npriors = prs\ncontrol = con\ncontrol$verbose = F\n\n##################################################################################\n\nlmeFit <- lme(log(serBilir) ~ ns(year, 2) + age + sex,\n random = ~ ns(year, 2) | id, data = pbc2)\nsurvFit <- coxph(Surv(years, status2) ~ drug, data = pbc2.id, x = TRUE)\n\njointFit <- jointModel(lmeFit, survFit, timeVar = \"year\", method = \"piecewise-PH-aGH\")\n\n\nobject = jointFit\nnewdata = pbc2[pbc2$id %in% c(2, 21), ]\ntype = \"SurvProb\" \nidVar = \"id\"; simulate = TRUE; survTimes = NULL \nlast.time = NULL; LeftTrunc_var = NULL; M = 200L \nCI.levels = c(0.025, 0.975); log = FALSE; scale = 1.6; weight = rep(1, nrow(newdata)) \ninit.b = NULL; seed = 1L\n\n##################################################################################\n\n\nlibrary(\"shiny\")\nrunApp(file.path(.Library, \"JMbayes/demo\"))\n\nrunDynPred()\n\nrunApp(file.path(getwd(), \"vers2\", \"Rpgm\", \"shiny\"))\n\n\n\ngc()\n", 3 | "created" : 1443615992393.000, 4 | "dirty" : false, 5 | "encoding" : "UTF-8", 6 | "folds" : "", 7 | "hash" : "1030676887", 8 | "id" : "C7160C89", 9 | "lastKnownWriteTime" : 1443617934, 10 | "path" : "C:/Users/Dimitris/Documents/PackagesGitHub/TestFiles/JM/Test.r", 11 | "project_path" : null, 12 | "properties" : { 13 | }, 14 | "relative_order" : 1, 15 | "source_on_save" : false, 16 | "type" : "r_source" 17 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/per/u/D80A67CC: -------------------------------------------------------------------------------- 1 | { 2 | "contents" : "lmeObject = lmeFit\nsurvObject = survFit\ntimeVar = \"year\"\nparameterization = \"value\"\nmethod. = \"piecewise-PH-GH\"\ninterFact = NULL\nderivForm = NULL\nlag = 0 \nscaleWB = NULL\nCompRisk = FALSE\ninit = NULL\ncontrol = list(knots = c(5, 10, 12))\n\nlmeFit <- lme(log(serBilir) ~ ns(year, 2), random = ~ ns(year, 2) | id, data = pbc2)\nsurvFit <- coxph(Surv(years, status2) ~ 1, data = pbc2.id, x = TRUE)\n\njointFit <- jointModel(lmeFit, survFit, timeVar = \"year\", method = \"piecewise-PH-aGH\",\n knots = c(5, 10, 12) + 1e-06)\nsummary(jointFit)\n", 3 | "created" : 1456995253260.000, 4 | "dirty" : true, 5 | "encoding" : "", 6 | "folds" : "", 7 | "hash" : "4078374684", 8 | "id" : "D80A67CC", 9 | "lastKnownWriteTime" : 7011605692497750387, 10 | "path" : null, 11 | "project_path" : null, 12 | "properties" : { 13 | "tempName" : "Untitled1" 14 | }, 15 | "relative_order" : 7, 16 | "source_on_save" : false, 17 | "type" : "r_source" 18 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/1CDB4DDC: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/1ED51FA1: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/2257E678: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/3582BADD: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/36E5C93E: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/57742131: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/66C5BD8C: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/71382EBB: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/7357ADA4: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/970E7439: -------------------------------------------------------------------------------- 1 | { 2 | "tempName" : "Untitled1" 3 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/99478E9E: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/A3AB6BAE: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/AA9B5996: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/BE84F276: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/C2A885FC: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/D5A1AB2D: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/F64CC370: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/FEA27AD7: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/650594D1/sdb/prop/INDEX: -------------------------------------------------------------------------------- 1 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FDESCRIPTION="2257E678" 2 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FNAMESPACE="BE84F276" 3 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2FcumHaz.R="99478E9E" 4 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2Ffitted.jointModel.R="71382EBB" 5 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2FjointModel.R="FEA27AD7" 6 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2Flog.posterior.b2.R="66C5BD8C" 7 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2FphGH.fit.R="3582BADD" 8 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2Fplot.jointModel.R="C2A885FC" 9 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2Fpredict.jointModel.R="AA9B5996" 10 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2Fresiduals.jointModel.R="1CDB4DDC" 11 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2FR%2FsurvfitJM.jointModel.R="F64CC370" 12 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2Finst%2FNEWS="36E5C93E" 13 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2Fman%2FJM.Rd="D5A1AB2D" 14 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJM%2Fman%2Fpbc.Rd="A3AB6BAE" 15 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FJMbayes%2FNAMESPACE="7357ADA4" 16 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FTestFiles%2FJM%2FTest.r="1ED51FA1" 17 | C%3A%2FUsers%2FDimitris%2FDocuments%2FPackagesGitHub%2FTestFiles%2FJMbayes%2FTest.r="57742131" 18 | C%3A%2FUsers%2Fdrizopoulos%2FDesktop%2Fcombine%20survfitJM%20Monte%20Carlo%20samples.R="970E7439" 19 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | 7 | # Standard to msysgit 8 | *.doc diff=astextplain 9 | *.DOC diff=astextplain 10 | *.docx diff=astextplain 11 | *.DOCX diff=astextplain 12 | *.dot diff=astextplain 13 | *.DOT diff=astextplain 14 | *.pdf diff=astextplain 15 | *.PDF diff=astextplain 16 | *.rtf diff=astextplain 17 | *.RTF diff=astextplain 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | *.history 5 | .gz 6 | src/*.o 7 | src/*.so 8 | src/*.dll -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: r 4 | cache: packages 5 | sudo: required 6 | warnings_are_errors: false 7 | 8 | r_check_args: '--as-cran --ignore-vignettes --no-examples' 9 | 10 | os: 11 | - linux 12 | - osx 13 | 14 | r: 15 | - oldrel 16 | - release 17 | - devel 18 | 19 | cran: http://cran.rstudio.com 20 | repos: 21 | CRAN: http://cran.rstudio.com 22 | 23 | r_packages: 24 | - devtools -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: JM 2 | Title: Joint Modeling of Longitudinal and Survival Data 3 | Version: 1.5-2 4 | Date: 2022-08-08 5 | Author: Dimitris Rizopoulos 6 | Maintainer: Dimitris Rizopoulos 7 | Description: Shared parameter models for the joint modeling of longitudinal and time-to-event data. 8 | Depends: R (>= 3.0.0), MASS, nlme, splines, survival 9 | Enhances: xtable 10 | LazyLoad: yes 11 | LazyData: yes 12 | License: GPL (>= 2) 13 | URL: http://jmr.r-forge.r-project.org/ 14 | -------------------------------------------------------------------------------- /JM.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 4 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Exported functions 2 | export(aucJM, anova.jointModel, coef.jointModel, crLong, dbs, dns, dynCJM, fitted.jointModel, fixef.jointModel, jointModel, 3 | ibs, ins, piecewiseExp.ph, plot.jointModel, plot.survfitJM, prederrJM, predict.jointModel, ranef.jointModel, 4 | residuals.jointModel, rocJM, simulateJM, simulate.jointModel, survfitJM, wald.strata, weibull.frailty, 5 | xtable.jointModel) 6 | 7 | # Imported functions 8 | importFrom(nlme, fixed.effects) 9 | importFrom(nlme, fixef) 10 | importFrom(nlme, random.effects) 11 | importFrom("nlme", "ranef") 12 | importFrom("survival", "survfit", "coxph", "survreg", "basehaz") 13 | importFrom("splines", "ns", "bs", "splineDesign") 14 | importFrom("MASS", "mvrnorm", "ginv") 15 | importFrom("grDevices", "dev.interactive") 16 | importFrom("graphics", "abline", "axis", "lines", "matlines", "matplot", "mtext", 17 | "panel.smooth", "par", "plot", "polygon") 18 | importFrom("stats", "AIC", "D", "IQR", "as.formula", "ave", "coef", 19 | "complete.cases", "cov", "cov2cor", "delete.response", 20 | "dnorm", "drop.terms", "fitted", "formula", "glm", 21 | "integrate", "lag", "lm.fit", "logLik", "mad", "median", 22 | "model.extract", "model.frame", "model.matrix", 23 | "model.response", "na.omit", "nlminb", "optim", "pchisq", 24 | "pnorm", "poisson", "qnorm", "qqline", "qqnorm", "quantile", 25 | "rchisq", "reformulate", "residuals", "rgamma", "rnorm", 26 | "runif", "rweibull", "sd", "terms", "uniroot", "var", 27 | "vcov", "simulate", "makepredictcall") 28 | importFrom("utils", "as.relistable", "combn", "head", "relist", "tail") 29 | 30 | 31 | # S3 methods 32 | S3method(anova, jointModel) 33 | S3method(aucJM, jointModel) 34 | S3method(aucJM, coxph) 35 | S3method(coef, jointModel) 36 | S3method(coef, summary.jointModel) 37 | S3method(coef, weibull.frailty) 38 | S3method(confint, jointModel) 39 | S3method(dynCJM, jointModel) 40 | S3method(dynCJM, coxph) 41 | S3method(fitted, jointModel) 42 | S3method(fixef, jointModel) 43 | S3method(logLik, jointModel) 44 | S3method(logLik, weibull.frailty) 45 | S3method(makepredictcall, dbs) 46 | S3method(makepredictcall, dns) 47 | S3method(makepredictcall, ibs) 48 | S3method(makepredictcall, ins) 49 | S3method(plot, jointModel) 50 | S3method(plot, rocJM) 51 | S3method(plot, survfitJM) 52 | S3method(predict, jointModel) 53 | S3method(prederrJM, jointModel) 54 | S3method(prederrJM, coxph) 55 | S3method(print, aov.jointModel) 56 | S3method(print, aucJM) 57 | S3method(print, dynCJM) 58 | S3method(print, prederrJM) 59 | S3method(print, jointModel) 60 | S3method(print, rocJM) 61 | S3method(print, summary.jointModel) 62 | S3method(print, summary.weibull.frailty) 63 | S3method(print, survfitJM) 64 | S3method(print, weibull.frailty) 65 | S3method(print, wald.strata) 66 | S3method(ranef, jointModel) 67 | S3method(residuals, jointModel) 68 | S3method(simulate, jointModel) 69 | S3method(summary, jointModel) 70 | S3method(survfitJM, jointModel) 71 | S3method(summary, weibull.frailty) 72 | S3method(vcov, jointModel) 73 | S3method(vcov, weibull.frailty) 74 | 75 | -------------------------------------------------------------------------------- /R/H.longAFTWB.R: -------------------------------------------------------------------------------- 1 | H.longAFTWB <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | eta.yxT <- as.vector(Xtime %*% betas) 5 | eta.tw <- as.vector(WW %*% gammas) 6 | if (parameterization %in% c("value", "both")) { 7 | Ys <- as.vector(Xs %*% betas) + Zsb 8 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 9 | eta.s <- Ws.intF.vl.alph * Ys 10 | } 11 | if (parameterization %in% c("slope", "both")) { 12 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 13 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 14 | eta.s <- if (parameterization == "both") 15 | eta.s + Ws.intF.sl.alph * Ys.deriv 16 | else 17 | Ws.intF.sl.alph * Ys.deriv 18 | } 19 | wk.exp.eta.s <- wk * exp(eta.s) 20 | exp.eta.tw.P <- exp(eta.tw) * P 21 | H1 <- XtX / sigma^2 22 | Vi <- exp(eta.tw) * P * rowsum(wk.exp.eta.s, id.GK, reorder = FALSE); dimnames(Vi) <- NULL 23 | Vii <- d * (sigma.t - 1) / Vi - sigma.t * Vi^(sigma.t - 1) 24 | H2 <- matrix(0, ncx, ncx) 25 | for (i in 1:ncx) { 26 | for (j in 1:ncx) { 27 | XX <- if (parameterization == "value") { 28 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 29 | } else if (parameterization == "slope") { 30 | if (i %in% indFixed && j %in% indFixed) { 31 | ii <- match(i, indFixed) 32 | jj <- match(j, indFixed) 33 | Ws.intF.sl.alph^2 * Xs.deriv[, ii] * Xs.deriv[, jj] 34 | } else 35 | 0 36 | } else { 37 | if (i %in% indFixed && j %in% indFixed) { 38 | ii <- match(i, indFixed) 39 | jj <- match(j, indFixed) 40 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 41 | (Ws.intF.vl.alph * Xs[, j] + Ws.intF.sl.alph * Xs.deriv[, jj]) 42 | } else if (i %in% indFixed && !j %in% indFixed) { 43 | ii <- match(i, indFixed) 44 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 45 | (Ws.intF.vl.alph * Xs[, j]) 46 | } else if (!i %in% indFixed && j %in% indFixed) { 47 | jj <- match(j, indFixed) 48 | (Ws.intF.vl.alph * Xs[, i]) * (Ws.intF.vl.alph * Xs[, j] + 49 | Ws.intF.sl.alph * Xs.deriv[, jj]) 50 | } else { 51 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 52 | } 53 | } 54 | ki <- Vii * exp.eta.tw.P * rowsum(wk.exp.eta.s * XX, id.GK, reorder = FALSE)#alpha * Xs[, i] 55 | kii <- c((p.byt * ki) %*% wGH) 56 | H2[i, j] <- - sum(kii, na.rm = TRUE) 57 | } 58 | } 59 | H2[lower.tri(H2)] <- t(H2)[lower.tri(H2)] 60 | H1 + H2 61 | } 62 | -------------------------------------------------------------------------------- /R/H.longPC.R: -------------------------------------------------------------------------------- 1 | H.longPC <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Ys <- as.vector(Xs %*% betas) + Zsb 6 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 7 | eta.s <- Ws.intF.vl.alph * Ys 8 | } 9 | if (parameterization %in% c("slope", "both")) { 10 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 11 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 12 | eta.s <- if (parameterization == "both") 13 | eta.s + Ws.intF.sl.alph * Ys.deriv 14 | else 15 | Ws.intF.sl.alph * Ys.deriv 16 | } 17 | exp.eta.tw <- exp(eta.tw) 18 | H1 <- XtX / sigma^2 19 | Int <- xi[ind.K] * wkP * exp(eta.s) 20 | H2 <- H1 21 | H2 <- matrix(0, ncx, ncx) 22 | for (i in 1:ncx) { 23 | for (j in i:ncx) { 24 | XX <- if (parameterization == "value") { 25 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 26 | } else if (parameterization == "slope") { 27 | if (i %in% indFixed && j %in% indFixed) { 28 | ii <- match(i, indFixed) 29 | jj <- match(j, indFixed) 30 | Ws.intF.sl.alph^2 * Xs.deriv[, ii] * Xs.deriv[, jj] 31 | } else 32 | 0 33 | } else { 34 | if (i %in% indFixed && j %in% indFixed) { 35 | ii <- match(i, indFixed) 36 | jj <- match(j, indFixed) 37 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 38 | (Ws.intF.vl.alph * Xs[, j] + Ws.intF.sl.alph * Xs.deriv[, jj]) 39 | } else if (i %in% indFixed && !j %in% indFixed) { 40 | ii <- match(i, indFixed) 41 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 42 | (Ws.intF.vl.alph * Xs[, j]) 43 | } else if (!i %in% indFixed && j %in% indFixed) { 44 | jj <- match(j, indFixed) 45 | (Ws.intF.vl.alph * Xs[, i]) * (Ws.intF.vl.alph * Xs[, j] + 46 | Ws.intF.sl.alph * Xs.deriv[, jj]) 47 | } else { 48 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 49 | } 50 | } 51 | ki <- exp.eta.tw * rowsum(Int * XX, id.GK, reorder = FALSE) 52 | kii <- c((p.byt * ki) %*% wGH) 53 | H2[i, j] <- sum(kii, na.rm = TRUE) 54 | } 55 | } 56 | H2[lower.tri(H2)] <- t(H2)[lower.tri(H2)] 57 | H1 + H2 58 | } 59 | -------------------------------------------------------------------------------- /R/H.longSplinePH.R: -------------------------------------------------------------------------------- 1 | H.longSplinePH <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Ys <- as.vector(Xs %*% betas) + Zsb 6 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 7 | eta.s <- Ws.intF.vl.alph * Ys 8 | } 9 | if (parameterization %in% c("slope", "both")) { 10 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 11 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 12 | eta.s <- if (parameterization == "both") 13 | eta.s + Ws.intF.sl.alph * Ys.deriv 14 | else 15 | Ws.intF.sl.alph * Ys.deriv 16 | } 17 | exp.eta.tw.P <- exp(eta.tw1) * P 18 | H1 <- XtX / sigma^2 19 | Int <- wk * exp(eta.ws + eta.s) #* alpha^2 20 | H2 <- matrix(0, ncx, ncx) 21 | for (i in 1:ncx) { 22 | for (j in i:ncx) { 23 | XX <- if (parameterization == "value") { 24 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 25 | } else if (parameterization == "slope") { 26 | if (i %in% indFixed && j %in% indFixed) { 27 | ii <- match(i, indFixed) 28 | jj <- match(j, indFixed) 29 | Ws.intF.sl.alph^2 * Xs.deriv[, ii] * Xs.deriv[, jj] 30 | } else 31 | 0 32 | } else { 33 | if (i %in% indFixed && j %in% indFixed) { 34 | ii <- match(i, indFixed) 35 | jj <- match(j, indFixed) 36 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 37 | (Ws.intF.vl.alph * Xs[, j] + Ws.intF.sl.alph * Xs.deriv[, jj]) 38 | } else if (i %in% indFixed && !j %in% indFixed) { 39 | ii <- match(i, indFixed) 40 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 41 | (Ws.intF.vl.alph * Xs[, j]) 42 | } else if (!i %in% indFixed && j %in% indFixed) { 43 | jj <- match(j, indFixed) 44 | (Ws.intF.vl.alph * Xs[, i]) * (Ws.intF.vl.alph * Xs[, j] + 45 | Ws.intF.sl.alph * Xs.deriv[, jj]) 46 | } else { 47 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 48 | } 49 | } 50 | ki <- exp.eta.tw.P * rowsum(Int * XX, id.GK, reorder = FALSE) 51 | ki <- rowsum(ki, idT, reorder = FALSE) 52 | kii <- c((p.byt * ki) %*% wGH) 53 | H2[i, j] <- sum(kii, na.rm = TRUE) 54 | } 55 | } 56 | H2[lower.tri(H2)] <- t(H2)[lower.tri(H2)] 57 | H1 + H2 58 | } 59 | -------------------------------------------------------------------------------- /R/H.longWB.R: -------------------------------------------------------------------------------- 1 | H.longWB <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Ys <- as.vector(Xs %*% betas) + Zsb 6 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 7 | eta.s <- Ws.intF.vl.alph * Ys 8 | } 9 | if (parameterization %in% c("slope", "both")) { 10 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 11 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 12 | eta.s <- if (parameterization == "both") 13 | eta.s + Ws.intF.sl.alph * Ys.deriv 14 | else 15 | Ws.intF.sl.alph * Ys.deriv 16 | } 17 | exp.eta.tw.P <- exp(eta.tw) * P 18 | H1 <- XtX / sigma^2 19 | Int <- wk * exp(log(sigma.t) + (sigma.t - 1) * log.st + eta.s) 20 | H2 <- matrix(0, ncx, ncx) 21 | for (i in 1:ncx) { 22 | for (j in i:ncx) { 23 | XX <- if (parameterization == "value") { 24 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 25 | } else if (parameterization == "slope") { 26 | if (i %in% indFixed && j %in% indFixed) { 27 | ii <- match(i, indFixed) 28 | jj <- match(j, indFixed) 29 | Ws.intF.sl.alph^2 * Xs.deriv[, ii] * Xs.deriv[, jj] 30 | } else 31 | 0 32 | } else { 33 | if (i %in% indFixed && j %in% indFixed) { 34 | ii <- match(i, indFixed) 35 | jj <- match(j, indFixed) 36 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 37 | (Ws.intF.vl.alph * Xs[, j] + Ws.intF.sl.alph * Xs.deriv[, jj]) 38 | } else if (i %in% indFixed && !j %in% indFixed) { 39 | ii <- match(i, indFixed) 40 | (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * Xs.deriv[, ii]) * 41 | (Ws.intF.vl.alph * Xs[, j]) 42 | } else if (!i %in% indFixed && j %in% indFixed) { 43 | jj <- match(j, indFixed) 44 | (Ws.intF.vl.alph * Xs[, i]) * (Ws.intF.vl.alph * Xs[, j] + 45 | Ws.intF.sl.alph * Xs.deriv[, jj]) 46 | } else { 47 | Ws.intF.vl.alph^2 * Xs[, i] * Xs[, j] 48 | } 49 | } 50 | ki <- exp.eta.tw.P * rowsum(Int * XX, id.GK, reorder = FALSE) 51 | kii <- c((p.byt * ki) %*% wGH) 52 | H2[i, j] <- sum(kii, na.rm = TRUE) 53 | } 54 | } 55 | H2[lower.tri(H2)] <- t(H2)[lower.tri(H2)] 56 | H1 + H2 57 | } 58 | -------------------------------------------------------------------------------- /R/HessLongPH.R: -------------------------------------------------------------------------------- 1 | HessLongPH <- 2 | function (X, Xtime, Xtime2, ew) { 3 | H1 <- - XtX / sigma^2 4 | H2 <- matrix(0, ncx, ncx) 5 | index <- which(lower.tri(H2, TRUE), arr.ind = TRUE) 6 | nn <- nrow(index) 7 | h <- numeric(nn) 8 | for (i in 1:nn) { 9 | i1 <- index[i, 1] 10 | i2 <- index[i, 2] 11 | pp <- rowsum(lambda0. * (alpha^2 * Xtime2[, i1] * Xtime2[, i2]) * ew, indT) 12 | h[i] <- - sum((pp * p.byt.) %*% wGH) 13 | } 14 | H2[lower.tri(H2, TRUE)] <- h 15 | H2 <- H2 + t(H2) 16 | diag(H2) <- diag(H2) / 2 17 | -(H1 + H2) 18 | } 19 | -------------------------------------------------------------------------------- /R/HessSurvPH.R: -------------------------------------------------------------------------------- 1 | HessSurvPH <- 2 | function (WW, Y, Y2, ew) { 3 | WY <- if (is.null(WW)) Y2 else cbind(WW[indT, , drop = FALSE], Y2) 4 | ncwy <- ncol(WY) 5 | p <- ncww + 1 6 | H <- matrix(0, p, p) 7 | index <- which(lower.tri(H, TRUE), arr.ind = TRUE) 8 | nn <- nrow(index) 9 | h <- numeric(nn) 10 | for (i in 1:nn) { 11 | i1 <- index[i, 1] 12 | if (i1 == p) 13 | i1 <- seq(p, ncwy) 14 | i2 <- index[i, 2] 15 | if (i2 == p) 16 | i2 <- seq(p, ncwy) 17 | pp <- rowsum(lambda0. * (WY[, i1] * WY[, i2]) * ew, indT) 18 | h[i] <- - sum((pp * p.byt.) %*% wGH) 19 | } 20 | H[lower.tri(H, TRUE)] <- h 21 | H <- H + t(H) 22 | diag(H) <- diag(H) / 2 23 | -H 24 | } 25 | -------------------------------------------------------------------------------- /R/LogLik.phGH.R: -------------------------------------------------------------------------------- 1 | LogLik.phGH <- 2 | function (thetas, lambda0) { 3 | betas <- thetas[1:ncx] 4 | sigma <- exp(thetas[ncx + 1]) 5 | gammas <- thetas[seq(ncx + 2, ncx + 1 + ncww)] 6 | alpha <- thetas[ncx + ncww + 2] 7 | D <- thetas[seq(ncx + ncww + 3, length(thetas))] 8 | D <- if (diag.D) exp(D) else chol.transf(D) 9 | # linear predictors 10 | eta.yx <- as.vector(X %*% betas) 11 | eta.yxT <- as.vector(Xtime %*% betas) 12 | eta.yxT2 <- as.vector(Xtime2 %*% betas) 13 | Y <- eta.yxT + Ztime.b 14 | Y2 <- eta.yxT2 + Ztime2.b 15 | eta.tw <- if (!is.null(WW)) as.vector(WW %*% gammas) else rep(0, n) 16 | eta.t <- eta.tw + alpha * Y 17 | eta.s <- alpha * Y2 18 | exp.eta.s <- exp(eta.s) 19 | mu.y <- eta.yx + Ztb 20 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 21 | log.p.yb <- rowsum(logNorm, id); dimnames(log.p.yb) <- NULL 22 | log.lambda0T <- log(lambda0[ind.T0]) 23 | log.lambda0T[is.na(log.lambda0T)] <- 0 24 | log.hazard <- log.lambda0T + eta.t 25 | S <- matrix(0, n, k) 26 | S[unq.indT, ] <- rowsum(lambda0[ind.L1] * exp.eta.s, indT, reorder = FALSE) 27 | log.survival <- - exp(eta.tw) * S 28 | log.p.tb <- d * log.hazard + log.survival 29 | log.p.b <- if (control$typeGH == "simple") { 30 | rep(dmvnorm(b, rep(0, ncz), D, TRUE), each = n) 31 | } else { 32 | matrix(dmvnorm(do.call(rbind, lis.b), rep(0, ncz), D, TRUE), n, k, byrow = TRUE) 33 | } 34 | p.ytb <- exp(log.p.yb + log.p.tb + log.p.b) 35 | if (control$typeGH != "simple") 36 | p.ytb <- p.ytb * VCdets 37 | dimnames(p.ytb) <- NULL 38 | p.yt <- c(p.ytb %*% wGH) 39 | p.byt <- p.ytb / p.yt 40 | log.p.yt <- log(p.yt) 41 | - sum(log.p.yt[is.finite(log.p.yt)], na.rm = TRUE) 42 | } 43 | -------------------------------------------------------------------------------- /R/LogLik.piecewiseGH.R: -------------------------------------------------------------------------------- 1 | LogLik.piecewiseGH <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | betas <- thetas$betas 5 | sigma <- exp(thetas$log.sigma) 6 | gammas <- thetas$gammas 7 | alpha <- thetas$alpha 8 | Dalpha <- thetas$Dalpha 9 | xi <- exp(thetas$log.xi) 10 | D <- thetas$D 11 | D <- if (diag.D) exp(D) else chol.transf(D) 12 | eta.yx <- as.vector(X %*% betas) 13 | eta.tw <- if (!is.null(WW)) as.vector(WW %*% gammas) else 0 14 | if (parameterization %in% c("value", "both")) { 15 | Y <- as.vector(Xtime %*% betas) + Ztime.b 16 | Ys <- as.vector(Xs %*% betas) + Zsb 17 | eta.t <- eta.tw + c(WintF.vl %*% alpha) * Y 18 | eta.s <- c(Ws.intF.vl %*% alpha) * Ys 19 | } 20 | if (parameterization %in% c("slope", "both")) { 21 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 22 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 23 | eta.t <- if (parameterization == "both") 24 | eta.t + c(WintF.sl %*% Dalpha) * Y.deriv 25 | else 26 | eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv 27 | eta.s <- if (parameterization == "both") 28 | eta.s + c(Ws.intF.sl %*% Dalpha) * Ys.deriv 29 | else 30 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv 31 | } 32 | mu.y <- eta.yx + Ztb 33 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 34 | log.p.yb <- rowsum(logNorm, id) 35 | log.hazard <- log(xi[ind.D]) + eta.t 36 | log.survival <- - exp(eta.tw) * rowsum(xi[ind.K] * wkP * exp(eta.s), id.GK, reorder = FALSE) 37 | dimnames(log.survival) <- NULL 38 | log.p.tb <- d * log.hazard + log.survival 39 | log.p.b <- if (control$typeGH == "simple") { 40 | rr <- dmvnorm(b, rep(0, ncz), D, TRUE) 41 | rep(rr, each = n) 42 | } else { 43 | matrix(dmvnorm(do.call(rbind, lis.b), rep(0, ncz), D, TRUE), n, k, byrow = TRUE) 44 | } 45 | p.ytb <- exp(log.p.yb + log.p.tb + log.p.b) 46 | if (control$typeGH != "simple") 47 | p.ytb <- p.ytb * VCdets 48 | dimnames(p.ytb) <- NULL 49 | p.yt <- c(p.ytb %*% wGH) 50 | log.p.yt <- log(p.yt) 51 | - sum(log.p.yt[is.finite(log.p.yt)], na.rm = TRUE) 52 | } 53 | -------------------------------------------------------------------------------- /R/LogLik.splineGH.R: -------------------------------------------------------------------------------- 1 | LogLik.splineGH <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | betas <- thetas$betas 5 | sigma <- exp(thetas$log.sigma) 6 | gammas <- thetas$gammas 7 | gammas.bs <- thetas$gammas.bs 8 | alpha <- thetas$alpha 9 | Dalpha <- thetas$Dalpha 10 | D <- thetas$D 11 | D <- if (diag.D) exp(D) else chol.transf(D) 12 | eta.yx <- as.vector(X %*% betas) 13 | eta.tw1 <- if (!is.null(W1)) as.vector(W1 %*% gammas) else rep(0, n) 14 | eta.tw2 <- as.vector(W2 %*% gammas.bs) 15 | if (parameterization %in% c("value", "both")) { 16 | Y <- as.vector(Xtime %*% betas) + Ztime.b 17 | Ys <- as.vector(Xs %*% betas) + Zsb 18 | eta.t <- eta.tw2 + eta.tw1 + c(WintF.vl %*% alpha) * Y 19 | eta.s <- c(Ws.intF.vl %*% alpha) * Ys 20 | } 21 | if (parameterization %in% c("slope", "both")) { 22 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 23 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 24 | eta.t <- if (parameterization == "both") 25 | eta.t + c(WintF.sl %*% Dalpha) * Y.deriv 26 | else 27 | eta.tw2 + eta.tw1 + c(WintF.sl %*% Dalpha) * Y.deriv 28 | eta.s <- if (parameterization == "both") 29 | eta.s + c(Ws.intF.sl %*% Dalpha) * Ys.deriv 30 | else 31 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv 32 | } 33 | eta.ws <- as.vector(W2s %*% gammas.bs) 34 | mu.y <- eta.yx + Ztb 35 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 36 | log.p.yb <- rowsum(logNorm, id) 37 | log.hazard <- eta.t 38 | log.survival <- - exp(eta.tw1) * P * rowsum(wk * exp(eta.ws + eta.s), 39 | id.GK, reorder = FALSE) 40 | dimnames(log.survival) <- NULL 41 | log.p.tb <- rowsum(d * log.hazard + log.survival, idT, reorder = FALSE) 42 | log.p.b <- if (control$typeGH == "simple") { 43 | rep(dmvnorm(b, rep(0, ncz), D, TRUE), each = n) 44 | } else { 45 | matrix(dmvnorm(do.call(rbind, lis.b), rep(0, ncz), D, TRUE), 46 | n, k, byrow = TRUE) 47 | } 48 | p.ytb <- exp(log.p.yb + log.p.tb + log.p.b) 49 | if (control$typeGH != "simple") 50 | p.ytb <- p.ytb * VCdets 51 | dimnames(p.ytb) <- NULL 52 | p.yt <- c(p.ytb %*% wGH) 53 | log.p.yt <- log(p.yt) 54 | - sum(log.p.yt[is.finite(log.p.yt)], na.rm = TRUE) 55 | } 56 | -------------------------------------------------------------------------------- /R/LogLik.weibullAFTGH.R: -------------------------------------------------------------------------------- 1 | LogLik.weibullAFTGH <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | betas <- thetas$betas 5 | sigma <- exp(thetas$log.sigma) 6 | gammas <- thetas$gammas 7 | alpha <- thetas$alpha 8 | Dalpha <- thetas$Dalpha 9 | sigma.t <- if (is.null(scaleWB)) exp(thetas$log.sigma.t) else scaleWB 10 | D <- thetas$D 11 | D <- if (diag.D) exp(D) else chol.transf(D) 12 | eta.yx <- as.vector(X %*% betas) 13 | eta.tw <- as.vector(WW %*% gammas) 14 | if (parameterization %in% c("value", "both")) { 15 | Y <- as.vector(Xtime %*% betas) + Ztime.b 16 | Ys <- as.vector(Xs %*% betas) + Zsb 17 | eta.t <- eta.tw + c(WintF.vl %*% alpha) * Y 18 | eta.s <- c(Ws.intF.vl %*% alpha) * Ys 19 | } 20 | if (parameterization %in% c("slope", "both")) { 21 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 22 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 23 | eta.t <- if (parameterization == "both") 24 | eta.t + c(WintF.sl %*% Dalpha) * Y.deriv 25 | else 26 | eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv 27 | eta.s <- if (parameterization == "both") 28 | eta.s + c(Ws.intF.sl %*% Dalpha) * Ys.deriv 29 | else 30 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv 31 | } 32 | mu.y <- eta.yx + Ztb 33 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 34 | log.p.yb <- rowsum(logNorm, id) 35 | Vi <- exp(eta.tw) * P * rowsum(wk * exp(eta.s), id.GK, reorder = FALSE); dimnames(Vi) <- NULL 36 | log.hazard <- log(sigma.t) + (sigma.t - 1) * log(Vi) + eta.t 37 | log.survival <- - Vi^sigma.t 38 | log.p.tb <- d * log.hazard + log.survival 39 | log.p.b <- if (control$typeGH == "simple") { 40 | rep(dmvnorm(b, rep(0, ncz), D, TRUE), each = n) 41 | } else { 42 | matrix(dmvnorm(do.call(rbind, lis.b), rep(0, ncz), D, TRUE), n, k, byrow = TRUE) 43 | } 44 | p.ytb <- exp(log.p.yb + log.p.tb + log.p.b) 45 | if (control$typeGH != "simple") 46 | p.ytb <- p.ytb * VCdets 47 | dimnames(p.ytb) <- NULL 48 | p.yt <- c(p.ytb %*% wGH) 49 | log.p.yt <- log(p.yt) 50 | - sum(log.p.yt[is.finite(log.p.yt)], na.rm = TRUE) 51 | } 52 | -------------------------------------------------------------------------------- /R/LogLik.weibullGH.R: -------------------------------------------------------------------------------- 1 | LogLik.weibullGH <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | betas <- thetas$betas 5 | sigma <- exp(thetas$log.sigma) 6 | gammas <- thetas$gammas 7 | alpha <- thetas$alpha 8 | Dalpha <- thetas$Dalpha 9 | sigma.t <- if (is.null(scaleWB)) exp(thetas$log.sigma.t) else scaleWB 10 | D <- thetas$D 11 | D <- if (diag.D) exp(D) else chol.transf(D) 12 | eta.yx <- as.vector(X %*% betas) 13 | eta.tw <- as.vector(WW %*% gammas) 14 | if (parameterization %in% c("value", "both")) { 15 | Y <- as.vector(Xtime %*% betas) + Ztime.b 16 | Ys <- as.vector(Xs %*% betas) + Zsb 17 | eta.t <- eta.tw + c(WintF.vl %*% alpha) * Y 18 | eta.s <- c(Ws.intF.vl %*% alpha) * Ys 19 | } 20 | if (parameterization %in% c("slope", "both")) { 21 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 22 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 23 | eta.t <- if (parameterization == "both") 24 | eta.t + c(WintF.sl %*% Dalpha) * Y.deriv 25 | else 26 | eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv 27 | eta.s <- if (parameterization == "both") 28 | eta.s + c(Ws.intF.sl %*% Dalpha) * Ys.deriv 29 | else 30 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv 31 | } 32 | mu.y <- eta.yx + Ztb 33 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 34 | log.p.yb <- rowsum(logNorm, id) 35 | log.hazard <- log(sigma.t) + (sigma.t - 1) * logT + eta.t 36 | log.survival <- - exp(eta.tw) * P * rowsum(wk * exp(log(sigma.t) + (sigma.t - 1) * 37 | log.st + eta.s), id.GK, reorder = FALSE) 38 | dimnames(log.survival) <- NULL 39 | log.p.tb <- d * log.hazard + log.survival 40 | log.p.b <- if (control$typeGH == "simple") { 41 | rep(dmvnorm(b, rep(0, ncz), D, TRUE), each = n) 42 | } else { 43 | matrix(dmvnorm(do.call(rbind, lis.b), rep(0, ncz), D, TRUE), n, k, byrow = TRUE) 44 | } 45 | p.ytb <- exp(log.p.yb + log.p.tb + log.p.b) 46 | if (control$typeGH != "simple") 47 | p.ytb <- p.ytb * VCdets 48 | dimnames(p.ytb) <- NULL 49 | p.yt <- c(p.ytb %*% wGH) 50 | log.p.yt <- log(p.yt) 51 | - sum(log.p.yt[is.finite(log.p.yt)], na.rm = TRUE) 52 | } 53 | -------------------------------------------------------------------------------- /R/ModelMats.R: -------------------------------------------------------------------------------- 1 | ModelMats <- 2 | function (time, ii, obs.times, survTimes) { 3 | if (method %in% c("weibull-AFT-GH", "weibull-PH-GH", 4 | "spline-PH-GH", "spline-PH-Laplace")) { 5 | id.GK <- if (!LongFormat) { 6 | rep(ii, each = object$control$GKk) 7 | } else { 8 | rep(which(idT == ii), each = object$control$GKk) 9 | } 10 | wk <- gaussKronrod(object$control$GKk)$wk 11 | sk <- gaussKronrod(object$control$GKk)$sk 12 | if (!LongFormat) { 13 | P <- time / 2 14 | st <- P * (sk + 1) 15 | } else { 16 | time0 <- obs.times[[ii]] 17 | time1 <- c(time0[-1], time) 18 | P <- (time1 - time0) / 2 19 | P1 <- (time1 + time0) / 2 20 | st <- outer(P, sk) + P1 21 | st <- c(t(st)) 22 | } 23 | data.id2 <- data.id[id.GK, ] 24 | data.id2[[timeVar]] <- pmax(st - lag, 0) 25 | out <- list(st = st, wk = rep(wk, length(P)), P = P) 26 | if (parameterization %in% c("value", "both")) { 27 | mfX <- model.frame(delete.response(TermsX), data = data.id2) 28 | mfZ <- model.frame(TermsZ, data = data.id2) 29 | out$Xs <- model.matrix(formYx, mfX) 30 | out$Zs <- model.matrix(formYz, mfZ) 31 | out$Ws.intF.vl <- WintF.vl[id.GK, , drop = FALSE] 32 | } 33 | if (parameterization %in% c("slope", "both")) { 34 | mfX.deriv <- model.frame(TermsX.deriv, data = data.id2) 35 | mfZ.deriv <- model.frame(TermsZ.deriv, data = data.id2) 36 | out$Xs.deriv <- model.matrix(derivForm$fixed, mfX.deriv) 37 | out$Zs.deriv <- model.matrix(derivForm$random, mfZ.deriv) 38 | out$Ws.intF.sl <- WintF.sl[id.GK, , drop = FALSE] 39 | } 40 | } 41 | if (method == "piecewise-PH-GH") { 42 | wk <- gaussKronrod(7)$wk 43 | sk <- gaussKronrod(7)$sk 44 | nk <- length(sk) 45 | qs <- c(0, sort(object$control$knots), 46 | max(survTimes, object$control$knots) + 1) 47 | ind <- findInterval(time, qs, rightmost.closed = TRUE) 48 | Tiq <- outer(time, qs, pmin) 49 | Lo <- Tiq[, 1:Q] 50 | Up <- Tiq[, 2:(Q+1)] 51 | T <- Up - Lo 52 | P <- T / 2 53 | if (!all(P < sqrt(.Machine$double.eps))) 54 | P[P < sqrt(.Machine$double.eps)] <- as.numeric(NA) 55 | P1 <- (Up + Lo) / 2 56 | st <- rep(P, each = nk) * rep(sk, Q) + rep(P1, each = nk) 57 | data.id2 <- data.id[rep(ii, each = nk*Q), ] 58 | data.id2[[timeVar]] <- pmax(st - lag, 0) 59 | data.id2 <- data.id2[!is.na(st), ] 60 | id.GK <- rep(ii, sum(!is.na(st))) 61 | out <- list(st = st, wk = wk, P = P, ind = ind) 62 | if (parameterization %in% c("value", "both")) { 63 | mfX <- model.frame(TermsX, data = data.id2) 64 | mfZ <- model.frame(TermsZ, data = data.id2) 65 | out$Xs <- model.matrix(formYx, mfX) 66 | out$Zs <- model.matrix(object$formYz, mfZ) 67 | out$Ws.intF.vl <- WintF.vl[id.GK, , drop = FALSE] 68 | } 69 | if (parameterization %in% c("slope", "both")) { 70 | mfX.deriv <- model.frame(TermsX.deriv, data = data.id2) 71 | mfZ.deriv <- model.frame(TermsZ.deriv, data = data.id2) 72 | out$Xs.deriv <- model.matrix(derivForm$fixed, mfX.deriv) 73 | out$Zs.deriv <- model.matrix(derivForm$random, mfZ.deriv) 74 | out$Ws.intF.sl <- WintF.sl[id.GK, , drop = FALSE] 75 | } 76 | } 77 | out 78 | } 79 | -------------------------------------------------------------------------------- /R/S.b.R: -------------------------------------------------------------------------------- 1 | S.b <- 2 | function (t, b, ii, Mats) { 3 | if (t == 0) 4 | return(1) 5 | idT.i <- idT %in% ii 6 | st <- Mats$st 7 | wk <- Mats$wk 8 | P <- Mats$P 9 | Xs <- Mats$Xs 10 | Zs <- Mats$Zs 11 | Xs.deriv <- Mats$Xs.deriv 12 | Zs.deriv <- Mats$Zs.deriv 13 | Ws.intF.vl <- Mats$Ws.intF.vl 14 | Ws.intF.sl <- Mats$Ws.intF.sl 15 | ind <- Mats$ind 16 | if (parameterization %in% c("value", "both")) 17 | Ys <- as.vector(Xs %*% betas.new + rowSums(Zs * rep(b, each = nrow(Zs)))) 18 | if (parameterization %in% c("slope", "both")) 19 | Ys.deriv <- as.vector(Xs.deriv %*% betas.new[indFixed]) + 20 | rowSums(Zs.deriv * rep(b[indRandom], each = nrow(Zs))) 21 | tt <- switch(parameterization, 22 | "value" = c(Ws.intF.vl %*% alpha.new) * Ys, 23 | "slope" = c(Ws.intF.sl %*% Dalpha.new) * Ys.deriv, 24 | "both" = c(Ws.intF.vl %*% alpha.new) * Ys + 25 | c(Ws.intF.sl %*% Dalpha.new) * Ys.deriv) 26 | eta.tw <- if (!is.null(W)) { 27 | if (!LongFormat) 28 | as.vector(W[ii, , drop = FALSE] %*% gammas.new) 29 | else 30 | as.vector(W[idT.i %in% ii, , drop = FALSE] %*% gammas.new) 31 | } else 0 32 | log.survival <- if (method == "weibull-PH-GH") { 33 | Vi <- exp(log(sigma.t.new) + (sigma.t.new - 1) * log(st) + tt) 34 | - exp(eta.tw) * P * sum(wk * Vi) 35 | } else if (method == "weibull-AFT-GH") { 36 | Vi <- exp(eta.tw) * P * sum(wk * exp(tt)) 37 | - Vi^sigma.t.new 38 | } else if (method == "spline-PH-GH") { 39 | W2s <- if (length(kn <- object$control$knots) == 1) { 40 | splineDesign(unlist(kn, use.names = FALSE), st, ord = object$control$ord, outer.ok = TRUE) 41 | } else { 42 | strt.i <- strt[ii] 43 | w2s <- lapply(kn, function (kn) splineDesign(kn, st, ord = object$control$ord, outer.ok = TRUE)) 44 | ll <- match(strt.i, names(w2s)) 45 | w2s[-ll] <- lapply(w2s[-ll], function (m) {m[, ] <- 0; m}) 46 | do.call(cbind, w2s) 47 | } 48 | Vi <- exp(c(W2s %*% gammas.bs.new) + tt) 49 | idT <- rep(seq_along(P), each = object$control$GKk) 50 | - sum(exp(eta.tw) * P * tapply(wk * Vi, idT, sum)) 51 | } else if (method == "piecewise-PH-GH") { 52 | P <- P[!is.na(P)] 53 | ind.K <- rep(seq_len(ind), each = 7) 54 | wk <- rep(wk, ind) 55 | wkP <- wk * rep(P, each = 7) 56 | eta.tw <- if (!is.null(W)) as.vector(W[i, , drop = FALSE] %*% gammas.new) else 0 57 | - exp(eta.tw) * sum(xi.new[ind.K] * wkP * exp(tt)) 58 | } 59 | exp(log.survival) 60 | } 61 | -------------------------------------------------------------------------------- /R/aucJM.R: -------------------------------------------------------------------------------- 1 | aucJM <- 2 | function (object, newdata, Tstart, ...) { 3 | UseMethod("aucJM") 4 | } 5 | -------------------------------------------------------------------------------- /R/cd.R: -------------------------------------------------------------------------------- 1 | cd <- 2 | function (x, f, ..., eps = 1e-03) { 3 | n <- length(x) 4 | res <- numeric(n) 5 | ex <- pmax(abs(x), 1) 6 | for (i in 1:n) { 7 | x1 <- x2 <- x 8 | x1[i] <- x[i] + eps * ex[i] 9 | x2[i] <- x[i] - eps * ex[i] 10 | diff.f <- c(f(x1, ...) - f(x2, ...)) 11 | diff.x <- x1[i] - x2[i] 12 | res[i] <- diff.f / diff.x 13 | } 14 | res 15 | } 16 | -------------------------------------------------------------------------------- /R/cd.vec.R: -------------------------------------------------------------------------------- 1 | cd.vec <- 2 | function (x, f, ..., eps = 1e-03) { 3 | n <- length(x) 4 | res <- matrix(0, n, n) 5 | ex <- pmax(abs(x), 1) 6 | for (i in 1:n) { 7 | x1 <- x2 <- x 8 | x1[i] <- x[i] + eps * ex[i] 9 | x2[i] <- x[i] - eps * ex[i] 10 | diff.f <- c(f(x1, ...) - f(x2, ...)) 11 | diff.x <- x1[i] - x2[i] 12 | res[, i] <- diff.f / diff.x 13 | } 14 | 0.5 * (res + t(res)) 15 | } 16 | -------------------------------------------------------------------------------- /R/chol.transf.R: -------------------------------------------------------------------------------- 1 | chol.transf <- 2 | function (x) { 3 | if (any(is.na(x) | !is.finite(x))) 4 | stop("NA or infinite values in 'x'.\n") 5 | if (is.matrix(x)) { 6 | k <- nrow(x) 7 | U <- chol(x) 8 | U[cbind(1:k, 1:k)] <- log(U[cbind(1:k, 1:k)]) 9 | U[upper.tri(U, TRUE)] 10 | } else { 11 | nx <- length(x) 12 | k <- round((- 1 + sqrt(1 + 8 * nx)) / 2) 13 | mat <- matrix(0, k, k) 14 | mat[upper.tri(mat, TRUE)] <- x 15 | mat[cbind(1:k, 1:k)] <- exp(mat[cbind(1:k, 1:k)]) 16 | res <- crossprod(mat) 17 | attr(res, "L") <- t(mat)[lower.tri(mat, TRUE)] 18 | res 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /R/coef.flexCPH.R: -------------------------------------------------------------------------------- 1 | coef.flexCPH <- 2 | function (object, include.splineCoefs = FALSE, ...) { 3 | if (include.splineCoefs) unlist(object$coefficients) else object$coefficients$betas 4 | } 5 | -------------------------------------------------------------------------------- /R/coef.jointModel.R: -------------------------------------------------------------------------------- 1 | coef.jointModel <- 2 | function (object, process = c("Longitudinal", "Event"), include.splineCoefs = FALSE, ...) { 3 | if (!inherits(object, "jointModel")) 4 | stop("Use only with 'jointModel' objects.\n") 5 | process <- match.arg(process) 6 | if (process == "Longitudinal") { 7 | betas <- object$coefficients$betas 8 | out <- matrix(betas, nrow = object$n, ncol = length(betas), byrow = TRUE) 9 | colnames(out) <- names(betas) 10 | if (!object$CompRisk && !object$LongFormat) 11 | rownames(out) <- names(object$y$logT) 12 | EB <- object$EB$post.b 13 | out[, colnames(EB)] <- out[, colnames(EB)] + EB 14 | out 15 | } else { 16 | gammas <- object$coefficients$gammas 17 | if (object$method %in% c("ch-GH", "ch-Laplace") && !include.splineCoefs) { 18 | ng <- length(gammas) 19 | nw <- ncol(object$x$W) 20 | gammas <- if (is.null(nw)) NULL else gammas[seq(ng - nw + 1, ng)] 21 | } 22 | out <- c(gammas, "Assoct" = as.vector(object$coefficients$alpha), 23 | "Assoct.s" = as.vector(object$coefficients$Dalpha)) 24 | if (object$method == "weibull-AFT-GH") 25 | out <- - out 26 | jj <- grep("Assoct[!^\\.s]", names(out)) 27 | ii <- setdiff(grep("Assoct", names(out)), jj) 28 | if (length(ii) > 1) { 29 | nn <- names(object$coefficients$alpha) 30 | names(out)[ii] <- if (length(nn) == 1) "Assoct" else { 31 | if (nn[1] == "") 32 | c("Assoct", paste("Assoct", nn[-1], sep = ":")) 33 | else 34 | paste("Assoct", nn, sep = ":") 35 | } 36 | } 37 | if (length(jj) > 1) { 38 | nn <- names(object$coefficients$Dalpha) 39 | names(out)[jj] <- if (length(nn) == 1) "Assoct.s" else { 40 | if (nn[1] == "") 41 | c("Assoct.s", paste("Assoct.s", nn[-1], sep = ":")) 42 | else 43 | paste("Assoct.s", nn, sep = ":") 44 | } 45 | } 46 | if ((lag <- object$y$lag) > 0) { 47 | kk <- grep("Assoct", names(out), fixed = TRUE) 48 | names(out)[kk] <- paste(names(out)[kk], "(lag=", lag, ")", sep = "") 49 | } 50 | out 51 | } 52 | } 53 | -------------------------------------------------------------------------------- /R/coef.summary.jointModel.R: -------------------------------------------------------------------------------- 1 | coef.summary.jointModel <- 2 | function (object, ...) { 3 | if (!inherits(object, "summary.jointModel")) 4 | stop("Use only with 'summary.jointModel' objects.\n") 5 | coefsY <- object$'CoefTable-Long' 6 | coefsT <- object$'CoefTable-Event' 7 | list("Longitudinal" = coefsY, "Event" = coefsT) 8 | } 9 | -------------------------------------------------------------------------------- /R/coef.weibull.frailty.R: -------------------------------------------------------------------------------- 1 | coef.weibull.frailty <- 2 | function (object, ...) { 3 | object$coefficients$betas 4 | } 5 | -------------------------------------------------------------------------------- /R/confint.jointModel.R: -------------------------------------------------------------------------------- 1 | confint.jointModel <- 2 | function (object, parm = c("all", "Longitudinal", "Event"), level = 0.95, ...) { 3 | if (!inherits(object, "jointModel")) 4 | stop("Use only with 'jointModel' objects.\n") 5 | parm <- match.arg(parm) 6 | cf <- switch(parm, 7 | "Longitudinal" = fixef(object), 8 | "Event" = fixef(object, "Event"), 9 | "all" = { 10 | cy <- fixef(object) 11 | names(cy) <- paste("Y.", names(cy), sep = "") 12 | ct <- fixef(object, "Event") 13 | names(ct) <- paste("T.", names(ct), sep = "") 14 | c(cy, ct) 15 | }) 16 | pnames <- names(cf) 17 | a <- (1 - level)/2 18 | a <- c(a, 1 - a) 19 | pct <- format.perc2(a, 3) 20 | fac <- qnorm(a) 21 | ci <- array(NA, dim = c(length(cf), 3L), dimnames = list(names(cf), 22 | c(pct[1], "est.", pct[2]))) 23 | ses <- sqrt(diag(vcov(object))) 24 | ii <- switch(parm, 25 | "Longitudinal" = grep("Y.", names(ses), fixed = TRUE)[seq_along(cf)], 26 | "Event" = grep("T.", names(ses), fixed = TRUE)[seq_along(cf)], 27 | "all" = { 28 | iy <- grep("Y.", names(ses), fixed = TRUE) 29 | it <- grep("T.", names(ses), fixed = TRUE) 30 | c(iy[-length(iy)], it[seq(1, length(cf) - length(iy) + 1)]) 31 | } 32 | ) 33 | ses <- ses[ii] 34 | ci[, c(1,3)] <- cf + ses %o% fac 35 | ci[, 2] <- cf 36 | ci 37 | } 38 | -------------------------------------------------------------------------------- /R/crLong.R: -------------------------------------------------------------------------------- 1 | crLong <- 2 | function (data, statusVar, censLevel, 3 | nameStrata = "strata", nameStatus = "status2") { 4 | n <- nrow(data) 5 | status <- data[[statusVar]] 6 | unqLevs <- unique(status) 7 | unqLevs <- unqLevs[unqLevs != censLevel] 8 | ncr <- length(unqLevs) 9 | dataOut <- data[rep(seq_len(n), each = ncr), ] 10 | dataOut[[nameStrata]] <- rep(unqLevs, n) 11 | dataOut[[nameStatus]] <- as.numeric(dataOut[[statusVar]] == dataOut[[nameStrata]]) 12 | dataOut[[nameStrata]] <- factor(dataOut[[nameStrata]]) 13 | dataOut 14 | } 15 | -------------------------------------------------------------------------------- /R/dataLM.R: -------------------------------------------------------------------------------- 1 | dataLM <- 2 | function (data, Tstart, idVar = "id", respVar = "y", timeVar = "time", evTimeVar = "Time", 3 | summary = c("value", "slope", "area"), tranfFun = function (x) x) { 4 | if (!is.data.frame(data) || nrow(data) == 0) 5 | stop("'data' must be a data.frame with more than one rows.\n") 6 | if (is.null(data[[idVar]])) 7 | stop("'idVar' not in 'data'.\n") 8 | if (is.null(data[[respVar]])) 9 | stop("'respVar' not in 'data'.\n") 10 | if (is.null(data[[timeVar]])) 11 | stop("'timeVar' not in 'data'.\n") 12 | if (is.null(data[[evTimeVar]])) 13 | stop("'evTimeVar' not in 'data'.\n") 14 | summary <- match.arg(summary) 15 | time <- data[[timeVar]] 16 | Time <- data[[evTimeVar]] 17 | ND <- data[Time > Tstart & time <= Tstart, ] 18 | f <- factor(ND[[idVar]], unique(ND[[idVar]])) 19 | if (summary == "value") { 20 | ND[tapply(row.names(ND), f, tail, 1), ] 21 | } else if (summary == "slope") { 22 | do.call(rbind, lapply(split(ND, f), function (d) { 23 | d <- tail(d, 2) 24 | d$slope <- if (nrow(d) == 1) 0 else diff(tranfFun(d[[respVar]])) / diff(d[[timeVar]]) 25 | tail(d, 1) 26 | })) 27 | } else { 28 | do.call(rbind, lapply(split(ND, f), function (d) { 29 | if (d[[timeVar]][1] != 0) 30 | d[[timeVar]][1] <- 0 31 | y <- tranfFun(d[[respVar]]) 32 | t <- c(d[[timeVar]], Tstart) 33 | d$area <- sum(diff(t) * y) 34 | tail(d, 1) 35 | })) 36 | 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /R/dbs.R: -------------------------------------------------------------------------------- 1 | dbs <- 2 | function (x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = range(x), eps = 1e-03) { 3 | bs.x <- if (is.null(knots)) { 4 | bs(x, df = df, intercept = intercept, Boundary.knots = Boundary.knots) 5 | } else { 6 | bs(x, knots = knots, intercept = intercept, Boundary.knots = Boundary.knots) 7 | } 8 | kn <- attr(bs.x, "knots") 9 | Bkn <- attr(bs.x, "Boundary.knots") 10 | ex <- pmax(abs(x), 1) 11 | x1 <- x + eps * ex 12 | x2 <- x - eps * ex 13 | bs.xeps1 <- suppressWarnings(bs(x1, knots = kn, Boundary.knots = Bkn, intercept = intercept)) 14 | bs.xeps2 <- suppressWarnings(bs(x2, knots = kn, Boundary.knots = Bkn, intercept = intercept)) 15 | out <- (bs.xeps1 - bs.xeps2) / c(x1 - x2) 16 | attr(out, "eps") <- eps 17 | attr(out, "class") <- c("dbs", "basis", "matrix") 18 | out 19 | } 20 | -------------------------------------------------------------------------------- /R/deriv.D.R: -------------------------------------------------------------------------------- 1 | deriv.D <- 2 | function (D) { 3 | ncz <- nrow(D) 4 | ind <- which(lower.tri(D, TRUE), arr.ind = TRUE) 5 | dimnames(ind) <- NULL 6 | nind <- nrow(ind) 7 | svD <- solve(D) 8 | lapply(1:nind, function (x, ind) { 9 | mat <- matrix(0, ncz, ncz) 10 | ii <- ind[x, , drop = FALSE] 11 | mat[ii[1], ii[2]] <- mat[ii[2], ii[1]] <- 1 12 | mat 13 | }, ind = ind[, 2:1]) 14 | } 15 | -------------------------------------------------------------------------------- /R/dmvnorm.R: -------------------------------------------------------------------------------- 1 | dmvnorm <- 2 | function (x, mu, Sigma, log = FALSE) { 3 | if (!is.matrix(x)) 4 | x <- rbind(x) 5 | p <- length(mu) 6 | if (p == 1) { 7 | dnorm(x, mu, sqrt(Sigma), log = log) 8 | } else { 9 | t1 <- length(mu) == length(Sigma) 10 | t2 <- all(abs(Sigma[lower.tri(Sigma)]) < sqrt(.Machine$double.eps)) 11 | if (t1 || t2) { 12 | if (!t1) 13 | Sigma <- diag(Sigma) 14 | nx <- nrow(x) 15 | ff <- rowSums(dnorm(x, rep(mu, each = nx), 16 | sd = rep(sqrt(Sigma), each = nx), log = TRUE)) 17 | if (log) ff else exp(ff) 18 | } else { 19 | ed <- eigen(Sigma, symmetric = TRUE) 20 | ev <- ed$values 21 | evec <- ed$vectors 22 | if (!all(ev >= -1e-06 * abs(ev[1]))) 23 | stop("'Sigma' is not positive definite") 24 | ss <- x - rep(mu, each = nrow(x)) 25 | inv.Sigma <- evec %*% (t(evec) / ev) 26 | quad <- 0.5 * rowSums((ss %*% inv.Sigma) * ss) 27 | fact <- - 0.5 * (p * log(2 * pi) + sum(log(ev))) 28 | if (log) 29 | as.vector(fact - quad) 30 | else 31 | as.vector(exp(fact - quad)) 32 | } 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /R/dmvt.R: -------------------------------------------------------------------------------- 1 | dmvt <- 2 | function (x, mu, Sigma, df, log = FALSE) { 3 | if (!is.numeric(x)) 4 | stop("'x' must be a numeric matrix or vector") 5 | if (!is.matrix(x)) 6 | x <- rbind(x) 7 | p <- length(mu) 8 | if (!all(dim(Sigma) == c(p, p)) || ncol(x) != p) 9 | stop("incompatible arguments") 10 | ed <- eigen(Sigma, symmetric = TRUE) 11 | ev <- ed$values 12 | if (!all(ev >= -1e-06 * abs(ev[1]))) 13 | stop("'Sigma' is not positive definite") 14 | ss <- x - rep(mu, each = nrow(x)) 15 | inv.Sigma <- ed$vectors %*% (t(ed$vectors) / ev) 16 | quad <- rowSums((ss %*% inv.Sigma) * ss) / df 17 | fact <- lgamma((df + p)/2) - lgamma(df/2) - 0.5 * (p * (log(pi) + log(df)) + sum(log(ev))) 18 | if (log) 19 | fact - 0.5 * (df + p) * log(1 + quad) 20 | else 21 | exp(fact) * ((1 + quad)^(- (df + p)/2)) 22 | } 23 | -------------------------------------------------------------------------------- /R/dns.R: -------------------------------------------------------------------------------- 1 | dns <- 2 | function (x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = range(x), eps = 1e-03) { 3 | ns.x <- if (is.null(knots)) { 4 | ns(x, df = df, intercept = intercept, Boundary.knots = Boundary.knots) 5 | } else { 6 | ns(x, knots = knots, intercept = intercept, Boundary.knots = Boundary.knots) 7 | } 8 | kn <- attr(ns.x, "knots") 9 | Bkn <- attr(ns.x, "Boundary.knots") 10 | ex <- pmax(abs(x), 1) 11 | x1 <- x + eps * ex 12 | x2 <- x - eps * ex 13 | ns.xeps1 <- ns(x1, knots = kn, Boundary.knots = Bkn, intercept = intercept) 14 | ns.xeps2 <- ns(x2, knots = kn, Boundary.knots = Bkn, intercept = intercept) 15 | out <- (ns.xeps1 - ns.xeps2) / c(x1 - x2) 16 | attr(out, "eps") <- eps 17 | attr(out, "class") <- c("dns", "basis", "matrix") 18 | out 19 | } 20 | -------------------------------------------------------------------------------- /R/dropAttr.R: -------------------------------------------------------------------------------- 1 | dropAttr <- 2 | function (mat) { 3 | d <- dim(mat) 4 | mat <- as.vector(mat) 5 | dim(mat) <- d 6 | mat 7 | } 8 | -------------------------------------------------------------------------------- /R/dynCJM.R: -------------------------------------------------------------------------------- 1 | dynCJM <- 2 | function (object, newdata, Dt, ...) { 3 | UseMethod("dynCJM") 4 | } 5 | -------------------------------------------------------------------------------- /R/dynCJM.coxph.R: -------------------------------------------------------------------------------- 1 | dynCJM.coxph <- 2 | function (object, newdata, Dt, idVar = "id", t.max = NULL, timeVar = "time", 3 | weightFun = NULL, respVar = "y", evTimeVar = "Time", 4 | summary = c("value", "slope", "area"), tranfFun = function (x) x, ...) { 5 | if (!inherits(object, "coxph")) 6 | stop("Use only with 'coxph' objects.\n") 7 | if (!is.data.frame(newdata) || nrow(newdata) == 0) 8 | stop("'newdata' must be a data.frame with more than one rows.\n") 9 | if (is.null(newdata[[idVar]])) 10 | stop("'idVar' not in 'newdata.\n'") 11 | if (!is.numeric(Dt) && length(Dt) > 1) 12 | stop("'Dt' must be a numeric scalar.\n") 13 | if (!is.null(weightFun) && !is.function(weightFun)) 14 | stop("'weightFun' must be a function.\n") 15 | newdata$area <- newdata$slope <- 0 16 | TermsT <- object$terms 17 | SurvT <- model.response(model.frame(TermsT, newdata)) 18 | Time <- SurvT[, 1] 19 | event <- SurvT[, 2] 20 | if (is.null(t.max) || !is.numeric(t.max) || length(t.max) > 1) 21 | t.max <- max(Time) + 1e-05 22 | wk <- gaussKronrod()$wk 23 | sk <- gaussKronrod()$sk 24 | P <- t.max / 2 25 | st <- P * (sk + 1) 26 | k <- length(st) 27 | auc.st <- numeric(k) 28 | form <- as.formula(paste(as.character(formula(object))[c(2,1,3)], collapse = " ")) 29 | old <- options(warn = (2)) 30 | on.exit(options(old)) 31 | for (i in 1:k) { 32 | tt <- try({ 33 | #data.i <- newdata[Time > st[i] & newdata[[timeVar]] <= st[i], ] 34 | #f <- factor(data.i[[idVar]], unique(data.i[[idVar]])) 35 | #data.i <- data.i[tapply(row.names(data.i), f, tail, 1), ] 36 | data.i <- dataLM(newdata, Tstart = st[i], idVar, respVar, timeVar, evTimeVar, 37 | summary, tranfFun) 38 | object.i <- coxph(form, data = data.i) 39 | aucJM(object.i, newdata = newdata, Tstart = st[i], 40 | Dt = Dt, timeVar = timeVar, idVar = idVar, 41 | respVar = respVar, evTimeVar = evTimeVar, 42 | summary = summary, tranfFun = tranfFun)$auc 43 | }, TRUE) 44 | auc.st[i] <- if (!inherits(tt, "try-error")) tt else NA 45 | } 46 | if (is.null(weightFun)) { 47 | weightFun <- function (t, Dt) { 48 | sfit <- survfit(Surv(Time, event) ~ 1) 49 | S.t <- summary(sfit, times = t)$surv 50 | S.tdt <- summary(sfit, times = t + Dt)$surv 51 | r <- (S.t - S.tdt) * S.tdt 52 | if (length(r)) r else NA 53 | } 54 | } 55 | w.st <- sapply(st, function (t) weightFun(t, Dt)) 56 | dynC <- sum(wk * auc.st * w.st, na.rm = TRUE) / sum(wk * w.st, na.rm = TRUE) 57 | out <- list(dynC = dynC, times = st, AUCs = auc.st, weights = w.st, t.max = t.max, Dt = Dt, 58 | classObject = class(object), nameObject = deparse(substitute(object))) 59 | class(out) <- "dynCJM" 60 | out 61 | } 62 | -------------------------------------------------------------------------------- /R/dynCJM.jointModel.R: -------------------------------------------------------------------------------- 1 | dynCJM.jointModel <- 2 | function (object, newdata, Dt, idVar = "id", t.max = NULL, simulate = FALSE, M = 100, 3 | weightFun = NULL, ...) { 4 | if (!inherits(object, "jointModel")) 5 | stop("Use only with 'jointModel' objects.\n") 6 | if (!is.data.frame(newdata) || nrow(newdata) == 0) 7 | stop("'newdata' must be a data.frame with more than one rows.\n") 8 | if (is.null(newdata[[idVar]])) 9 | stop("'idVar' not in 'newdata.\n'") 10 | if (!is.numeric(Dt) && length(Dt) > 1) 11 | stop("'Dt' must be a numeric scalar.\n") 12 | if (!is.null(weightFun) && !is.function(weightFun)) 13 | stop("'weightFun' must be a function.\n") 14 | TermsT <- object$termsT 15 | SurvT <- model.response(model.frame(TermsT, newdata)) 16 | Time <- SurvT[, 1] 17 | event <- SurvT[, 2] 18 | if (is.null(t.max) || !is.numeric(t.max) || length(t.max) > 1) 19 | t.max <- max(Time) + 1e-05 20 | wk <- gaussKronrod()$wk 21 | sk <- gaussKronrod()$sk 22 | P <- t.max / 2 23 | st <- P * (sk + 1) 24 | auc.st <- sapply(st, function (t) 25 | aucJM(object, newdata = newdata, Tstart = t, Dt = Dt, idVar = idVar, simulate = simulate, M = M)$auc) 26 | if (is.null(weightFun)) { 27 | weightFun <- function (t, Dt) { 28 | sfit <- survfit(Surv(Time, event) ~ 1) 29 | S.t <- summary(sfit, times = t)$surv 30 | S.tdt <- summary(sfit, times = t + Dt)$surv 31 | r <- (S.t - S.tdt) * S.tdt 32 | if (length(r)) r else NA 33 | } 34 | } 35 | w.st <- sapply(st, function (t) weightFun(t, Dt)) 36 | dynC <- sum(wk * auc.st * w.st, na.rm = TRUE) / sum(wk * w.st, na.rm = TRUE) 37 | out <- list(dynC = dynC, times = st, AUCs = auc.st, weights = w.st, t.max = t.max, Dt = Dt, 38 | classObject = class(object), nameObject = deparse(substitute(object))) 39 | class(out) <- "dynCJM" 40 | out 41 | } 42 | -------------------------------------------------------------------------------- /R/fd.vec.R: -------------------------------------------------------------------------------- 1 | fd.vec <- 2 | function (x, f, ..., eps = 1e-05) { 3 | n <- length(x) 4 | res <- matrix(0, n, n) 5 | ex <- pmax(abs(x), 1) 6 | f0 <- f(x, ...) 7 | for (i in 1:n) { 8 | x1 <- x 9 | x1[i] <- x[i] + eps * ex[i] 10 | diff.f <- c(f(x1, ...) - f0) 11 | diff.x <- x1[i] - x[i] 12 | res[, i] <- diff.f / diff.x 13 | } 14 | 0.5 * (res + t(res)) 15 | } 16 | -------------------------------------------------------------------------------- /R/fixef.jointModel.R: -------------------------------------------------------------------------------- 1 | fixef.jointModel <- 2 | function (object, process = c("Longitudinal", "Event"), 3 | include.splineCoefs = FALSE, ...) { 4 | if (!inherits(object, "jointModel")) 5 | stop("Use only with 'jointModel' objects.\n") 6 | process <- match.arg(process) 7 | if (process == "Longitudinal") { 8 | object$coefficients$betas 9 | } else { 10 | gammas <- object$coefficients$gammas 11 | if (object$method == "spline-PH-GH" && !include.splineCoefs) { 12 | ng <- length(gammas) 13 | nw <- ncol(object$x$W) 14 | gammas <- if (is.null(nw)) NULL else gammas[seq(ng - nw + 1, ng)] 15 | } 16 | out <- c(gammas, "Assoct" = as.vector(object$coefficients$alpha), 17 | "Assoct.s" = as.vector(object$coefficients$Dalpha)) 18 | if (object$method == "weibull-AFT-GH") 19 | out <- - out 20 | jj <- grep("Assoct[!^\\.s]", names(out)) 21 | ii <- setdiff(grep("Assoct", names(out)), jj) 22 | if (length(ii) > 1) { 23 | nn <- names(object$coefficients$alpha) 24 | names(out)[ii] <- if (length(nn) == 1) "Assoct" else { 25 | if (nn[1] == "") 26 | c("Assoct", paste("Assoct", nn[-1], sep = ":")) 27 | else 28 | paste("Assoct", nn, sep = ":") 29 | } 30 | } 31 | if (length(jj) > 1) { 32 | nn <- names(object$coefficients$Dalpha) 33 | names(out)[jj] <- if (length(nn) == 1) "Assoct.s" else { 34 | if (nn[1] == "") 35 | c("Assoct.s", paste("Assoct.s", nn[-1], sep = ":")) 36 | else 37 | paste("Assoct.s", nn, sep = ":") 38 | } 39 | } 40 | if ((lag <- object$y$lag) > 0) { 41 | kk <- grep("Assoct", names(out), fixed = TRUE) 42 | names(out)[kk] <- paste(names(out)[kk], "(lag=", lag, ")", sep = "") 43 | } 44 | out 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /R/flexCPH.R: -------------------------------------------------------------------------------- 1 | flexCPH <- 2 | function (formula = formula(data), data = parent.frame(), subset, na.action, init, control = list()) { 3 | call <- match.call() 4 | m <- match.call(expand.dots = FALSE) 5 | temp <- c("", "formula", "data", "subset", "na.action") 6 | m <- m[match(temp, names(m), nomatch = 0)] 7 | Terms <- if (missing(data)) terms(formula) else terms(formula, data = data) 8 | m$formula <- Terms 9 | m[[1]] <- as.name("model.frame") 10 | m <- eval(m, parent.frame()) 11 | if (NROW(m) == 0) 12 | stop("No (non-missing) observations.\n") 13 | con <- list(lng.in.kn = 3, ord = 4, knots = NULL, numeriDeriv = "fd", eps.Hes = 1e-06, parscale = NULL) 14 | con[names(control)] <- control 15 | Y <- model.extract(m, "response") 16 | if (!inherits(Y, "Surv")) 17 | stop("Response must be a survival object.\n") 18 | logT <- log(Y[, 1]) 19 | d <- Y[, 2] 20 | attr(Terms, "intercept") <- 1 21 | X <- model.matrix(Terms, m) 22 | X <- X[, -1, drop = FALSE] 23 | type <- attr(Y, "type") 24 | if (type != "right") 25 | stop("flexCPH() supports currently only right-censored data.\n") 26 | if (missing(init)) 27 | init <- NULL 28 | out <- flexCPH.fit(logT, d, X, init, con) 29 | out$control <- con 30 | out$terms <- Terms 31 | out$call <- call 32 | class(out) <- "flexCPH" 33 | out 34 | } 35 | -------------------------------------------------------------------------------- /R/flexCPH.fit.R: -------------------------------------------------------------------------------- 1 | flexCPH.fit <- 2 | function (logT, d, X, init.thetas = NULL, control) { 3 | lgLwph <- function (thetas) { 4 | gamas <- thetas[1:nk] 5 | gamas[1:nk] <- cumsum(c(gamas[1], exp(gamas[2:nk]))) 6 | betas <- thetas[-c(1:nk)] 7 | eta <- as.vector(W %*% gamas + X %*% betas) 8 | sc <- as.vector(S %*% diff(gamas)) 9 | lgL <- d * (log(sc) + eta - logT) - exp(eta) 10 | - sum(lgL, na.rm = TRUE) 11 | } 12 | Scwph <- function (thetas) { 13 | gamas <- thetas[1:nk] 14 | gamas[1:nk] <- cumsum(c(gamas[1], exp(gamas[2:nk]))) 15 | betas <- thetas[-c(1:nk)] 16 | eta <- as.vector(W %*% gamas + X %*% betas) 17 | sc <- as.vector(S %*% diff(gamas)) 18 | ew <- - exp(eta) 19 | out <- (d + ew) * WX 20 | out[, 1:nk] <- out[, 1:nk] + d * SS / sc 21 | out <- colSums(out, na.rm = TRUE) 22 | out[1:nk] <- out[1:nk] %*% jacobian(thetas[1:nk]) 23 | - out 24 | } 25 | min.x <- min(logT) 26 | max.x <- max(logT) 27 | kn <- if (is.null(control$knots)) { 28 | kk <- seq(0, 1, length.out = control$lng.in.kn + 2)[-c(1, control$lng.in.kn + 2)] 29 | quantile(logT[d == 1], kk, names = FALSE) 30 | } else { 31 | control$knots 32 | } 33 | kn <- sort(c(rep(c(min.x, max.x), control$ord), kn)) 34 | W <- splineDesign(kn, logT, ord = control$ord) 35 | S <- splineDesign(kn[-c(1, length(kn))], logT, ord = control$ord - 1) 36 | S <- control$ord * S / rep(diff(kn, lag = control$ord + 1), each = length(d)) 37 | ncs <- ncol(S) 38 | SS <- cbind(- S[, 1], S[, 1:(ncs - 1)] - S[, 2:ncs], S[, ncs]) 39 | nk <- ncol(W) 40 | WX <- cbind(W, X) 41 | if (is.null(init.thetas)) { 42 | init.thetas <- 43 | init.thetas <- c(-1, seq(-0.5, 0.5, length.out = nk - 1), rep(0, ncol(X))) 44 | } 45 | if (is.null(control$parscale)) 46 | control$parscale <- rep(0.01, length(init.thetas)) 47 | opt <- optim(init.thetas, lgLwph, Scwph, method = "BFGS", 48 | control = list(maxit = 5000, parscale = control$parscale, reltol = 1e-09)) 49 | thetas <- opt$par 50 | gamas <- thetas[1:nk] 51 | gamas[1:nk] <- cumsum(c(gamas[1], exp(gamas[2:nk]))) 52 | betas <- thetas[-(1:nk)] 53 | eta <- as.vector(W %*% gamas + X %*% betas) 54 | ew <- exp(eta) 55 | surv <- exp(- ew) 56 | CH <- exp(ew) 57 | logCH <- eta 58 | H <- if (control$numeriDeriv == "fd") { 59 | fd.vec(opt$par, Scwph, eps = control$eps.Hes) 60 | } else { 61 | cd.vec(opt$par, Scwph, eps = control$eps.Hes) 62 | } 63 | if (any(is.na(H) | !is.finite(H))) { 64 | warning("infinite or missing values in Hessian at convergence.\n") 65 | } else { 66 | ev <- eigen(H, symmetric = TRUE, only.values = TRUE)$values 67 | if (!all(ev >= -1e-06 * abs(ev[1]))) 68 | warning("Hessian matrix at convergence is not positive definite.\n") 69 | } 70 | names(gamas) <- paste("bs.", 1:nk, sep = "") 71 | names(betas) <- colnames(X) 72 | nams <- c(names(gamas), names(betas)) 73 | dimnames(H) <- list(nams, nams) 74 | list(coefficients = list(gammas = gamas, betas = betas), Hessian = H, logLik = -opt$value, logT = logT, 75 | d = d, X = X, knots = kn, survival = surv, cumHazard = CH, "log.cumHazard" = logCH) 76 | } 77 | -------------------------------------------------------------------------------- /R/fn.R: -------------------------------------------------------------------------------- 1 | fn <- 2 | function (bb) { 3 | eta.yi <- eta.yxi + rowSums(Z.ind.i * rep(bb, each = ni[i])) 4 | Yi <- alpha * (eta.si + rowSums(Zsi * rep(bb, each = GKk))) 5 | log.p.ybi <- sum(dnorm(yi, eta.yi, sigma, log = TRUE)) 6 | log.p.tbi <- if (d[i]) { 7 | eta.tw1i + eta.tw2i + alpha * (eta.yxT[i] + sum(Ztime.i * bb)) - exp(eta.tw1i) * Pi * sum(wk * exp(eta.wsi + Yi)) 8 | } else { 9 | - exp(eta.tw1i) * Pi * sum(wk * exp(eta.wsi + alpha * eta.si)) 10 | } 11 | log.p.bi <- if (diag.D) - 0.5 * crossprod(bb, bb / D)[1, ] else - 0.5 * crossprod(bb, solve(D, bb))[1, ] 12 | - (log.p.ybi + log.p.tbi + log.p.bi) 13 | } 14 | -------------------------------------------------------------------------------- /R/format.perc2.R: -------------------------------------------------------------------------------- 1 | format.perc2 <- 2 | function (probs, digits) { 3 | paste(format(100 * probs, trim = TRUE, scientific = FALSE, 4 | digits = digits), "%") 5 | } 6 | -------------------------------------------------------------------------------- /R/gauher.R: -------------------------------------------------------------------------------- 1 | gauher <- 2 | function (n) { 3 | m <- trunc((n + 1)/2) 4 | x <- w <- rep(-1, n) 5 | for (i in seq_len(m)) { 6 | z <- if (i == 1) { 7 | sqrt(2*n + 1) - 1.85575 * (2*n + 1)^(-0.16667) 8 | } else if (i == 2) { 9 | z - 1.14 * n^0.426 / z 10 | } else if (i == 3) { 11 | 1.86 * z - 0.86 * x[1] 12 | } else if (i == 4) { 13 | 1.91 * z - 0.91 * x[2] 14 | } else { 15 | 2*z - x[i - 2] 16 | } 17 | for (its in seq_len(10)) { 18 | p1 <- 0.751125544464943 19 | p2 <- 0 20 | for (j in seq_len(n)) { 21 | p3 <- p2 22 | p2 <- p1 23 | p1 <- z * sqrt(2/j) * p2 - sqrt((j - 1)/j) * p3 24 | } 25 | pp <- sqrt(2*n) * p2 26 | z1 <- z 27 | z <- z1 - p1/pp 28 | if (abs(z - z1) <= 3e-14) 29 | break 30 | } 31 | x[i] <- z 32 | x[n + 1 - i] <- -z 33 | w[i] <- 2 / (pp * pp) 34 | w[n + 1 - i] <- w[i] 35 | } 36 | list(x = x, w = w) 37 | } 38 | -------------------------------------------------------------------------------- /R/gaussKronrod.R: -------------------------------------------------------------------------------- 1 | gaussKronrod <- 2 | function (k = 15) { 3 | sk <- c(-0.949107912342758524526189684047851, -0.741531185599394439863864773280788, -0.405845151377397166906606412076961, 0, 4 | 0.405845151377397166906606412076961, 0.741531185599394439863864773280788, 0.949107912342758524526189684047851, -0.991455371120812639206854697526329, 5 | -0.864864423359769072789712788640926, -0.586087235467691130294144838258730, -0.207784955007898467600689403773245, 0.207784955007898467600689403773245, 6 | 0.586087235467691130294144838258730, 0.864864423359769072789712788640926, 0.991455371120812639206854697526329) 7 | wk15 <- c(0.063092092629978553290700663189204, 0.140653259715525918745189590510238, 0.190350578064785409913256402421014, 8 | 0.209482141084727828012999174891714, 0.190350578064785409913256402421014, 0.140653259715525918745189590510238, 0.063092092629978553290700663189204, 9 | 0.022935322010529224963732008058970, 0.104790010322250183839876322541518, 0.169004726639267902826583426598550, 0.204432940075298892414161999234649, 10 | 0.204432940075298892414161999234649, 0.169004726639267902826583426598550, 0.104790010322250183839876322541518, 0.022935322010529224963732008058970) 11 | wk7 <- c(0.129484966168869693270611432679082, 0.279705391489276667901467771423780, 0.381830050505118944950369775488975, 12 | 0.417959183673469387755102040816327, 0.381830050505118944950369775488975, 0.279705391489276667901467771423780, 0.129484966168869693270611432679082) 13 | if (k == 7) 14 | list(sk = sk[1:7], wk = wk7) 15 | else 16 | list(sk = sk, wk = wk15) 17 | } 18 | -------------------------------------------------------------------------------- /R/globals.R: -------------------------------------------------------------------------------- 1 | 2 | if (getRversion() >= '2.15.1') globalVariables(c('X', 'Xtime', 'WW', 'gammas', 'parameterization', 'Xs', 'Zsb', 'Ws.intF.vl', 'alpha', 'Xs.deriv', 'indFixed', 'Zsb.deriv', 3 | 'Ws.intF.sl', 'Dalpha', 'wk', 'P', 'XtX', 'sigma', 'id.GK', 'd', 'sigma.t', 'ncx', 'p.byt', 'wGH', 'eta.tw', 'xi', 'ind.K', 'wkP', 'eta.tw1', 'eta.ws', 'idT', 'log.st', 4 | 'lambda0.', 'indT', 'p.byt.', 'ncww', 'diag.D', 'Xtime2', 'Ztime.b', 'Ztime2.b', 'n', 'Ztb', 'y', 'id', 'ind.T0', 'k', 'unq.indT', 'ind.L1', 'control', 'b', 'ncz', 'lis.b', 5 | 'VCdets', 'list.thetas', 'WintF.vl', 'Xtime.deriv', 'Ztime.b.deriv', 'WintF.sl', 'ind.D', 'W1', 'W2', 'W2s', 'scaleWB', 'logT', 'object', 'obs.times', 'Z', 'LongFormat', 6 | 'Ztime', 'Ztime.deriv', 'method', 'Zs', 'Zs.deriv', 'st', 'type', 'M', 'return.data', 'ni', 'data.id', 'timeVar', 'TermsX', 'TermsZ', 'formYx', 'formYz', 'TermsX.deriv', 7 | 'TermsZ.deriv', 'derivForm', 'Q', 'betas.new', 'indRandom', 'alpha.new', 'Dalpha.new', 'W', 'gammas.new', 'sigma.t.new', 'strt', 'gammas.bs.new', 'i', 'xi.new', 'lambda0', 8 | 'b2', 'lis.b2', 'ZtZ', 'N', 'nk', 'B', 'verbose', 'Ys.deriv', 'eta.yxi', 'Z.ind.i', 'eta.si', 'Zsi', 'GKk', 'yi', 'eta.tw1i', 'eta.tw2i', 'eta.yxT', 'Ztime.i', 'Pi', 9 | 'eta.wsi', 'yi.eta.yxi', 'Zb', 'Y', 'Y.deriv', 'Ys', 'Y2', 'chLaplace.fit', 'sigma.new', 'D.new', 'eta.tw2', 'eta.yx', 'Z.missO', 'id3.miss', 'y.missO', 'id.miss', 'n.missO', 10 | 'Xtime.missO', 'Ztime.missO', 'WintF.vl.missO', 'Xs.missO', 'Zs.missO', 'Ws.intF.vl.missO', 'Xtime.deriv.missO', 'Ztime.deriv.missO', 'WintF.sl.missO', 'Xs.deriv.missO', 11 | 'Zs.deriv.missO', 'Ws.intF.sl.missO', 'logT.missO', 'log.st.missO', 'P.missO', 'd.missO', 'W2.missO', 'idT.missO', 'W2s.missO', 'ind.D.missO', 'ind.K.missO', 'wkP.missO', 12 | 'max.time', 'SclongCH', 'ScsurvCH', 'update.bCH', 'LogLik.chLaplace', 'Score.chLaplace', 'kn', 'new.b', 'cons.logLik', 'xtable', 'pdMatrix')) 13 | -------------------------------------------------------------------------------- /R/gr.R: -------------------------------------------------------------------------------- 1 | gr <- 2 | function (bb) { 3 | gr.ybi <- - crossprod(Z.ind.i, Z.ind.i %*% bb - yi.eta.yxi) / sigma^2 4 | Yi <- alpha * (eta.si + rowSums(Zsi * rep(bb, each = GKk))) 5 | gr.tbi <- numeric(ncz) 6 | for (k in 1:ncz) { 7 | gr.tbi[k] <- if (d[i]) { 8 | alpha * Ztime.i[k] - exp(eta.tw1i) * Pi * sum(wk * exp(eta.wsi + Yi) * alpha * Zsi[, k]) 9 | } else { 10 | - exp(eta.tw1i) * Pi * sum(wk * exp(eta.wsi + eta.si) * alpha * Zsi[, k]) 11 | } 12 | } 13 | gr.bi <- if (diag.D) - bb / D else - solve(D, bb) 14 | - as.vector(gr.ybi + gr.tbi + gr.bi) 15 | } 16 | -------------------------------------------------------------------------------- /R/gr.longAFTWB.R: -------------------------------------------------------------------------------- 1 | gr.longAFTWB <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Ys <- as.vector(Xs %*% betas) + Zsb 6 | WintF.vl.alph <- c(WintF.vl %*% alpha) 7 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 8 | eta.s <- Ws.intF.vl.alph * Ys 9 | } 10 | if (parameterization %in% c("slope", "both")) { 11 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 12 | WintF.sl.alph <- c(WintF.sl %*% Dalpha) 13 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 14 | eta.s <- if (parameterization == "both") 15 | eta.s + Ws.intF.sl.alph * Ys.deriv 16 | else 17 | Ws.intF.sl.alph * Ys.deriv 18 | } 19 | wk.exp.eta.s <- wk * exp(eta.s) 20 | exp.eta.tw.P <- exp(eta.tw) * P 21 | sc1 <- - crossprod(X, y - eta.yx - Zb) / sigma^2 22 | Vi <- exp(eta.tw) * P * rowsum(wk.exp.eta.s, id.GK, reorder = FALSE); dimnames(Vi) <- NULL 23 | Vii <- d * (sigma.t - 1) / Vi - sigma.t * Vi^(sigma.t - 1) 24 | sc2 <- numeric(ncx) 25 | for (i in 1:ncx) { 26 | ki <- Vii * exp.eta.tw.P * switch(parameterization, 27 | "value" = rowsum(wk.exp.eta.s * Ws.intF.vl.alph * Xs[, i], id.GK, reorder = FALSE), 28 | "slope" = {ii <- match(i, indFixed); 29 | if (is.na(ii)) 0 else rowsum(wk.exp.eta.s * Ws.intF.sl.alph * 30 | Xs.deriv[, ii], id.GK, reorder = FALSE)}, 31 | "both" = {ii <- match(i, indFixed); 32 | rowsum(wk.exp.eta.s * (Ws.intF.vl.alph * Xs[, i] + Ws.intF.sl.alph * 33 | if (is.na(ii)) 0 else Xs.deriv[, ii]), id.GK, reorder = FALSE)} 34 | ) 35 | kii <- c((p.byt * ki) %*% wGH) 36 | sc2[i] <- switch(parameterization, 37 | "value" = - sum(d * WintF.vl.alph * Xtime[, i] + kii, na.rm = TRUE), 38 | "slope" = {ii <- match(i, indFixed); 39 | if (is.na(ii)) 0 else - sum(d * WintF.sl.alph * Xtime.deriv[, ii] + kii, na.rm = TRUE)}, 40 | "both" = {ii <- match(i, indFixed); 41 | - sum(d * (WintF.vl.alph * Xtime[, i] + WintF.sl.alph * 42 | if (is.na(ii)) 0 else Xtime.deriv[, ii]) + kii, na.rm = TRUE)} 43 | ) 44 | } 45 | c(sc1 + sc2) 46 | } 47 | -------------------------------------------------------------------------------- /R/gr.longPC.R: -------------------------------------------------------------------------------- 1 | gr.longPC <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Ys <- as.vector(Xs %*% betas) + Zsb 6 | WintF.vl.alph <- c(WintF.vl %*% alpha) 7 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 8 | eta.s <- Ws.intF.vl.alph * Ys 9 | } 10 | if (parameterization %in% c("slope", "both")) { 11 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 12 | WintF.sl.alph <- c(WintF.sl %*% Dalpha) 13 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 14 | eta.s <- if (parameterization == "both") 15 | eta.s + Ws.intF.sl.alph * Ys.deriv 16 | else 17 | Ws.intF.sl.alph * Ys.deriv 18 | } 19 | exp.eta.tw <- exp(eta.tw) 20 | sc1 <- - crossprod(X, y - eta.yx - Zb) / sigma^2 21 | Int <- xi[ind.K] * wkP * exp(eta.s) 22 | sc2 <- numeric(ncx) 23 | for (i in 1:ncx) { 24 | ki <- exp.eta.tw * switch(parameterization, 25 | "value" = rowsum(Int * Ws.intF.vl.alph * Xs[, i], id.GK, reorder = FALSE), 26 | "slope" = {ii <- match(i, indFixed); 27 | if (is.na(ii)) 0 else rowsum(Int * Ws.intF.sl.alph * Xs.deriv[, ii], id.GK, reorder = FALSE)}, 28 | "both" = {ii <- match(i, indFixed); 29 | rowsum(Int * (Ws.intF.vl.alph * Xs[, i] + 30 | Ws.intF.sl.alph * if (is.na(ii)) 0 else Xs.deriv[, ii]), id.GK, reorder = FALSE)} 31 | ) 32 | kii <- c((p.byt * ki) %*% wGH) 33 | sc2[i] <- switch(parameterization, 34 | "value" = - sum(d * WintF.vl.alph * Xtime[, i] - kii, na.rm = TRUE), 35 | "slope" = {ii <- match(i, indFixed); 36 | if (is.na(ii)) 0 else - sum(d * WintF.sl.alph * Xtime.deriv[, ii] - kii, na.rm = TRUE)}, 37 | "both" = {ii <- match(i, indFixed); 38 | - sum(d * (WintF.vl.alph * Xtime[, i] + 39 | WintF.sl.alph * if (is.na(ii)) 0 else Xtime.deriv[, ii]) - kii, na.rm = TRUE)} 40 | ) 41 | } 42 | c(sc1 + sc2) 43 | } 44 | -------------------------------------------------------------------------------- /R/gr.longPH.R: -------------------------------------------------------------------------------- 1 | gr.longPH <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | eta.yxT <- as.vector(Xtime %*% betas) 5 | eta.yxT2 <- as.vector(Xtime2 %*% betas) 6 | Y <- eta.yxT + Ztime.b 7 | Y2 <- eta.yxT2 + Ztime2.b 8 | eta.t <- eta.tw + alpha * Y 9 | eta.s <- alpha * Y2 10 | exp.eta.s <- exp(eta.s) 11 | exp.eta.tw <- exp(eta.tw) 12 | sc1 <- - crossprod(X, y - eta.yx - Zb) / sigma^2 13 | Int <- lambda0[ind.L1] * exp(eta.s) * alpha 14 | sc2 <- numeric(ncx) 15 | for (i in 1:ncx) { 16 | S <- matrix(0, n, k) 17 | S[unq.indT, ] <- rowsum(Int * Xtime2[, i], indT, reorder = FALSE) 18 | ki <- exp.eta.tw * S 19 | kii <- c((p.byt * ki) %*% wGH) 20 | sc2[i] <- - sum(d * alpha * Xtime[, i] - kii, na.rm = TRUE) 21 | } 22 | c(sc1 + sc2) 23 | } 24 | -------------------------------------------------------------------------------- /R/gr.longSplinePH.R: -------------------------------------------------------------------------------- 1 | gr.longSplinePH <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Ys <- as.vector(Xs %*% betas) + Zsb 6 | WintF.vl.alph <- c(WintF.vl %*% alpha) 7 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 8 | eta.s <- Ws.intF.vl.alph * Ys 9 | } 10 | if (parameterization %in% c("slope", "both")) { 11 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 12 | WintF.sl.alph <- c(WintF.sl %*% Dalpha) 13 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 14 | eta.s <- if (parameterization == "both") 15 | eta.s + Ws.intF.sl.alph * Ys.deriv 16 | else 17 | Ws.intF.sl.alph * Ys.deriv 18 | } 19 | exp.eta.tw.P <- exp(eta.tw1) * P 20 | sc1 <- - crossprod(X, y - eta.yx - Zb) / sigma^2 21 | Int <- wk * exp(eta.ws + eta.s) 22 | sc2 <- numeric(ncx) 23 | for (i in 1:ncx) { 24 | ki <- exp.eta.tw.P * switch(parameterization, 25 | "value" = rowsum(Int * Ws.intF.vl.alph * Xs[, i], id.GK, reorder = FALSE), 26 | "slope" = {ii <- match(i, indFixed); 27 | if (is.na(ii)) 0 else rowsum(Int * Ws.intF.sl.alph * Xs.deriv[, ii], 28 | id.GK, reorder = FALSE)}, 29 | "both" = {ii <- match(i, indFixed); 30 | rowsum(Int * (Ws.intF.vl.alph * Xs[, i] + 31 | Ws.intF.sl.alph * if (is.na(ii)) 0 else Xs.deriv[, ii]), 32 | id.GK, reorder = FALSE)} 33 | ) 34 | ki <- c(rowsum(ki, idT, reorder = FALSE)) 35 | kii <- c((p.byt * ki) %*% wGH) 36 | sc2[i] <- switch(parameterization, 37 | "value" = { 38 | ddd <- tapply(d * WintF.vl.alph * Xtime[, i], idT, sum) 39 | - sum(ddd - kii, na.rm = TRUE) 40 | }, 41 | "slope" = { 42 | ii <- match(i, indFixed) 43 | if (is.na(ii)) 0 else { 44 | ddd <- tapply(d * WintF.sl.alph * Xtime.deriv[, ii], idT, sum) 45 | - sum(ddd - kii, na.rm = TRUE) 46 | } 47 | }, 48 | "both" = { 49 | ii <- match(i, indFixed) 50 | ddd <- tapply(d * (WintF.vl.alph * Xtime[, i] + 51 | WintF.sl.alph * if (is.na(ii)) 0 else Xtime.deriv[, ii]), 52 | idT, sum) 53 | - sum(ddd - kii, na.rm = TRUE) 54 | } 55 | ) 56 | } 57 | c(sc1 + sc2) 58 | } 59 | -------------------------------------------------------------------------------- /R/gr.longWB.R: -------------------------------------------------------------------------------- 1 | gr.longWB <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Ys <- as.vector(Xs %*% betas) + Zsb 6 | WintF.vl.alph <- c(WintF.vl %*% alpha) 7 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 8 | eta.s <- Ws.intF.vl.alph * Ys 9 | } 10 | if (parameterization %in% c("slope", "both")) { 11 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 12 | WintF.sl.alph <- c(WintF.sl %*% Dalpha) 13 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 14 | eta.s <- if (parameterization == "both") 15 | eta.s + Ws.intF.sl.alph * Ys.deriv 16 | else 17 | Ws.intF.sl.alph * Ys.deriv 18 | } 19 | exp.eta.tw.P <- exp(eta.tw) * P 20 | sc1 <- - crossprod(X, y - eta.yx - Zb) / sigma^2 21 | Int <- wk * exp(log(sigma.t) + (sigma.t - 1) * log.st + eta.s) 22 | sc2 <- numeric(ncx) 23 | for (i in 1:ncx) { 24 | ki <- exp.eta.tw.P * switch(parameterization, 25 | "value" = rowsum(Int * Ws.intF.vl.alph * Xs[, i], id.GK, reorder = FALSE), 26 | "slope" = {ii <- match(i, indFixed); 27 | if (is.na(ii)) 0 else rowsum(Int * Ws.intF.sl.alph * Xs.deriv[, ii], id.GK, reorder = FALSE)}, 28 | "both" = {ii <- match(i, indFixed); 29 | rowsum(Int * (Ws.intF.vl.alph * Xs[, i] + 30 | Ws.intF.sl.alph * if (is.na(ii)) 0 else Xs.deriv[, ii]), id.GK, reorder = FALSE)} 31 | ) 32 | kii <- c((p.byt * ki) %*% wGH) 33 | sc2[i] <- switch(parameterization, 34 | "value" = - sum(d * WintF.vl.alph * Xtime[, i] - kii, na.rm = TRUE), 35 | "slope" = {ii <- match(i, indFixed); 36 | if (is.na(ii)) 0 else - sum(d * WintF.sl.alph * Xtime.deriv[, ii] - kii, na.rm = TRUE)}, 37 | "both" = {ii <- match(i, indFixed); 38 | - sum(d * (WintF.vl.alph * Xtime[, i] + 39 | WintF.sl.alph * if (is.na(ii)) 0 else Xtime.deriv[, ii]) - kii, na.rm = TRUE)} 40 | ) 41 | } 42 | c(sc1 + sc2) 43 | } 44 | -------------------------------------------------------------------------------- /R/gr.survAFTWB.R: -------------------------------------------------------------------------------- 1 | gr.survAFTWB <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | sigma.t <- if (is.null(scaleWB)) exp(thetas$log.sigma.t) else scaleWB 8 | eta.tw <- as.vector(WW %*% gammas) 9 | eta.t <- switch(parameterization, 10 | "value" = eta.tw + c(WintF.vl %*% alpha) * Y, 11 | "slope" = eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv, 12 | "both" = eta.tw + c(WintF.vl %*% alpha) * Y + c(WintF.sl %*% Dalpha) * Y.deriv) 13 | eta.s <- switch(parameterization, 14 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 15 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 16 | "both" = c(Ws.intF.vl %*% alpha) * Ys + c(Ws.intF.sl %*% Dalpha) * Ys.deriv) 17 | wk.exp.eta.s <- wk * exp(eta.s) 18 | exp.eta.tw <- exp(eta.tw) 19 | Vi <- exp.eta.tw * P * rowsum(wk.exp.eta.s, id.GK, reorder = FALSE); dimnames(Vi) <- NULL 20 | Vii <- d * (sigma.t - 1) / Vi - sigma.t * Vi^(sigma.t - 1) 21 | scgammas <- - colSums(WW * (d + c((p.byt * Vii * Vi) %*% wGH)), na.rm = TRUE) 22 | scalpha <- if (parameterization %in% c("value", "both")) { 23 | rr <- numeric(ncol(WintF.vl)) 24 | for (k in seq_along(rr)) 25 | rr[k] <- - sum((p.byt * (d * WintF.vl[, k] * Y + Vii * exp.eta.tw * P * 26 | rowsum(wk.exp.eta.s * Ws.intF.vl[, k] * Ys, id.GK, reorder = FALSE))) %*% wGH, na.rm = TRUE) 27 | rr 28 | } else NULL 29 | scalpha.D <- if (parameterization %in% c("slope", "both")) { 30 | rr <- numeric(ncol(WintF.sl)) 31 | for (k in seq_along(rr)) 32 | rr[k] <- - sum((p.byt * (d * WintF.sl[, k] * Y.deriv + Vii * exp.eta.tw * P * 33 | rowsum(wk.exp.eta.s * Ws.intF.sl[, k] * Ys.deriv, id.GK, reorder = FALSE))) %*% wGH, na.rm = TRUE) 34 | rr 35 | } else NULL 36 | scsigmat <- if (is.null(scaleWB)) { 37 | - sigma.t * sum((p.byt * (d / sigma.t + (d - Vi^sigma.t) * log(Vi))) %*% wGH, na.rm = TRUE) 38 | 39 | } else NULL 40 | c(scgammas, scalpha, scalpha.D, scsigmat) 41 | } 42 | -------------------------------------------------------------------------------- /R/gr.survPC.R: -------------------------------------------------------------------------------- 1 | gr.survPC <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | xi <- exp(thetas$log.xi) 8 | eta.tw <- if (!is.null(WW)) as.vector(WW %*% gammas) else rep(0, n) 9 | eta.t <- switch(parameterization, 10 | "value" = eta.tw + c(WintF.vl %*% alpha) * Y, 11 | "slope" = eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv, 12 | "both" = eta.tw + c(WintF.vl %*% alpha) * Y + c(WintF.sl %*% Dalpha) * Y.deriv) 13 | exp.eta.s <- exp(switch(parameterization, 14 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 15 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 16 | "both" = c(Ws.intF.vl %*% alpha) * Ys + c(Ws.intF.sl %*% Dalpha) * Ys.deriv)) 17 | exp.eta.tw <- exp(eta.tw) 18 | Int <- wkP * exp.eta.s 19 | Int2 <- xi[ind.K] * Int 20 | scgammas <- if (!is.null(WW)) { 21 | - colSums(WW * (d - c((p.byt * (exp.eta.tw * 22 | rowsum(Int2, id.GK, reorder = FALSE))) %*% wGH)), na.rm = TRUE) 23 | } else NULL 24 | scalpha <- if (parameterization %in% c("value", "both")) { 25 | rr <- numeric(ncol(WintF.vl)) 26 | for (k in seq_along(rr)) 27 | rr[k] <- - sum((p.byt * (d * WintF.vl[, k] * Y - exp.eta.tw * 28 | rowsum(Int2 * Ws.intF.vl[, k] * Ys, id.GK, reorder = FALSE))) %*% wGH, na.rm = TRUE) 29 | rr 30 | } else NULL 31 | scalpha.D <- if (parameterization %in% c("slope", "both")) { 32 | rr <- numeric(ncol(WintF.sl)) 33 | for (k in seq_along(rr)) 34 | rr[k] <- - sum((p.byt * (d * WintF.sl[, k] * Y.deriv - exp.eta.tw * 35 | rowsum(Int2 * Ws.intF.sl[, k] * Ys.deriv, id.GK, reorder = FALSE))) %*% wGH, na.rm = TRUE) 36 | rr 37 | } else NULL 38 | scxi <- numeric(Q) 39 | for (i in 1:Q) { 40 | i1 <- ind.D == i 41 | i2 <- ind.K == i 42 | i3 <- ind.D >= i 43 | ki <- c((p.byt[i3, ] * (exp.eta.tw[i3] * rowsum(Int[i2, ], id.GK[i2], reorder = FALSE))) %*% wGH) 44 | kk <- numeric(n); kk[i3] <- ki 45 | scxi[i] <- - xi[i] * sum((d * i1)/xi[i] - kk) 46 | } 47 | c(scgammas, scalpha, scalpha.D, scxi) 48 | } 49 | -------------------------------------------------------------------------------- /R/gr.survPH.R: -------------------------------------------------------------------------------- 1 | gr.survPH <- 2 | function (thetas) { 3 | gammas <- thetas[seq_len(ncww)] 4 | alpha <- thetas[ncww + 1] 5 | eta.tw <- if (!is.null(WW)) as.vector(WW %*% gammas) else rep(0, n) 6 | eta.t <- eta.tw + alpha * Y 7 | eta.s <- alpha * Y2 8 | exp.eta.s <- exp(eta.s) 9 | exp.eta.tw <- exp(eta.tw) 10 | Int <- lambda0[ind.L1] * exp.eta.s 11 | sc.gammas <- if (!is.null(WW)) { 12 | S1 <- matrix(0, n, k) 13 | S1[unq.indT, ] <- rowsum(Int, indT, reorder = FALSE) 14 | - colSums(WW * (d - c((p.byt * (exp.eta.tw * S1)) %*% wGH)), na.rm = TRUE) 15 | } else 16 | NULL 17 | S2 <- matrix(0, n, k) 18 | S2[unq.indT, ] <- rowsum(Int * Y2, indT, reorder = FALSE) 19 | sc.alpha <- - sum((p.byt * (d * Y - exp.eta.tw * S2)) %*% wGH, na.rm = TRUE) 20 | c(sc.gammas, sc.alpha) 21 | } 22 | -------------------------------------------------------------------------------- /R/gr.survSplinePH.R: -------------------------------------------------------------------------------- 1 | gr.survSplinePH <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | gammas.bs <- thetas$gammas.bs 8 | eta.tw1 <- if (!is.null(W1)) as.vector(W1 %*% gammas) else rep(0, n) 9 | eta.tw2 <- as.vector(W2 %*% gammas.bs) 10 | eta.t <- switch(parameterization, 11 | "value" = eta.tw2 + eta.tw1 + c(WintF.vl %*% alpha) * Y, 12 | "slope" = eta.tw2 + eta.tw1 + c(WintF.sl %*% Dalpha) * Y.deriv, 13 | "both" = eta.tw2 + eta.tw1 + c(WintF.vl %*% alpha) * Y + 14 | c(WintF.sl %*% Dalpha) * Y.deriv) 15 | eta.s <- switch(parameterization, 16 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 17 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 18 | "both" = c(Ws.intF.vl %*% alpha) * Ys + 19 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv) 20 | eta.ws <- as.vector(W2s %*% gammas.bs) 21 | exp.eta.tw.P <- exp(eta.tw1) * P 22 | Int <- wk * exp(eta.ws + eta.s) 23 | scgammas1 <- if (!is.null(W1)) { 24 | ki <- exp.eta.tw.P * rowsum(Int, id.GK, reorder = FALSE) 25 | scg1 <- numeric(ncol(W1)) 26 | for (jj in seq_along(scg1)) { 27 | tt <- rowsum(W1[, jj] * ki, idT, reorder = FALSE) 28 | scg1[jj] <- sum(c((p.byt * tt) %*% wGH), na.rm = TRUE) 29 | } 30 | - colSums(W1 * d, na.rm = TRUE) + scg1 31 | } else 32 | NULL 33 | scgammas2 <- numeric(nk) 34 | for (i in 1:nk) { 35 | kk <- exp.eta.tw.P * rowsum(Int * W2s[, i], id.GK, reorder = FALSE) 36 | kk <- rowsum(kk, idT, reorder = FALSE) 37 | scgammas2[i] <- - sum(W2[, i] * d) + sum(c((p.byt * kk) %*% wGH)) 38 | } 39 | scalpha <- if (parameterization %in% c("value", "both")) { 40 | rr <- numeric(ncol(WintF.vl)) 41 | for (k in seq_along(rr)) { 42 | rrr <- exp.eta.tw.P * rowsum(Int * Ws.intF.vl[, k] * Ys, 43 | id.GK, reorder = FALSE) 44 | rrr <- rowsum(rrr, idT, reorder = FALSE) 45 | rr[k] <- - sum((p.byt * (rowsum(d * WintF.vl[, k] * Y, idT, 46 | reorder = FALSE) - rrr)) %*% wGH, na.rm = TRUE) 47 | } 48 | rr 49 | } else NULL 50 | scalpha.D <- if (parameterization %in% c("slope", "both")) { 51 | rr <- numeric(ncol(WintF.sl)) 52 | for (k in seq_along(rr)) { 53 | rrr <- exp.eta.tw.P * rowsum(Int * Ws.intF.sl[, k] * 54 | Ys.deriv, id.GK, reorder = FALSE) 55 | rrr <- rowsum(rrr, idT, reorder = FALSE) 56 | rr[k] <- - sum((p.byt * (rowsum(d * WintF.sl[, k] * Y.deriv, 57 | idT, reorder = FALSE) - rrr)) %*% wGH, na.rm = TRUE) 58 | } 59 | rr 60 | } else NULL 61 | c(scgammas1, scalpha, scalpha.D, scgammas2) 62 | } 63 | -------------------------------------------------------------------------------- /R/gr.survWB.R: -------------------------------------------------------------------------------- 1 | gr.survWB <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | sigma.t <- if (is.null(scaleWB)) exp(thetas$log.sigma.t) else scaleWB 8 | eta.tw <- as.vector(WW %*% gammas) 9 | eta.t <- switch(parameterization, 10 | "value" = eta.tw + c(WintF.vl %*% alpha) * Y, 11 | "slope" = eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv, 12 | "both" = eta.tw + c(WintF.vl %*% alpha) * Y + c(WintF.sl %*% Dalpha) * Y.deriv) 13 | eta.s <- switch(parameterization, 14 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 15 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 16 | "both" = c(Ws.intF.vl %*% alpha) * Ys + c(Ws.intF.sl %*% Dalpha) * Ys.deriv) 17 | exp.eta.tw.P <- exp(eta.tw) * P 18 | Int <- wk * exp(log(sigma.t) + (sigma.t - 1) * log.st + eta.s) 19 | ki <- exp.eta.tw.P * rowsum(Int, id.GK, reorder = FALSE) 20 | kii <- c((p.byt * ki) %*% wGH) 21 | scgammas <- - colSums(WW * (d - kii), na.rm = TRUE) 22 | scalpha <- if (parameterization %in% c("value", "both")) { 23 | rr <- numeric(ncol(WintF.vl)) 24 | for (k in seq_along(rr)) 25 | rr[k] <- - sum((p.byt * (d * WintF.vl[, k] * Y - exp.eta.tw.P * 26 | rowsum(Int * Ws.intF.vl[, k] * Ys, id.GK, reorder = FALSE))) %*% wGH, na.rm = TRUE) 27 | rr 28 | } else NULL 29 | scalpha.D <- if (parameterization %in% c("slope", "both")) { 30 | rr <- numeric(ncol(WintF.sl)) 31 | for (k in seq_along(rr)) 32 | rr[k] <- - sum((p.byt * (d * WintF.sl[, k] * Y.deriv - exp.eta.tw.P * 33 | rowsum(Int * Ws.intF.sl[, k] * Ys.deriv, id.GK, reorder = FALSE))) %*% wGH, na.rm = TRUE) 34 | rr 35 | } else NULL 36 | scsigmat <- if (is.null(scaleWB)) { 37 | Int2 <- st^(sigma.t - 1) * (1 + sigma.t * log.st) * exp(eta.s) 38 | - sigma.t * sum((p.byt * (d * (1/sigma.t + logT) - exp.eta.tw.P * 39 | rowsum(wk * Int2, id.GK, reorder = FALSE))) %*% wGH, na.rm = TRUE) 40 | } else NULL 41 | c(scgammas, scalpha, scalpha.D, scsigmat) 42 | } 43 | -------------------------------------------------------------------------------- /R/ibs.R: -------------------------------------------------------------------------------- 1 | ibs <- 2 | function (x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = range(x), 3 | from = 0, weight.fun = NULL, ...) { 4 | if (!is.null(weight.fun) && !is.function(weight.fun)) 5 | stop("'weight.fun' must be a function.\n") 6 | bs.x <- if (is.null(knots)) { 7 | bs(x, df = df, intercept = intercept, Boundary.knots = Boundary.knots) 8 | } else { 9 | bs(x, knots = knots, intercept = intercept, Boundary.knots = Boundary.knots) 10 | } 11 | kn <- attr(bs.x, "knots") 12 | Bkn <- attr(bs.x, "Boundary.knots") 13 | wk <- gaussKronrod(15)$wk 14 | sk <- gaussKronrod(15)$sk 15 | P1 <- (x + from) / 2 16 | P2 <- (x - from) / 2 17 | st <- outer(P2, sk) + P1 18 | out <- vector("list", 15) 19 | for (i in 1:15) { 20 | out[[i]] <- wk[i] * bs(st[, i], knots = kn, Boundary.knots = Bkn, intercept = intercept) 21 | if (!is.null(weight.fun)) { 22 | ww <- weight.fun(st[, i], x, ...) 23 | out[[i]] <- out[[i]] * ifelse(is.finite(ww), ww, 0) 24 | } 25 | 26 | } 27 | out <- P2 * Reduce("+", out) 28 | attr(out, "from") <- from 29 | attr(out, "weight.fun") <- weight.fun 30 | attr(out, "class") <- c("ibs", "basis", "matrix") 31 | out 32 | } 33 | -------------------------------------------------------------------------------- /R/ins.R: -------------------------------------------------------------------------------- 1 | ins <- 2 | function (x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = range(x), 3 | from = 0, weight.fun = NULL, ...) { 4 | if (!is.null(weight.fun) && !is.function(weight.fun)) 5 | stop("'weight.fun' must be a function.\n") 6 | ns.x <- if (is.null(knots)) { 7 | ns(x, df = df, intercept = intercept, Boundary.knots = Boundary.knots) 8 | } else { 9 | ns(x, knots = knots, intercept = intercept, Boundary.knots = Boundary.knots) 10 | } 11 | kn <- attr(ns.x, "knots") 12 | Bkn <- attr(ns.x, "Boundary.knots") 13 | wk <- gaussKronrod(15)$wk 14 | sk <- gaussKronrod(15)$sk 15 | P1 <- (x + from) / 2 16 | P2 <- (x - from) / 2 17 | st <- outer(P2, sk) + P1 18 | out <- vector("list", 15) 19 | for (i in 1:15) { 20 | out[[i]] <- wk[i] * ns(st[, i], knots = kn, Boundary.knots = Bkn, intercept = intercept) 21 | if (!is.null(weight.fun)) { 22 | ww <- weight.fun(st[, i], x, ...) 23 | out[[i]] <- out[[i]] * ifelse(is.finite(ww), ww, 0) 24 | } 25 | } 26 | out <- P2 * Reduce("+", out) 27 | attr(out, "from") <- from 28 | attr(out, "weight.fun") <- weight.fun 29 | attr(out, "class") <- c("ins", "basis", "matrix") 30 | out 31 | } 32 | -------------------------------------------------------------------------------- /R/jacobian.R: -------------------------------------------------------------------------------- 1 | jacobian <- 2 | function (theta) { 3 | k <- length(theta) 4 | etheta <- exp(theta) 5 | mat <- matrix(0, k, k) 6 | mat[, 1] <- rep(1, k) 7 | for (i in 2:k) 8 | mat[i:k, i] <- etheta[i] 9 | mat 10 | } 11 | -------------------------------------------------------------------------------- /R/jacobian2.R: -------------------------------------------------------------------------------- 1 | jacobian2 <- 2 | function (L, ncz) { 3 | ind <- which(lower.tri(matrix(0, ncz, ncz), TRUE), arr.ind = TRUE) 4 | dimnames(ind) <- NULL 5 | nind <- nrow(ind) 6 | id <- 1:nind 7 | rind <- which(ind[, 1] == ind[, 2]) 8 | lind <- vector("list", length(rind)) 9 | for (i in seq_along(rind)) { 10 | tt <- matrix(0, ncz - i + 1, ncz - i + 1) 11 | tt[lower.tri(tt, TRUE)] <- seq(rind[i], nind) 12 | tt <- tt + t(tt) 13 | diag(tt) <- diag(tt) / 2 14 | lind[[i]] <- tt 15 | } 16 | out <- matrix(0, nind, nind) 17 | for (g in 1:ncz) { 18 | gind <- id[g == ind[, 2]] 19 | vals <- L[gind] 20 | for (j in gind) { 21 | k <- which(j == gind) 22 | out[cbind(lind[[g]][k, ], j)] <- if (j %in% rind) vals[1] * vals else vals 23 | } 24 | } 25 | out[rind, ] <- 2 * out[rind, ] 26 | col.ind <- matrix(0, ncz, ncz) 27 | col.ind[lower.tri(col.ind, TRUE)] <- seq(1, length(L)) 28 | col.ind <- t(col.ind) 29 | out[, col.ind[upper.tri(col.ind, TRUE)]] 30 | } 31 | -------------------------------------------------------------------------------- /R/log.posterior.b.R: -------------------------------------------------------------------------------- 1 | log.posterior.b <- 2 | function (b, y, Mats, method, ii) { 3 | id.i <- id %in% ii 4 | idT.i <- idT %in% ii 5 | X.i <- X[id.i, , drop = FALSE] 6 | Z.i <- Z[id.i, , drop = FALSE] 7 | mu.y <- as.vector(X.i %*% betas.new) + rowSums(Z.i * rep(b, each = nrow(Z.i))) 8 | logNorm <- dnorm(y[id.i], mu.y, sigma.new, TRUE) 9 | log.p.yb <- sum(logNorm) 10 | log.p.b <- dmvnorm(b, rep(0, ncol(Z)), D.new, TRUE) 11 | st <- Mats[[ii]]$st 12 | wk <- Mats[[ii]]$wk 13 | P <- Mats[[ii]]$P 14 | Xs <- Mats[[ii]]$Xs 15 | Zs <- Mats[[ii]]$Zs 16 | Xs.deriv <- Mats[[ii]]$Xs.deriv 17 | Zs.deriv <- Mats[[ii]]$Zs.deriv 18 | Ws.intF.vl <- Mats[[ii]]$Ws.intF.vl 19 | Ws.intF.sl <- Mats[[ii]]$Ws.intF.sl 20 | ind <- Mats[[ii]]$ind 21 | if (parameterization %in% c("value", "both")) 22 | Ys <- as.vector(Xs %*% betas.new + rowSums(Zs * rep(b, each = nrow(Zs)))) 23 | if (parameterization %in% c("slope", "both")) 24 | Ys.deriv <- as.vector(Xs.deriv %*% betas.new[indFixed]) + 25 | rowSums(Zs.deriv * rep(b[indRandom], each = nrow(Zs))) 26 | tt <- switch(parameterization, 27 | "value" = c(Ws.intF.vl %*% alpha.new) * Ys, 28 | "slope" = c(Ws.intF.sl %*% Dalpha.new) * Ys.deriv, 29 | "both" = c(Ws.intF.vl %*% alpha.new) * Ys + 30 | c(Ws.intF.sl %*% Dalpha.new) * Ys.deriv) 31 | eta.tw <- if (!is.null(W)) { 32 | if (!LongFormat) 33 | as.vector(W[ii, , drop = FALSE] %*% gammas.new) 34 | else 35 | as.vector(W[idT.i, , drop = FALSE] %*% gammas.new) 36 | } else 0 37 | log.survival <- if (method == "weibull-PH-GH") { 38 | Vi <- exp(log(sigma.t.new) + (sigma.t.new - 1) * log(st) + tt) 39 | - exp(eta.tw) * P * sum(wk * Vi) 40 | } else if (method == "weibull-AFT-GH") { 41 | Vi <- exp(eta.tw) * P * sum(wk * exp(tt)) 42 | - Vi^sigma.t.new 43 | } else if (method == "spline-PH-GH") { 44 | W2s <- if (length(kn <- object$control$knots) == 1) { 45 | splineDesign(unlist(kn, use.names = FALSE), st, 46 | ord = object$control$ord, outer.ok = TRUE) 47 | } else { 48 | strt.i <- strt[ii] 49 | w2s <- lapply(kn, function (kn) 50 | splineDesign(kn, st, ord = object$control$ord, outer.ok = TRUE)) 51 | ll <- match(strt.i, names(w2s)) 52 | w2s[-ll] <- lapply(w2s[-ll], function (m) {m[, ] <- 0; m}) 53 | do.call(cbind, w2s) 54 | } 55 | Vi <- exp(c(W2s %*% gammas.bs.new) + tt) 56 | idT <- rep(seq_along(P), each = object$control$GKk) 57 | - sum(exp(eta.tw) * P * tapply(wk * Vi, idT, sum)) 58 | } else if (method == "piecewise-PH-GH") { 59 | P <- P[!is.na(P)] 60 | kn <- length(object$control$knots) 61 | ind.K <- rep(seq_len(ind), each = kn) 62 | wk <- rep(wk, ind) 63 | wkP <- wk * rep(P, each = kn) 64 | eta.tw <- if (!is.null(W)) as.vector(W[i, , drop = FALSE] %*% gammas.new) else 0 65 | - exp(eta.tw) * sum(xi.new[ind.K] * wkP * exp(tt)) 66 | } 67 | log.p.yb + log.survival + log.p.b 68 | } 69 | -------------------------------------------------------------------------------- /R/logLik.flexCPH.R: -------------------------------------------------------------------------------- 1 | logLik.flexCPH <- 2 | function (object, ...) { 3 | out <- object$logLik 4 | attr(out, "df") <- length(unlist(object$coefficients)) 5 | attr(out, "nobs") <- length(object$d) 6 | class(out) <- "logLik" 7 | out 8 | } 9 | -------------------------------------------------------------------------------- /R/logLik.jointModel.R: -------------------------------------------------------------------------------- 1 | logLik.jointModel <- 2 | function (object, ...) { 3 | if (!inherits(object, "jointModel")) 4 | stop("Use only with 'jointModel' objects.\n") 5 | out <- object$logLik 6 | attr(out, "df") <- nrow(object$Hessian) 7 | attr(out, "nobs") <- object$n 8 | class(out) <- "logLik" 9 | out 10 | } 11 | -------------------------------------------------------------------------------- /R/logLik.weibull.frailty.R: -------------------------------------------------------------------------------- 1 | logLik.weibull.frailty <- 2 | function (object, ...) { 3 | out <- object$logLik 4 | attr(out, "df") <- length(unlist(object$coefficients)) 5 | attr(out, "nobs") <- length(unique(object$id)) 6 | class(out) <- "logLik" 7 | out 8 | } 9 | -------------------------------------------------------------------------------- /R/makepredictcall.dbs.R: -------------------------------------------------------------------------------- 1 | makepredictcall.dbs <- 2 | function (var, call) { 3 | if (as.character(call)[1L] != "dbs") 4 | return(call) 5 | at <- attributes(var)[c("knots", "Boundary.knots", "intercept", "eps")] 6 | xxx <- call[1L:2L] 7 | xxx[names(at)] <- at 8 | xxx 9 | } 10 | -------------------------------------------------------------------------------- /R/makepredictcall.dns.R: -------------------------------------------------------------------------------- 1 | makepredictcall.dns <- 2 | function (var, call) { 3 | if (as.character(call)[1L] != "dns") 4 | return(call) 5 | at <- attributes(var)[c("knots", "Boundary.knots", "intercept", "eps")] 6 | xxx <- call[1L:2L] 7 | xxx[names(at)] <- at 8 | xxx 9 | } 10 | -------------------------------------------------------------------------------- /R/makepredictcall.ibs.R: -------------------------------------------------------------------------------- 1 | makepredictcall.ibs <- 2 | function (var, call) { 3 | if (as.character(call)[1L] != "ibs") 4 | return(call) 5 | at <- attributes(var)[c("knots", "Boundary.knots", "intercept", "from", "weight.fun")] 6 | xxx <- call[1L:2L] 7 | xxx[names(at)] <- at 8 | xxx 9 | } 10 | -------------------------------------------------------------------------------- /R/makepredictcall.ins.R: -------------------------------------------------------------------------------- 1 | makepredictcall.ins <- 2 | function (var, call) { 3 | if (as.character(call)[1L] != "ins") 4 | return(call) 5 | at <- attributes(var)[c("knots", "Boundary.knots", "intercept", "from", "weight.fun")] 6 | xxx <- call[1L:2L] 7 | xxx[names(at)] <- at 8 | xxx 9 | } 10 | -------------------------------------------------------------------------------- /R/nearPD.R: -------------------------------------------------------------------------------- 1 | nearPD <- 2 | function (M, eig.tol = 1e-06, conv.tol = 1e-07, posd.tol = 1e-08, maxits = 100) { 3 | # based on function nearcor() submitted to R-help by Jens Oehlschlagel on 2007-07-13, and 4 | # function posdefify() from package `sfsmisc' 5 | if (!(is.numeric(M) && is.matrix(M) && identical(M, t(M)))) 6 | stop("Input matrix M must be square and symmetric.\n") 7 | inorm <- function (x) max(rowSums(abs(x))) 8 | n <- ncol(M) 9 | U <- matrix(0, n, n) 10 | X <- M 11 | iter <- 0 12 | converged <- FALSE 13 | while (iter < maxits && !converged) { 14 | Y <- X 15 | T <- Y - U 16 | e <- eigen(Y, symmetric = TRUE) 17 | Q <- e$vectors 18 | d <- e$values 19 | D <- if (length(d) > 1) diag(d) else as.matrix(d) 20 | p <- (d > eig.tol * d[1]) 21 | QQ <- Q[, p, drop = FALSE] 22 | X <- QQ %*% D[p, p, drop = FALSE] %*% t(QQ) 23 | U <- X - T 24 | X <- (X + t(X)) / 2 25 | conv <- inorm(Y - X) / inorm(Y) 26 | iter <- iter + 1 27 | converged <- conv <= conv.tol 28 | } 29 | X <- (X + t(X)) / 2 30 | e <- eigen(X, symmetric = TRUE) 31 | d <- e$values 32 | Eps <- posd.tol * abs(d[1]) 33 | if (d[n] < Eps) { 34 | d[d < Eps] <- Eps 35 | Q <- e$vectors 36 | o.diag <- diag(X) 37 | X <- Q %*% (d * t(Q)) 38 | D <- sqrt(pmax(Eps, o.diag) / diag(X)) 39 | X[] <- D * X * rep(D, each = n) 40 | } 41 | (X + t(X)) / 2 42 | } 43 | -------------------------------------------------------------------------------- /R/opt.longAFTWB.R: -------------------------------------------------------------------------------- 1 | opt.longAFTWB <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Y <- as.vector(Xtime %*% betas) + Ztime.b 6 | Ys <- as.vector(Xs %*% betas) + Zsb 7 | WintF.vl.alph <- c(WintF.vl %*% alpha) 8 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 9 | eta.t <- eta.tw + WintF.vl.alph * Y 10 | eta.s <- Ws.intF.vl.alph * Ys 11 | } 12 | if (parameterization %in% c("slope", "both")) { 13 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 14 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 15 | WintF.sl.alph <- c(WintF.sl %*% Dalpha) 16 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 17 | eta.t <- if (parameterization == "both") 18 | eta.t + WintF.sl.alph * Y.deriv 19 | else 20 | eta.tw + WintF.sl.alph * Y.deriv 21 | eta.s <- if (parameterization == "both") 22 | eta.s + Ws.intF.sl.alph * Ys.deriv 23 | else 24 | Ws.intF.sl.alph * Ys.deriv 25 | } 26 | mu.y <- eta.yx + Ztb 27 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 28 | log.p.yb <- rowsum(logNorm, id) 29 | Vi <- exp(eta.tw) * P * rowsum(wk * exp(eta.s), id.GK, reorder = FALSE); dimnames(Vi) <- NULL 30 | log.hazard <- log(sigma.t) + (sigma.t - 1) * log(Vi) + eta.t 31 | log.survival <- - Vi^sigma.t 32 | log.p.tb <- d * log.hazard + log.survival 33 | p.bytn <- p.byt * (log.p.yb + log.p.tb) 34 | -sum(p.bytn %*% wGH, na.rm = TRUE) 35 | } 36 | -------------------------------------------------------------------------------- /R/opt.longPC.R: -------------------------------------------------------------------------------- 1 | opt.longPC <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Y <- as.vector(Xtime %*% betas) + Ztime.b 6 | Ys <- as.vector(Xs %*% betas) + Zsb 7 | eta.t <- eta.tw + c(WintF.vl %*% alpha) * Y 8 | eta.s <- c(Ws.intF.vl %*% alpha) * Ys 9 | } 10 | if (parameterization %in% c("slope", "both")) { 11 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 12 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 13 | eta.t <- if (parameterization == "both") 14 | eta.t + c(WintF.sl %*% Dalpha) * Y.deriv 15 | else 16 | eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv 17 | eta.s <- if (parameterization == "both") 18 | eta.s + c(Ws.intF.sl %*% Dalpha) * Ys.deriv 19 | else 20 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv 21 | } 22 | mu.y <- eta.yx + Ztb 23 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 24 | log.p.yb <- rowsum(logNorm, id) 25 | log.hazard <- log(xi[ind.D]) + eta.t 26 | log.survival <- - exp(eta.tw) * rowsum(xi[ind.K] * wkP * exp(eta.s), id.GK, reorder = FALSE) 27 | dimnames(log.survival) <- NULL 28 | log.p.tb <- d * log.hazard + log.survival 29 | p.bytn <- p.byt * (log.p.yb + log.p.tb) 30 | -sum(p.bytn %*% wGH, na.rm = TRUE) 31 | } 32 | -------------------------------------------------------------------------------- /R/opt.longPH.R: -------------------------------------------------------------------------------- 1 | opt.longPH <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | eta.yxT <- as.vector(Xtime %*% betas) 5 | eta.yxT2 <- as.vector(Xtime2 %*% betas) 6 | Y <- eta.yxT + Ztime.b 7 | Y2 <- eta.yxT2 + Ztime2.b 8 | eta.t <- eta.tw + alpha * Y 9 | eta.s <- alpha * Y2 10 | mu.y <- eta.yx + Ztb 11 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 12 | log.p.yb <- rowsum(logNorm, id); dimnames(log.p.yb) <- NULL 13 | log.lambda0T <- log(lambda0[ind.T0]) 14 | log.lambda0T[is.na(log.lambda0T)] <- 0 15 | log.hazard <- log.lambda0T + eta.t 16 | S <- matrix(0, n, k) 17 | S[unq.indT, ] <- rowsum(lambda0[ind.L1] * exp(eta.s), indT, reorder = FALSE) 18 | log.survival <- - exp(eta.tw) * S 19 | log.p.tb <- d * log.hazard + log.survival 20 | p.bytn <- p.byt * (log.p.yb + log.p.tb) 21 | -sum(p.bytn %*% wGH, na.rm = TRUE) 22 | } 23 | -------------------------------------------------------------------------------- /R/opt.longSplinePH.R: -------------------------------------------------------------------------------- 1 | opt.longSplinePH <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Y <- as.vector(Xtime %*% betas) + Ztime.b 6 | Ys <- as.vector(Xs %*% betas) + Zsb 7 | WintF.vl.alph <- c(WintF.vl %*% alpha) 8 | Ws.intF.vl.alph <- c(Ws.intF.vl %*% alpha) 9 | eta.t <- eta.tw2 + eta.tw1 + WintF.vl.alph * Y 10 | eta.s <- Ws.intF.vl.alph * Ys 11 | } 12 | if (parameterization %in% c("slope", "both")) { 13 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 14 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 15 | WintF.sl.alph <- c(WintF.sl %*% Dalpha) 16 | Ws.intF.sl.alph <- c(Ws.intF.sl %*% Dalpha) 17 | eta.t <- if (parameterization == "both") 18 | eta.t + WintF.sl.alph * Y.deriv 19 | else 20 | eta.tw2 + eta.tw1 + WintF.sl.alph * Y.deriv 21 | eta.s <- if (parameterization == "both") 22 | eta.s + Ws.intF.sl.alph * Ys.deriv 23 | else 24 | Ws.intF.sl.alph * Ys.deriv 25 | } 26 | mu.y <- eta.yx + Ztb 27 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 28 | log.p.yb <- rowsum(logNorm, id) 29 | log.hazard <- eta.t 30 | log.survival <- - exp(eta.tw1) * P * rowsum(wk * exp(eta.ws + eta.s), 31 | id.GK, reorder = FALSE) 32 | log.p.tb <- rowsum(d * log.hazard + log.survival, idT, reorder = FALSE) 33 | p.bytn <- p.byt * (log.p.yb + log.p.tb) 34 | -sum(p.bytn %*% wGH, na.rm = TRUE) 35 | } 36 | -------------------------------------------------------------------------------- /R/opt.longWB.R: -------------------------------------------------------------------------------- 1 | opt.longWB <- 2 | function (betas) { 3 | eta.yx <- as.vector(X %*% betas) 4 | if (parameterization %in% c("value", "both")) { 5 | Y <- as.vector(Xtime %*% betas) + Ztime.b 6 | Ys <- as.vector(Xs %*% betas) + Zsb 7 | eta.t <- eta.tw + c(WintF.vl %*% alpha) * Y 8 | eta.s <- c(Ws.intF.vl %*% alpha) * Ys 9 | } 10 | if (parameterization %in% c("slope", "both")) { 11 | Y.deriv <- as.vector(Xtime.deriv %*% betas[indFixed]) + Ztime.b.deriv 12 | Ys.deriv <- as.vector(Xs.deriv %*% betas[indFixed]) + Zsb.deriv 13 | eta.t <- if (parameterization == "both") 14 | eta.t + c(WintF.sl %*% Dalpha) * Y.deriv 15 | else 16 | eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv 17 | eta.s <- if (parameterization == "both") 18 | eta.s + c(Ws.intF.sl %*% Dalpha) * Ys.deriv 19 | else 20 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv 21 | } 22 | mu.y <- eta.yx + Ztb 23 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 24 | log.p.yb <- rowsum(logNorm, id) 25 | log.hazard <- log(sigma.t) + (sigma.t - 1) * logT + eta.t 26 | log.survival <- - exp(eta.tw) * P * rowsum(wk * exp(log(sigma.t) + (sigma.t - 1) * log.st + eta.s), id.GK, reorder = FALSE) 27 | log.p.tb <- d * log.hazard + log.survival 28 | p.bytn <- p.byt * (log.p.yb + log.p.tb) 29 | -sum(p.bytn %*% wGH, na.rm = TRUE) 30 | } 31 | -------------------------------------------------------------------------------- /R/opt.survAFTWB.R: -------------------------------------------------------------------------------- 1 | opt.survAFTWB <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | sigma.t <- if (is.null(scaleWB)) exp(thetas$log.sigma.t) else scaleWB 8 | eta.tw <- as.vector(WW %*% gammas) 9 | eta.t <- switch(parameterization, 10 | "value" = eta.tw + c(WintF.vl %*% alpha) * Y, 11 | "slope" = eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv, 12 | "both" = eta.tw + c(WintF.vl %*% alpha) * Y + c(WintF.sl %*% Dalpha) * Y.deriv) 13 | eta.s <- switch(parameterization, 14 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 15 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 16 | "both" = c(Ws.intF.vl %*% alpha) * Ys + c(Ws.intF.sl %*% Dalpha) * Ys.deriv) 17 | Vi <- exp(eta.tw) * P * rowsum(wk * exp(eta.s), id.GK, reorder = FALSE); dimnames(Vi) <- NULL 18 | log.hazard <- log(sigma.t) + (sigma.t - 1) * log(Vi) + eta.t 19 | log.survival <- - Vi^sigma.t 20 | log.p.tb <- d * log.hazard + log.survival 21 | p.bytn <- p.byt * log.p.tb 22 | -sum(p.bytn %*% wGH, na.rm = TRUE) 23 | } 24 | -------------------------------------------------------------------------------- /R/opt.survPC.R: -------------------------------------------------------------------------------- 1 | opt.survPC <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | xi <- exp(thetas$log.xi) 8 | eta.tw <- if (!is.null(WW)) as.vector(WW %*% gammas) else 0 9 | eta.t <- switch(parameterization, 10 | "value" = eta.tw + c(WintF.vl %*% alpha) * Y, 11 | "slope" = eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv, 12 | "both" = eta.tw + c(WintF.vl %*% alpha) * Y + c(WintF.sl %*% Dalpha) * Y.deriv) 13 | eta.s <- switch(parameterization, 14 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 15 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 16 | "both" = c(Ws.intF.vl %*% alpha) * Ys + c(Ws.intF.sl %*% Dalpha) * Ys.deriv) 17 | log.hazard <- log(xi[ind.D]) + eta.t 18 | log.survival <- - exp(eta.tw) * rowsum(xi[ind.K] * wkP * exp(eta.s), id.GK, reorder = FALSE) 19 | dimnames(log.survival) <- NULL 20 | log.p.tb <- d * log.hazard + log.survival 21 | p.bytn <- p.byt * log.p.tb 22 | -sum(p.bytn %*% wGH, na.rm = TRUE) 23 | } 24 | -------------------------------------------------------------------------------- /R/opt.survPH.R: -------------------------------------------------------------------------------- 1 | opt.survPH <- 2 | function (thetas) { 3 | gammas <- thetas[seq_len(ncww)] 4 | alpha <- thetas[ncww + 1] 5 | eta.tw <- if (!is.null(WW)) as.vector(WW %*% gammas) else rep(0, n) 6 | eta.t <- eta.tw + alpha * Y 7 | eta.s <- alpha * Y2 8 | exp.eta.s <- exp(eta.s) 9 | log.lambda0T <- log(lambda0[ind.T0]) 10 | log.lambda0T[is.na(log.lambda0T)] <- 0 11 | log.hazard <- log.lambda0T + eta.t 12 | S <- matrix(0, n, k) 13 | S[unq.indT, ] <- rowsum(lambda0[ind.L1] * exp.eta.s, indT) 14 | log.survival <- - exp(eta.tw) * S 15 | log.p.tb <- d * log.hazard + log.survival 16 | p.bytn <- p.byt * log.p.tb 17 | -sum(p.bytn %*% wGH, na.rm = TRUE) 18 | } 19 | -------------------------------------------------------------------------------- /R/opt.survSplinePH.R: -------------------------------------------------------------------------------- 1 | opt.survSplinePH <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | gammas.bs <- thetas$gammas.bs 8 | eta.tw1 <- if (!is.null(W1)) as.vector(W1 %*% gammas) else rep(0, n) 9 | eta.tw2 <- as.vector(W2 %*% gammas.bs) 10 | eta.t <- switch(parameterization, 11 | "value" = eta.tw2 + eta.tw1 + c(WintF.vl %*% alpha) * Y, 12 | "slope" = eta.tw2 + eta.tw1 + c(WintF.sl %*% Dalpha) * Y.deriv, 13 | "both" = eta.tw2 + eta.tw1 + c(WintF.vl %*% alpha) * Y + 14 | c(WintF.sl %*% Dalpha) * Y.deriv) 15 | eta.s <- switch(parameterization, 16 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 17 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 18 | "both" = c(Ws.intF.vl %*% alpha) * Ys + 19 | c(Ws.intF.sl %*% Dalpha) * Ys.deriv) 20 | eta.ws <- as.vector(W2s %*% gammas.bs) 21 | log.hazard <- eta.t 22 | log.survival <- - exp(eta.tw1) * P * rowsum(wk * exp(eta.ws + eta.s), 23 | id.GK, reorder = FALSE) 24 | dimnames(log.survival) <- NULL 25 | log.p.tb <- rowsum(d * log.hazard + log.survival, idT, reorder = FALSE) 26 | p.bytn <- p.byt * log.p.tb 27 | -sum(p.bytn %*% wGH, na.rm = TRUE) 28 | } 29 | -------------------------------------------------------------------------------- /R/opt.survWB.R: -------------------------------------------------------------------------------- 1 | opt.survWB <- 2 | function (thetas) { 3 | thetas <- relist(thetas, skeleton = list.thetas) 4 | gammas <- thetas$gammas 5 | alpha <- thetas$alpha 6 | Dalpha <- thetas$Dalpha 7 | sigma.t <- if (is.null(scaleWB)) exp(thetas$log.sigma.t) else scaleWB 8 | eta.tw <- as.vector(WW %*% gammas) 9 | eta.t <- switch(parameterization, 10 | "value" = eta.tw + c(WintF.vl %*% alpha) * Y, 11 | "slope" = eta.tw + c(WintF.sl %*% Dalpha) * Y.deriv, 12 | "both" = eta.tw + c(WintF.vl %*% alpha) * Y + c(WintF.sl %*% Dalpha) * Y.deriv) 13 | eta.s <- switch(parameterization, 14 | "value" = c(Ws.intF.vl %*% alpha) * Ys, 15 | "slope" = c(Ws.intF.sl %*% Dalpha) * Ys.deriv, 16 | "both" = c(Ws.intF.vl %*% alpha) * Ys + c(Ws.intF.sl %*% Dalpha) * Ys.deriv) 17 | log.hazard <- log(sigma.t) + (sigma.t - 1) * logT + eta.t 18 | log.survival <- - exp(eta.tw) * P * rowsum(wk * exp(log(sigma.t) + 19 | (sigma.t - 1) * log.st + eta.s), id.GK, reorder = FALSE) 20 | dimnames(log.survival) <- NULL 21 | log.p.tb <- d * log.hazard + log.survival 22 | p.bytn <- p.byt * log.p.tb 23 | -sum(p.bytn %*% wGH, na.rm = TRUE) 24 | } 25 | -------------------------------------------------------------------------------- /R/piecewiseExp.ph.R: -------------------------------------------------------------------------------- 1 | piecewiseExp.ph <- 2 | function (coxObject, knots = NULL, length.knots = 6) { 3 | Time <- coxObject$y[, 1] 4 | d <- coxObject$y[, 2] 5 | n <- length(Time) 6 | if (is.null(knots)) { 7 | Q <- length.knots + 1 8 | knots <- unique(quantile(Time, seq(0, 1, len = Q + 1), names = FALSE)[-c(1, Q + 1)]) 9 | knots <- knots + 1e-06 10 | if (max(knots) > max(Time)) 11 | knots[which.max(knots)] <- max(Time) - 1e-06 12 | } 13 | knots <- c(0, sort(knots), max(Time) + 1) 14 | Q <- length(knots) - 1 15 | ind <- findInterval(Time, knots, rightmost.closed = TRUE) 16 | D <- matrix(0, n, Q) 17 | D[cbind(seq_along(ind), ind)] <- 1 18 | D <- c(D * d) 19 | Tiq <- outer(Time, knots, pmin) 20 | T <- c(Tiq[, 2:(Q+1)] - Tiq[, 1:Q]) 21 | X <- coxObject$x[rep(seq_len(n), Q), ] 22 | ND <- suppressWarnings(data.frame(Time = T, D = D, X, xi = gl(Q, n), 23 | check.names = FALSE)[T > 0, ]) 24 | glm(D ~ . + offset(log(Time)) - Time - 1, 25 | family = poisson, data = ND) 26 | } 27 | -------------------------------------------------------------------------------- /R/plot.flexCPH.R: -------------------------------------------------------------------------------- 1 | plot.flexCPH <- 2 | function (x, scale = c("survival", "cumHazard", "log-cumHazard"), survTimes = NULL, X = NULL, 3 | xlab, lab, ylab, main, type, plot.it = TRUE, ...) { 4 | scale <- match.arg(scale) 5 | if (is.null(X)) 6 | X <- x$X 7 | if (is.null(survTimes)) 8 | survTimes <- seq(min(x$logT), max(x$logT), length.out = 51) 9 | W <- splineDesign(x$knots, survTimes, ord = x$control$ord) 10 | eta.w <- c(W %*% x$coefficients$gammas) 11 | eta.x <- c(X %*% x$coefficients$betas) 12 | eta <- outer(eta.x, eta.w, "+") 13 | fit <- switch(scale, 14 | "survival" = exp(- exp(eta)), 15 | "cumHazard" = exp(eta), 16 | "log-cumHazard" = eta) 17 | fit <- colMeans(fit) 18 | if (plot.it) { 19 | if (missing(xlab)) 20 | xlab <- "Time" 21 | if (missing(ylab)) 22 | ylab <- switch(scale, 23 | "survival" = "Survival", 24 | "cumHazard" = "Cumulative Hazard", 25 | "log-cumHazard" = "log Cumulative Hazard") 26 | if (missing(main)) 27 | main <- "" 28 | if (missing(type)) 29 | type <- "l" 30 | plot(survTimes, fit, xlab = xlab, ylab = ylab, main = main, type = type, ...) 31 | } 32 | invisible(cbind(survTimes = exp(survTimes), fit = fit)) 33 | } 34 | -------------------------------------------------------------------------------- /R/prederrJM.R: -------------------------------------------------------------------------------- 1 | prederrJM <- 2 | function (object, newdata, Tstart, Thoriz, ...) { 3 | UseMethod("prederrJM") 4 | } 5 | -------------------------------------------------------------------------------- /R/prederrJM.coxph.R: -------------------------------------------------------------------------------- 1 | prederrJM.coxph <- 2 | function (object, newdata, Tstart, Thoriz, lossFun = c("absolute", "square"), 3 | interval = FALSE, idVar = "id", timeVar = "time", respVar = "y", 4 | evTimeVar = "Time", summary = c("value", "slope", "area"), 5 | tranfFun = function (x) x, ...) { 6 | if (!inherits(object, "coxph")) 7 | stop("Use only with 'coxph' objects.\n") 8 | if (!is.data.frame(newdata) || nrow(newdata) == 0) 9 | stop("'newdata' must be a data.frame with more than one rows.\n") 10 | if (is.null(newdata[[idVar]])) 11 | stop("'idVar' not in 'newdata'.\n") 12 | lossFun <- if (is.function(lossFun)) { 13 | lf <- lossFun 14 | match.fun(lossFun) 15 | } else { 16 | lf <- match.arg(lossFun) 17 | if (lf == "absolute") function (x) abs(x) else function (x) x*x 18 | } 19 | summary <- match.arg(summary) 20 | if (summary %in% c("slope", "area")) 21 | newdata$area <- newdata$slope <- 0 22 | id <- newdata[[idVar]] 23 | id <- match(id, unique(id)) 24 | TermsT <- object$terms 25 | SurvT <- model.response(model.frame(TermsT, newdata)) 26 | Time <- SurvT[, 1] 27 | newdata2 <- dataLM(newdata, Tstart, idVar, respVar, timeVar, evTimeVar, summary, 28 | tranfFun) 29 | SurvT <- model.response(model.frame(TermsT, newdata2)) 30 | Time <- SurvT[, 1] 31 | delta <- SurvT[, 2] 32 | indCens <- Time < Thoriz & delta == 0 33 | nr <- nrow(newdata2) 34 | aliveThoriz.id <- newdata2[Time > Thoriz, ] 35 | Surv.aliveThoriz <- c(summary(survfit(object, newdata = aliveThoriz.id), times = Thoriz)$surv) 36 | deadThoriz.id <- newdata2[Time <= Thoriz & delta == 1, ] 37 | Surv.deadThoriz <- c(summary(survfit(object, newdata = deadThoriz.id), times = Thoriz)$surv) 38 | if (sum(indCens) > 1) { 39 | censThoriz.id <- newdata2[indCens, ] 40 | Surv.censThoriz <- c(summary(survfit(object, newdata = censThoriz.id), times = Thoriz)$surv) 41 | tt <- model.response(model.frame(TermsT, censThoriz.id))[, 1] 42 | nn <- length(tt) 43 | weights <- numeric(nn) 44 | for (i in seq_len(nn)) { 45 | weights[i] <- c(summary(survfit(object, newdata = censThoriz.id[i, ]), times = Thoriz)$surv) / 46 | c(summary(survfit(object, newdata = censThoriz.id[i, ]), times = tt[i])$surv) 47 | } 48 | } else { 49 | Surv.censThoriz <- weights <- NA 50 | } 51 | prederr <- if (!interval) { 52 | (1/nr) * sum(lossFun(1 - Surv.aliveThoriz), lossFun(0 - Surv.deadThoriz), 53 | weights * lossFun(1 - Surv.censThoriz) + (1 - weights) * lossFun(0 - Surv.censThoriz)) 54 | } else { 55 | TimeCens <- model.response(model.frame(TermsT, newdata))[, 1] 56 | deltaCens <- 1 - model.response(model.frame(TermsT, newdata))[, 2] 57 | KMcens <- survfit(Surv(TimeCens, deltaCens) ~ 1) 58 | times <- TimeCens[TimeCens > Tstart & TimeCens <= Thoriz & !deltaCens] 59 | times <- sort(unique(times)) 60 | k <- as.numeric(table(times)) 61 | w <- summary(KMcens, times = Tstart)$surv / summary(KMcens, times = times)$surv 62 | prederr.times <- sapply(times, 63 | function (t) prederrJM(object, newdata, Tstart, t, 64 | interval = FALSE, idVar = idVar, timeVar = timeVar, 65 | respVar = respVar, evTimeVar = evTimeVar, 66 | summary = summary, tranfFun = tranfFun)$prederr) 67 | num <- sum(prederr.times * w * k, na.rm = TRUE) 68 | den <- sum(w * k, na.rm = TRUE) 69 | num / den 70 | } 71 | out <- list(prederr = prederr, nr = nr, Tstart = Tstart, Thoriz = Thoriz, interval = interval, 72 | classObject = class(object), nameObject = deparse(substitute(object)), lossFun = lf) 73 | class(out) <- "prederrJM" 74 | out 75 | } 76 | -------------------------------------------------------------------------------- /R/prederrJM.jointModel.R: -------------------------------------------------------------------------------- 1 | prederrJM.jointModel <- 2 | function (object, newdata, Tstart, Thoriz, lossFun = c("absolute", "square"), 3 | interval = FALSE, idVar = "id", simulate = FALSE, M = 100, ...) { 4 | if (!inherits(object, "jointModel")) 5 | stop("Use only with 'jointModel' objects.\n") 6 | if (!is.data.frame(newdata) || nrow(newdata) == 0) 7 | stop("'newdata' must be a data.frame with more than one rows.\n") 8 | if (is.null(newdata[[idVar]])) 9 | stop("'idVar' not in 'newdata.\n'") 10 | lossFun <- if (is.function(lossFun)) { 11 | lf <- lossFun 12 | match.fun(lossFun) 13 | } else { 14 | lf <- match.arg(lossFun) 15 | if (lf == "absolute") function (x) abs(x) else function (x) x*x 16 | } 17 | id <- newdata[[idVar]] 18 | id <- match(id, unique(id)) 19 | TermsT <- object$termsT 20 | SurvT <- model.response(model.frame(TermsT, newdata)) 21 | Time <- SurvT[, 1] 22 | timeVar <- object$timeVar 23 | newdata2 <- newdata[Time > Tstart, ] 24 | SurvT <- model.response(model.frame(TermsT, newdata2)) 25 | Time <- SurvT[, 1] 26 | delta <- SurvT[, 2] 27 | aliveThoriz <- newdata2[Time > Thoriz & newdata2[[timeVar]] <= Tstart, ] 28 | deadThoriz <- newdata2[Time <= Thoriz & delta == 1 & newdata2[[timeVar]] <= Tstart, ] 29 | indCens <- Time < Thoriz & delta == 0 & newdata2[[timeVar]] <= Tstart 30 | censThoriz <- newdata2[indCens, ] 31 | nr <- length(unique(newdata2[[idVar]])) 32 | idalive <- unique(aliveThoriz[[idVar]]) 33 | iddead <- unique(deadThoriz[[idVar]]) 34 | idcens <- unique(censThoriz[[idVar]]) 35 | Surv.aliveThoriz <- survfitJM(object, newdata = aliveThoriz, idVar = idVar, simulate = simulate, M = M, 36 | survTimes = Thoriz, last.time = rep(Tstart, length(idalive))) 37 | Surv.deadThoriz <- survfitJM(object, newdata = deadThoriz, idVar = idVar, simulate = simulate, 38 | survTimes = Thoriz, last.time = rep(Tstart, length(iddead))) 39 | Surv.aliveThoriz <- sapply(Surv.aliveThoriz$summaries, "[", 2) 40 | Surv.deadThoriz <- sapply(Surv.deadThoriz$summaries, "[", 2) 41 | if (nrow(censThoriz)) { 42 | Surv.censThoriz <- survfitJM(object, newdata = censThoriz, idVar = idVar, simulate = simulate, M = M, 43 | survTimes = Thoriz, last.time = rep(Tstart, length(idcens))) 44 | tt <- Time[indCens] 45 | weights <- survfitJM(object, newdata = censThoriz, idVar = idVar, simulate = simulate, M = M, 46 | survTimes = Thoriz, last.time = tt[!duplicated(censThoriz[[idVar]])]) 47 | Surv.censThoriz <- sapply(Surv.censThoriz$summaries, "[", 2) 48 | weights <- sapply(weights$summaries, "[", 2) 49 | } else { 50 | Surv.censThoriz <- weights <- NA 51 | } 52 | prederr <- if (!interval) { 53 | (1/nr) * sum(lossFun(1 - Surv.aliveThoriz), lossFun(0 - Surv.deadThoriz), 54 | weights * lossFun(1 - Surv.censThoriz) + (1 - weights) * lossFun(0 - Surv.censThoriz)) 55 | } else { 56 | TimeCens <- exp(object$y$logT) 57 | deltaCens <- 1 - object$y$event 58 | KMcens <- survfit(Surv(TimeCens, deltaCens) ~ 1) 59 | times <- TimeCens[TimeCens > Tstart & TimeCens < Thoriz & !deltaCens] 60 | times <- sort(unique(times)) 61 | k <- as.numeric(table(times)) 62 | w <- summary(KMcens, times = Tstart)$surv / summary(KMcens, times = times)$surv 63 | prederr.times <- sapply(times, 64 | function (t) prederrJM(object, newdata, Tstart, t, 65 | interval = FALSE, idVar = idVar, simulate = simulate)$prederr) 66 | num <- sum(prederr.times * w * k, na.rm = TRUE) 67 | den <- sum(w * k, na.rm = TRUE) 68 | num / den 69 | } 70 | out <- list(prederr = prederr, nr = nr, Tstart = Tstart, Thoriz = Thoriz, interval = interval, 71 | classObject = class(object), nameObject = deparse(substitute(object)), lossFun = lf) 72 | class(out) <- "prederrJM" 73 | out 74 | } 75 | -------------------------------------------------------------------------------- /R/predict.b.R: -------------------------------------------------------------------------------- 1 | predict.b <- 2 | function (method, y, X, Xtime, Z, Ztime, betas, sigma, Time, W1, gammas, alpha, sigma.t, D, 3 | id, control, knots) { 4 | WW <- if (method == "Cox-PH-GH") { 5 | NA 6 | } else if (method == "weibull-GH") { 7 | if (is.null(W1)) as.matrix(rep(1, length(Time))) else cbind(1, W1) 8 | } else { 9 | logT <- log(Time) 10 | W2 <- splineDesign(knots, logT, ord = control$ord) 11 | S <- splineDesign(knots[-c(1, length(knots))], logT, ord = control$ord - 1) 12 | S <- control$ord * S / rep(diff(knots, lag = control$ord + 1), each = length(Time)) 13 | ncs <- ncol(S) 14 | #SS <- cbind(- S[, 1], S[, 1:(ncs - 1)] - S[, 2:ncs], S[, ncs]) 15 | nk <- ncol(W2) 16 | if (is.null(W1)) cbind(W2) else cbind(W2, W1) 17 | } 18 | ncx <- ncol(X) 19 | ncz <- ncol(Z) 20 | ncww <- ncol(WW) 21 | n <- length(Time) 22 | N <- length(y) 23 | ni <- as.vector(tapply(id, id, length)) 24 | diag.D <- ncz != ncol(D) 25 | out <- if (method %in% c("Cox-PH-GH", "weibull-GH", "ch-GH", "spline-GH-PH")) { 26 | GH <- gauher(control$GHk) 27 | b <- as.matrix(expand.grid(lapply(1:ncz, function (k, u) u$x, u = GH))) 28 | k <- nrow(b) 29 | wGH <- as.matrix(expand.grid(lapply(1:ncz, function (k, u) u$w, u = GH))) 30 | wGH <- 2^(ncz/2) * apply(wGH, 1, prod) * exp(rowSums(b * b)) * control$det.inv.chol.VC 31 | b <- sqrt(2) * t(control$inv.chol.VC %*% t(b)) 32 | b2 <- if (ncz == 1) b * b else t(apply(b, 1, function (x) x %o% x)) 33 | Ztb <- Z %*% t(b) 34 | Ztime.b <- Ztime %*% t(b) 35 | eta.yx <- as.vector(X %*% betas) 36 | eta.yxT <- as.vector(Xtime %*% betas) 37 | eta.tw <- as.vector(WW %*% gammas) 38 | Y <- eta.yxT + Ztime.b 39 | eta.t <- eta.tw + alpha * Y 40 | mu.y <- eta.yx + Ztb 41 | logNorm <- dnorm(y, mu.y, sigma, TRUE) 42 | log.p.yb <- rowsum(logNorm, id) 43 | log.p.tb <- if (method == "ph-GH") { 44 | NA 45 | } else if (method == "weibull-GH") { 46 | w <- (log(Time) - eta.t) / sigma.t 47 | - exp(w) 48 | } else { 49 | - exp(eta.t) 50 | } 51 | log.p.b <- if (ncz == 1) { 52 | dnorm(b, sd = sqrt(D), log = TRUE) 53 | } else { 54 | if (diag.D) { 55 | rowSums(dnorm(b, sd = rep(sqrt(D), each = k), log = TRUE)) 56 | } else { 57 | dmvnorm(b, rep(0, ncz), D, TRUE) 58 | } 59 | } 60 | p.ytb <- exp((log.p.yb + log.p.tb) + rep(log.p.b, each = n)) 61 | dimnames(p.ytb) <- NULL 62 | p.yt <- c(p.ytb %*% wGH) 63 | p.byt <- p.ytb / p.yt 64 | p.byt %*% (b * wGH) 65 | } else { 66 | environment(update.bCH) <- environment(fn.b) <- environment(gr.b) <- environment() 67 | vb <- matrix(0, n, ncz * ncz); cons.logLik <- 0 68 | new.b <- update.bCH(matrix(0, n, ncz), vb, betas, sigma, c(gammas, alpha), D) 69 | attr(new.b, "b") 70 | } 71 | attr(out, "WW") <- WW 72 | out 73 | } 74 | -------------------------------------------------------------------------------- /R/print.aov.jointModel.R: -------------------------------------------------------------------------------- 1 | print.aov.jointModel <- 2 | function (x, ...) { 3 | if (!inherits(x, "aov.jointModel")) 4 | stop("Use only with 'aov.jointModel' objects.\n") 5 | if (is.null(x$L0)) { 6 | f <- function (dat) { 7 | dat[] <- lapply(dat, function (x) 8 | round(unlist(x), 4)) 9 | dat$'Pr(>|Chi|)' <- format.pval(dat$'Pr(>|Chi|)', 10 | eps = 1e-04) 11 | dat 12 | } 13 | cat("\nMarginal Wald Tests Table\n") 14 | if (!is.null(x$aovTab.Y)) { 15 | cat("\nLongitudinal Process\n") 16 | print(f(x$aovTab.Y)) 17 | } 18 | if (!is.null(x$aovTab.T)) { 19 | cat("\nEvent Process\n") 20 | print(f(x$aovTab.T)) 21 | } 22 | if (!is.null(x$aovTab.L)) { 23 | cat("\nUser-defined Contrasts Matrix\n") 24 | print(f(x$aovTab.L)) 25 | } 26 | cat("\n") 27 | } else { 28 | dat <- if (x$test) { 29 | p.val <- round(x$p.value, 4) 30 | p.val <- if (p.val < 0.0001) "<0.0001" else p.val 31 | data.frame(AIC = round(c(x$aic0, x$aic1), 2), 32 | BIC = round(c(x$bic0, x$bic1), 2), 33 | log.Lik = round(c(x$L0, x$L1), 2), 34 | LRT = c(" ", round(x$LRT, 2)), df = c("", x$df), 35 | p.value = c("", p.val), row.names = c(x$nam0, x$nam1)) 36 | } else { 37 | data.frame(AIC = round(c(x$aic0, x$aic1), 2), 38 | BIC = round(c(x$bic0, x$bic1), 2), 39 | log.Lik = round(c(x$L0, x$L1), 2), df = c("", x$df), 40 | row.names = c(x$nam0, x$nam1)) 41 | } 42 | cat("\n") 43 | print(dat) 44 | cat("\n") 45 | } 46 | invisible(x) 47 | } 48 | -------------------------------------------------------------------------------- /R/print.aucJM.R: -------------------------------------------------------------------------------- 1 | print.aucJM <- 2 | function (x, digits = 4, ...) { 3 | if (!inherits(x, "aucJM")) 4 | stop("Use only with 'aucJM' objects.\n") 5 | if (x$class == "JMbayes" || x$class == "jointModel") 6 | cat("\n\tTime-dependent AUC for the Joint Model", x$nameObject) 7 | else 8 | cat("\n\tTime-dependent AUC for the Cox Model", x$nameObject) 9 | cat("\n\nEstimated AUC:", round(x$auc, digits)) 10 | cat("\nAt time:", round(x$Thoriz, digits)) 11 | cat("\nUsing information up to time: ", round(x$Tstart, digits), 12 | " (", x$nr, " subjects still at risk)", sep = "") 13 | cat("\n\n") 14 | invisible(x) 15 | } 16 | -------------------------------------------------------------------------------- /R/print.dynCJM.R: -------------------------------------------------------------------------------- 1 | print.dynCJM <- 2 | function (x, digits = 4, ...) { 3 | if (!inherits(x, "dynCJM")) 4 | stop("Use only with 'dynCJM' objects.\n") 5 | if (x$classObject == "JMbayes") 6 | cat("\n\tDynamic Discrimination Index for the Joint Model", x$nameObject) 7 | else 8 | cat("\n\tDynamic Discrimination Index for the Cox Model", x$nameObject) 9 | cat("\n\nEstimated dynC:", round(x$dynC, digits)) 10 | cat("\nIn the time interval: [0, ", round(x$t.max, digits), "]", sep = "") 11 | cat("\nLength of time interval:", round(x$Dt, digits)) 12 | cat("\n\n") 13 | invisible(x) 14 | } 15 | -------------------------------------------------------------------------------- /R/print.flexCPH.R: -------------------------------------------------------------------------------- 1 | print.flexCPH <- 2 | function (x, digits = max(4, getOption("digits") - 4), ...) { 3 | cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "") 4 | print(lapply(x$coefficients, round, digits = digits)) 5 | cat("\nlog-Lik:", x$logLik, "\n\n") 6 | invisible(x) 7 | } 8 | -------------------------------------------------------------------------------- /R/print.jointModel.R: -------------------------------------------------------------------------------- 1 | print.jointModel <- 2 | function (x, digits = max(4, getOption("digits") - 4), ...) { 3 | if (!inherits(x, "jointModel")) 4 | stop("Use only with 'jointModel' objects.\n") 5 | cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "") 6 | cat("Variance Components:\n") 7 | D <- x$coefficients$D 8 | ncz <- nrow(D) 9 | diag.D <- ncz != ncol(D) 10 | sds <- if (diag.D) sqrt(D) else sqrt(diag(D)) 11 | if (ncz > 1) { 12 | if (diag.D) { 13 | dat <- round(c(D), digits) 14 | names(dat) <- rownames(D) 15 | } else { 16 | corrs <- cov2cor(D) 17 | corrs[upper.tri(corrs, TRUE)] <- 0 18 | mat <- round(cbind(sds, corrs[, -ncz]), digits) 19 | mat <- apply(mat, 2, sprintf, fmt = "% .4f") 20 | mat[mat == mat[1, 2]] <- "" 21 | mat[1, -1] <- abbreviate(colnames(mat)[-1], 6) 22 | colnames(mat) <- c(colnames(mat)[1], rep("", ncz - 1)) 23 | dat <- data.frame(mat, check.rows = FALSE, check.names = FALSE) 24 | names(dat) <- c("StdDev", "Corr", if (ncz > 2) rep(" ", ncz - 2) else NULL) 25 | row.names(dat) <- dimnames(D)[[1]] 26 | } 27 | } else { 28 | dat <- data.frame("StdDev" = sds, row.names = rownames(D), 29 | check.rows = FALSE, check.names = FALSE) 30 | } 31 | lis <- list("Random-Effects" = dat, "Residual" = c("Longitudinal" = x$coefficients$sigma, 32 | "Event" = x$coefficients$sigma.t)) 33 | print(lapply(lis, function (x) if (!is.numeric(x)) x else round(x, digits = digits))) 34 | cat("\nCoefficients:\n") 35 | gammas <- x$coefficients$gammas 36 | if (x$method %in% c("ch-GH", "ch-Laplace")) { 37 | ng <- length(gammas) 38 | nw <- ncol(x$x$W) 39 | gammas <- if (is.null(nw)) NULL else gammas[seq(ng - nw + 1, ng)] 40 | } 41 | gammas <- c(gammas, "Assoct" = as.vector(x$coefficients$alpha), 42 | "Assoct.s" = as.vector(x$coefficients$Dalpha), x$coefficients$xi, 43 | x$coefficients$gammas.bs) 44 | if (x$method == "weibull-AFT-GH") 45 | gammas <- -gammas 46 | jj <- grep("Assoct[!^\\.s]", names(gammas)) 47 | ii <- setdiff(grep("Assoct", names(gammas)), jj) 48 | if (length(ii) > 1) { 49 | nn <- names(x$coefficients$alpha) 50 | names(gammas)[ii] <- if (length(nn) == 1) "Assoct" else { 51 | if (nn[1] == "") 52 | c("Assoct", paste("Assoct", nn[-1], sep = ":")) 53 | else 54 | paste("Assoct", nn, sep = ":") 55 | } 56 | } 57 | if (length(jj) > 1) { 58 | nn <- names(x$coefficients$Dalpha) 59 | names(gammas)[jj] <- if (length(nn) == 1) "Assoct.s" else { 60 | if (nn[1] == "") 61 | c("Assoct.s", paste("Assoct.s", nn[-1], sep = ":")) 62 | else 63 | paste("Assoct.s", nn, sep = ":") 64 | } 65 | } 66 | if ((lag <- x$y$lag) > 0) { 67 | kk <- grep("Assoct", names(gammas), fixed = TRUE) 68 | names(gammas)[kk] <- paste(names(gammas)[kk], "(lag=", lag, ")", sep = "") 69 | } 70 | print(lapply(list("Longitudinal Process" = x$coefficients$betas, "Event Process" = gammas), 71 | round, digits = digits)) 72 | cat("\nlog-Lik:", x$logLik) 73 | cat("\n\n") 74 | invisible(x) 75 | } 76 | -------------------------------------------------------------------------------- /R/print.prederrJM.R: -------------------------------------------------------------------------------- 1 | print.prederrJM <- 2 | function (x, digits = 4, ...) { 3 | if (!inherits(x, "prederrJM")) 4 | stop("Use only with 'prederrJM' objects.\n") 5 | if (x$class == "JMbayes" || x$class == "jointModel") 6 | cat("\nPrediction Error for the Joint Model", x$nameObject) 7 | else 8 | cat("\nPrediction Error for the Cox model", x$nameObject) 9 | cat("\n\nEstimated prediction error:", round(x$prederr, digits)) 10 | if (!x$interval) { 11 | cat("\nAt time:", round(x$Thoriz, digits)) 12 | } else { 13 | cat("\nIn the time interval: [", round(x$Tstart, digits), 14 | ", ", round(x$Thoriz, digits), "]", sep = "") 15 | } 16 | cat("\nUsing information up to time: ", round(x$Tstart, digits), " (", x$nr, " subjects still at risk)", sep = "") 17 | cat("\nLoss function:", if (is.function(x$lossFun)) "user-defined function" else x$lossFun) 18 | cat("\n\n") 19 | invisible(x) 20 | } 21 | -------------------------------------------------------------------------------- /R/print.rocJM.R: -------------------------------------------------------------------------------- 1 | print.rocJM <- 2 | function (x, ...) { 3 | cat("\nAreas under the time-dependent ROC curves\n\n") 4 | cat("Estimation: Monte Carlo (", x$M, " samples)\n", sep = "") 5 | if (x$diffType == "absolute") { 6 | lx <- length(x$abs.diff) 7 | ld <- paste(round(x$abs.diff, 2), collapse = ", ") 8 | } else { 9 | lx <- length(x$rel.diff) 10 | ld <- paste(round(x$rel.diff, 2), collapse = ", ") 11 | } 12 | cat("Difference: ", x$diffType, ", lag = ", lx, 13 | " (", ld,")\n", sep = "") 14 | cat("Thresholds range: (", round(x$min.cc, 2), ", ", 15 | round(x$max.cc, 2), ")\n\n", sep = "") 16 | times <- x$times 17 | aucs <- x$AUCs 18 | for (i in seq_along(times)) { 19 | cat("Case:", names(times)[i], "\n") 20 | cat("Recorded time(s):", paste(round(x$times[[i]], 2), 21 | collapse = ", "), "\n") 22 | ac <- if (is.matrix(aucs)) round(aucs[, i], 4) else 23 | round(aucs[[i]], 4) 24 | thr <- round(x$optThr[[i]], 4) 25 | m <- cbind(x$dt, round(x$dt + 26 | tail(x$times[[i]], 1), 2), ac, thr) 27 | colnames(m) <- if ((nc <- ncol(thr)) == 1) { 28 | c("dt", "t + dt", "AUC", "Cut") 29 | } else { 30 | c("dt", "t + dt", "AUC", 31 | paste("Cut.", 1:nc, sep = "")) 32 | } 33 | rownames(m) <- rep("", nrow(m)) 34 | print(m) 35 | cat("\n") 36 | } 37 | invisible(x) 38 | } 39 | -------------------------------------------------------------------------------- /R/print.summary.flexCPH.R: -------------------------------------------------------------------------------- 1 | print.summary.flexCPH <- 2 | function (x, digits = max(4, getOption("digits") - 4), ...) { 3 | cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "") 4 | cat("Data Descriptives:\n") 5 | pcEv <- round(100 * sum(x$d) / length(x$d), 1) 6 | cat("Number of sample units:", length(x$d), "\n") 7 | cat("Number of Events: ", sum(x$d), " (", pcEv, "%)", sep = "", "\n") 8 | cat("\nModel Summary:\n") 9 | cat("B-spline basis internal knots at: ", 10 | paste(round(exp(x$knots[-c(1, length(x$knots))]), 2), collapse = ", "), "\n\n", sep = "") 11 | model.sum <- data.frame(log.Lik = x$logLik, AIC = x$AIC, BIC = x$BIC, row.names = "") 12 | print(model.sum) 13 | if (!is.null(x$coefTab)) { 14 | cat("\nCoefficients:\n") 15 | out <- as.data.frame(round(x$coefTab, digits)) 16 | ind <- out$"p-value" == 0 17 | out$"p-value" <- sprintf(paste("%.", digits, "f", sep = ""), out$"p-value") 18 | out$"p-value"[ind] <- paste("<0.", paste(rep("0", digits - 1), collapse = ""), "1", sep = "") 19 | print(out) 20 | } 21 | cat("\n\n") 22 | invisible(x) 23 | } 24 | -------------------------------------------------------------------------------- /R/print.summary.weibull.frailty.R: -------------------------------------------------------------------------------- 1 | print.summary.weibull.frailty <- 2 | function (x, digits = max(4, getOption("digits") - 4), ...) { 3 | cat("\n\n\tWeibull Relative Risk Model with Gamma Frailty\n") 4 | cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "") 5 | cat("Data Descriptives:\n") 6 | cat("Number of groups:", length(unique(x$id)), "\n") 7 | cat("Number of observations:", length(x$id), "\n") 8 | cat("Total Number of Events: ", sum(x$d), "\n") 9 | cat("\nModel Summary:\n") 10 | model.sum <- data.frame(log.Lik = x$logLik, AIC = x$AIC, BIC = x$BIC, row.names = "") 11 | print(model.sum) 12 | if (!is.null(x$coefTab)) { 13 | cat("\nCoefficients:\n") 14 | out <- as.data.frame(round(x$coefTab, digits)) 15 | ind <- out$"p-value" == 0 16 | out$"p-value" <- sprintf(paste("%.", digits, "f", sep = ""), out$"p-value") 17 | out$"p-value"[ind] <- paste("<0.", paste(rep("0", digits - 1), collapse = ""), "1", sep = "") 18 | print(out) 19 | } 20 | cat("\nShape:", round(x$shape, digits), "\nScale:", round(x$scale, digits), 21 | "\nFrailty variance:", round(x$var.frailty, digits)) 22 | cat("\n\n") 23 | invisible(x) 24 | } 25 | -------------------------------------------------------------------------------- /R/print.survfitJM.R: -------------------------------------------------------------------------------- 1 | print.survfitJM <- 2 | function (x, ...) { 3 | if (!is.null(x$success.rate)) { 4 | cat("\nPrediction of Conditional Probabilities of Event\n\tbased on", 5 | nrow(x$success.rate), "Monte Carlo samples\n\n") 6 | } else { 7 | cat("\nPrediction of Conditional Probabilities for Events\n\n") 8 | } 9 | f <- function (d, t) { 10 | dd <- d[1, , drop = FALSE] 11 | dd[1, ] <- c(as.vector(t), rep(1, ncol(dd) - 1)) 12 | round(rbind(dd, d), 4) 13 | } 14 | print(mapply(f, x$summaries, x$last.time, SIMPLIFY = FALSE)) 15 | invisible(x) 16 | } 17 | -------------------------------------------------------------------------------- /R/print.wald.strata.R: -------------------------------------------------------------------------------- 1 | print.wald.strata <- 2 | function (x, ...) { 3 | cat("\n\tWald Test for Stratification Factors\n\n") 4 | pval <- x$Result[, "Pr(> X^2)"] 5 | pval <- if (pval < 0.0001) "<0.0001" else formatC(round(pval, 4), format = "fg") 6 | cat("X^2 = ", round(x$Result[, "X^2"], 4), ", df = ", x$Result[, "df"], 7 | ", p-value = ", pval, "\n", sep = "") 8 | cat("alternative hypothesis:", x$alternative, "\n\n") 9 | invisible(x) 10 | } 11 | -------------------------------------------------------------------------------- /R/print.weibull.frailty.R: -------------------------------------------------------------------------------- 1 | print.weibull.frailty <- 2 | function (x, digits = max(4, getOption("digits") - 4), ...) { 3 | cat("\nCall:\n", paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "") 4 | cat("\nFrailty distribution: Gamma") 5 | cat("\nFrailty variance:", round(x$coefficients$var.frailty, digits = digits)) 6 | if (length(x$coefficients$betas)) { 7 | cat("\n\nCoefficients:\n") 8 | print(round(x$coefficients$betas, digits = digits)) 9 | } 10 | cat("\nShape:", round(x$coefficients$shape, digits = digits)) 11 | cat("\nScale:", round(x$coefficients$scale, digits = digits)) 12 | cat("\n\nlog-Lik:", x$logLik, "\n\n") 13 | invisible(x) 14 | } 15 | -------------------------------------------------------------------------------- /R/ranef.jointModel.R: -------------------------------------------------------------------------------- 1 | ranef.jointModel <- 2 | function (object, type = c("mean", "mode"), postVar = FALSE, ...) { 3 | if (!inherits(object, "jointModel")) 4 | stop("Use only with 'jointModel' objects.\n") 5 | type <- match.arg(type) 6 | if (type == "mean") { 7 | out <- as.matrix(object$EB$post.b) 8 | rownames(out) <- if (!object$CompRisk && !object$LongFormat) 9 | names(object$y$logT) 10 | else 11 | seq_len(nrow(out)) 12 | if (postVar) { 13 | n <- nrow(out) 14 | ncz <- ncol(out) 15 | vars <- vector("list", n) 16 | for (i in 1:n) { 17 | vars[[i]] <- matrix(as.matrix(object$EB$post.vb)[i, ], ncz, ncz) 18 | dimnames(vars[[i]]) <- list(colnames(out), colnames(out)) 19 | } 20 | names(vars) <- rownames(out) 21 | attr(out, "postVar") <- vars 22 | } 23 | } else { 24 | mv <- log.posterior.b2(object) 25 | out <- mv$modes 26 | if (postVar) 27 | attr(out, "postVar") <- mv$vars 28 | } 29 | out 30 | } 31 | -------------------------------------------------------------------------------- /R/rmvt.R: -------------------------------------------------------------------------------- 1 | rmvt <- function (n, mu, Sigma, df) { 2 | p <- length(mu) 3 | if (is.list(Sigma)) { 4 | ev <- Sigma$values 5 | evec <- Sigma$vectors 6 | } else { 7 | ed <- eigen(Sigma, symmetric = TRUE) 8 | ev <- ed$values 9 | evec <- ed$vectors 10 | } 11 | X <- drop(mu) + tcrossprod(evec * rep(sqrt(pmax(ev, 0)), each = p), 12 | matrix(rnorm(n * p), n)) / rep(sqrt(rchisq(n, df)/df), each = p) 13 | if (n == 1L) drop(X) else t.default(X) 14 | } 15 | -------------------------------------------------------------------------------- /R/simulate.jointModel.R: -------------------------------------------------------------------------------- 1 | simulate.jointModel <- 2 | function (object, nsim, seed = NULL, times = NULL, Data = NULL, ...) { 3 | thetas <- object$coefficients 4 | n <- object$n 5 | lag <- object$y$lag 6 | if (is.null(Data)) 7 | Data <- object$data.id 8 | if (is.null(times)) 9 | times <- sort(unique(object$times)) 10 | method <- switch(object$method, "weibull-AFT-GH" = "weibull-AFT", 11 | "weibull-PH-GH" = "weibull-PH", "spline-PH-GH" = "spline-PH", 12 | "piecewise-PH-GH" = "piecewise-PH", "Cox-PH-GH" =, 13 | "ch-Laplace" = stop("not available.\n")) 14 | tt <- attr(delete.response(object$termsT), "term.labels") 15 | formulas <- list(Yfixed = reformulate(attr(delete.response(object$termsYx), 16 | "term.labels")), Yrandom = object$formYz, timeVar = object$timeVar, 17 | Tfixed = if (length(tt)) reformulate(tt) else reformulate("1")) 18 | simulateJM(nsim = nsim, nsub = n, thetas = thetas, times = times, 19 | formulas = formulas, Data = Data, method = method, lag = lag, 20 | seed = seed, ...) 21 | } 22 | -------------------------------------------------------------------------------- /R/summary.flexCPH.R: -------------------------------------------------------------------------------- 1 | summary.flexCPH <- 2 | function (object, ...) { 3 | out <- list(logLik = object$logLik, AIC = AIC(object), 4 | BIC = AIC(object, k = log(length(object$d))), d = object$d, knots = unique(object$knots), 5 | call = object$call) 6 | betas <- object$coefficients$betas 7 | gammas <- object$coefficients$gammas 8 | Var <- vcov(object) 9 | ind <- if (length(gammas) == nrow(Var)) NULL else seq(length(gammas) + 1, nrow(Var)) 10 | if (nind <- length(ind)) { 11 | sds <- if (nind == 1) sqrt(Var[ind, ind]) else sqrt(diag(Var[ind, ind])) 12 | out$coefTab <- cbind("value" = betas, "exp(value)" = exp(betas), "std.err" = sds, 13 | "z-value" = betas / sds, "p-value" = 2 * pnorm(abs(betas / sds), lower.tail = FALSE)) 14 | } 15 | class(out) <- "summary.flexCPH" 16 | out 17 | } 18 | -------------------------------------------------------------------------------- /R/summary.weibull.frailty.R: -------------------------------------------------------------------------------- 1 | summary.weibull.frailty <- 2 | function (object, sand.se = FALSE, ...) { 3 | out <- list(logLik = object$logLik, AIC = AIC(object), 4 | BIC = AIC(object, k = log(length(unique(object$id)))), 5 | id = object$id, d = object$y[, 2], call = object$call) 6 | coefs <- object$coefficients$betas 7 | nx <- length(coefs) 8 | ind <- seq_len(nx) 9 | betas <- coefs[ind] 10 | Var <- vcov(object) 11 | if (sand.se) 12 | Var2 <- vcov(object, sand.se = sand.se) 13 | if (nind <- length(ind)) { 14 | sds <- if (nind == 1) sqrt(Var[ind, ind]) else sqrt(diag(Var[ind, ind])) 15 | if (sand.se) { 16 | sds2 <- if (nind == 1) sqrt(Var2[ind, ind]) else sqrt(diag(Var2[ind, ind])) 17 | } 18 | out$coefTab <- if (sand.se) { 19 | cbind("value" = betas, "std.err" = sds, "sand s.e." = sds2, 20 | "z-value" = betas / sds2, 21 | "p-value" = 2 * pnorm(abs(betas / sds2), lower.tail = FALSE)) 22 | } else { 23 | cbind("value" = betas, "std.err" = sds, "z-value" = betas / sds, 24 | "p-value" = 2 * pnorm(abs(betas / sds), lower.tail = FALSE)) 25 | } 26 | } 27 | out$shape <- object$coefficients$shape 28 | out$scale <- object$coefficients$scale 29 | out$var.frailty <- object$coefficients$var.frailty 30 | class(out) <- "summary.weibull.frailty" 31 | out 32 | } 33 | -------------------------------------------------------------------------------- /R/survfitJM.R: -------------------------------------------------------------------------------- 1 | survfitJM <- 2 | function (object, newdata, ...) { 3 | UseMethod("survfitJM") 4 | } 5 | -------------------------------------------------------------------------------- /R/update.logLik.Laplace.R: -------------------------------------------------------------------------------- 1 | update.logLik.Laplace <- 2 | function (b, betas, sigma, gammas, gammas.bs, alpha, D) { 3 | log.p.yt <- numeric(n) 4 | eta.yx <- as.vector(X %*% betas) 5 | eta.yxT <- as.vector(Xtime %*% betas) 6 | eta.s <- as.vector(Xs %*% betas) 7 | eta.tw1 <- as.vector(W1 %*% gammas) 8 | eta.tw2 <- as.vector(W2 %*% gammas.bs) 9 | eta.ws <- as.vector(W2s %*% gammas.bs) 10 | environment(fn) <- environment(gr) <- environment() 11 | hes.b <- vb <- matrix(0, n, ncz * ncz) 12 | bb <- b 13 | for (i in 1:n) { 14 | # individual values 15 | ind.i <- id == i 16 | id.GKi <- id.GK == i 17 | yi <- y[ind.i] 18 | eta.yxi <- eta.yx[ind.i] 19 | eta.yxTi <- eta.yxT[i] 20 | eta.si <- eta.s[id.GKi] 21 | Z.ind.i <- Z[ind.i, , drop = FALSE] 22 | Ztime.i <- Ztime[i, ] 23 | Zsi <- Zs[id.GKi, , drop = FALSE] 24 | yi.eta.yxi <- yi - eta.yxi 25 | logTi <- logT[i] 26 | eta.tw1i <- eta.tw1[i] 27 | eta.tw2i <- eta.tw2[i] 28 | Pi <- P[i] 29 | eta.wsi <- eta.ws[id.GKi] 30 | # posterior modes 31 | opt <- try(optim(b[i, ], fn, gr, method = "BFGS", hessian = TRUE), TRUE) 32 | if (inherits(opt, "try-error")) { 33 | opt <- list(par = b[i, ], hessian = matrix(attr(new.b, "hes.b")[i, ], ncz, ncz)) 34 | } 35 | H <- opt$hessian 36 | var.b <- if (!inherits(var.b <- try(solve(H), TRUE), "try-error")) var.b else ginv(H) 37 | bb[i, ] <- opt$par 38 | vb[i, ] <- c(var.b) 39 | hes.b[i, ] <- c(H) 40 | # likelihood contributions 41 | mu.y.b <- eta.yxi + rowSums(Z.ind.i * rep(bb[i, ], each = ni[i])) 42 | Yi <- alpha * (eta.si + rowSums(Zsi * rep(bb[i, ], each = GKk))) 43 | log.p.y.b <- sum(dnorm(yi, mu.y.b, sigma, log = TRUE)) 44 | log.p.t.b <- if (d[i]) { 45 | eta.tw1i + eta.tw2i + alpha * (eta.yxT[i] + sum(Ztime.i * bb[i, ])) - exp(eta.tw1i) * Pi * sum(wk * exp(eta.wsi + Yi)) 46 | } else { 47 | - exp(eta.tw1i) * Pi * sum(wk * exp(eta.wsi + Yi)) 48 | } 49 | log.p.b <- if (diag.D) { 50 | sum(dnorm(bb[i, ], 0, sqrt(D), log = TRUE)) 51 | } else { 52 | dmvnorm(bb[i, ], rep(0, ncz), D, log = TRUE) 53 | } 54 | log.p.yt[i] <- (log.p.y.b + log.p.t.b + log.p.b) - 0.5 * log(det(H)) 55 | } 56 | res <- cons.logLik + sum(log.p.yt, na.rm = TRUE) 57 | attr(res, "b") <- bb 58 | attr(res, "vb") <- vb 59 | attr(res, "hes.b") <- hes.b 60 | res 61 | } 62 | -------------------------------------------------------------------------------- /R/vcov.flexCPH.R: -------------------------------------------------------------------------------- 1 | vcov.flexCPH <- 2 | function (object, ...) { 3 | ginv(object$Hessian) 4 | } 5 | -------------------------------------------------------------------------------- /R/vcov.jointModel.R: -------------------------------------------------------------------------------- 1 | vcov.jointModel <- 2 | function (object, ...) { 3 | out <- try(solve(object$Hessian), silent = TRUE) 4 | vmat <- if (!inherits(out, "try-error")) 5 | structure(out, dimnames = dimnames(object$Hessian)) 6 | else 7 | structure(ginv(object$Hessian), dimnames = dimnames(object$Hessian)) 8 | (vmat + t(vmat)) / 2 9 | } 10 | -------------------------------------------------------------------------------- /R/vcov.weibull.frailty.R: -------------------------------------------------------------------------------- 1 | vcov.weibull.frailty <- 2 | function (object, sand.se = FALSE, ...) { 3 | inv.H <- solve(object$hessian) 4 | betas <- object$coefficients$betas 5 | shape <- object$coefficients$shape 6 | scale <- object$coefficients$scale 7 | var.fr <- object$coefficients$var.frailty 8 | out <- if (sand.se) { 9 | logT <- log(object$y[, 1]) 10 | d <- object$y[, 2] 11 | id <- object$id 12 | Time <- exp(logT) 13 | X <- object$x 14 | p <- ncol(X) 15 | N <- nrow(X) 16 | n <- length(unique(id)) 17 | D <- as.vector(tapply(d, id, sum)) 18 | if (!ncol(X)) 19 | X <- as.matrix(rep(0, N)) 20 | Xd <- rowsum(X * d, id, FALSE) 21 | sum.d <- as.vector(tapply(d, id, sum)) 22 | sum.dlogT <- as.vector(tapply(d * logT, id, sum)) 23 | theta <- 1 / var.fr 24 | eta <- if (p > 0) c(X %*% betas) else rep(0, N) 25 | exp.eta <- exp(eta) 26 | log.lambda0 <- log(shape * scale) + (shape - 1) * logT 27 | Lambda0 <- scale * Time^shape 28 | Lambda0.eta <- Lambda0 * exp(eta) 29 | mat.id <- cbind(Lambda0.eta, Time^shape * exp(eta), logT * Lambda0.eta, Lambda0.eta * X) 30 | P <- rowsum(mat.id, id, FALSE) 31 | Lambda0.eta <- P[, 1] 32 | theta.Lambda0.eta <- theta + Lambda0.eta 33 | log.theta.Lambda0.eta <- log(theta.Lambda0.eta) 34 | X.Lambda0.eta <- P[, seq(4, ncol(P)), drop = FALSE] 35 | sc.betas <- (Xd - (D + theta) * X.Lambda0.eta / theta.Lambda0.eta) 36 | sc.scale <- scale * c(sum.d / scale - (D + theta) * P[, 2] / theta.Lambda0.eta) 37 | sc.shape <- shape * (sum.d / shape + sum.dlogT - (D + theta) * P[, 3] / theta.Lambda0.eta) 38 | sc.var.fr <- - theta * (log(theta) + 1 - digamma(theta) + digamma(D + theta) - 39 | log.theta.Lambda0.eta - (D + theta) / theta.Lambda0.eta) 40 | score <- if (p > 0) cbind(sc.betas, sc.scale, sc.shape, sc.var.fr) else cbind(sc.scale, sc.shape, sc.var.fr) 41 | out.score <- colSums(t(apply(score, 1, function (x) x %o% x))) 42 | dim(out.score) <- dim(inv.H) 43 | out.score <- 0.5 * (out.score + t(out.score)) 44 | inv.H %*% out.score %*% inv.H 45 | } else 46 | inv.H 47 | out <- 0.5 * (out + t(out)) 48 | nams <- c(names(betas), "Log(scale)", "Log(shape)", "Log(var.frlty)") 49 | dimnames(out) <- list(nams, nams) 50 | out 51 | } 52 | -------------------------------------------------------------------------------- /R/wald.strata.R: -------------------------------------------------------------------------------- 1 | wald.strata <- 2 | function (fit) { 3 | if (!inherits(fit, "jointModel") || (nlv <- length(levels(fit$y$strata))) == 1) { 4 | stop("used only for stratified joint models.\n") 5 | } 6 | knots <- do.call(cbind, fit$control$knots) 7 | if (!all(apply(knots, 1, function (x) all(x == x[1])))) { 8 | warning("it appears that the knots are not the same among strata.\n") 9 | } 10 | coefs <- fit$coefficients 11 | spline.coefs <- coefs$gammas.bs 12 | ii <- grep("T.bs", colnames(fit$Hessian), fixed = TRUE) 13 | Var.spline.coefs <- vcov(fit)[ii, ii] 14 | n <- length(spline.coefs) 15 | p <- n / nlv 16 | L <- matrix(0, p * (nlv - 1), n) 17 | ind <- matrix(seq_len(n), ncol = nlv) 18 | pairs <- seq_len(nlv) 19 | pairs <- c(rbind(pairs[-nlv], pairs[-1])) 20 | ii <- cbind(rep(seq_len(p), each = 2*(nlv - 1)), rep(pairs, p)) 21 | L[cbind(rep(seq_len(nrow(L)), each = 2), ind[ii])] <- c(1, -1) 22 | v <- c(L %*% spline.coefs) 23 | stat <- c(crossprod(v, solve(L %*% tcrossprod(Var.spline.coefs, L), v))) 24 | df <- nrow(L) 25 | pvalue <- pchisq(stat, df = df, lower.tail = FALSE) 26 | mat <- rbind(c("X^2" = stat, df = df, "Pr(> X^2)" = pvalue)) 27 | rownames(mat) <- rep("", nrow(mat)) 28 | structure(list(alternative = "spline coefficients for the baseline risk\n\tfunction are not equal among strata", 29 | Result = mat), class = "wald.strata") 30 | } 31 | -------------------------------------------------------------------------------- /R/weibull.frailty.R: -------------------------------------------------------------------------------- 1 | weibull.frailty <- 2 | function (formula = formula(data), data = parent.frame(), id = "id", subset, na.action, init, 3 | control = list()) { 4 | call <- match.call() 5 | m <- match.call(expand.dots = FALSE) 6 | temp <- c("", "formula", "data", "subset", "na.action") 7 | m <- m[match(temp, names(m), nomatch = 0)] 8 | Terms <- if (missing(data)) terms(formula) else terms(formula, data = data) 9 | m$formula <- Terms 10 | m[[1]] <- as.name("model.frame") 11 | m <- eval(m, parent.frame()) 12 | if (NROW(m) == 0) 13 | stop("No (non-missing) observations.\n") 14 | Y <- model.extract(m, "response") 15 | if (!inherits(Y, "Surv")) 16 | stop("Response must be a survival object.\n") 17 | logT <- log(Y[, 1]) 18 | d <- Y[, 2] 19 | id <- if (is.character(id) && length(id) == 1) { 20 | if (missing(data) || !id %in% names(data)) 21 | stop("'id' not a 'data'.\n") 22 | nam.id <- id 23 | dd <- if (missing(na.action)) na.omit(data) else na.action(data) 24 | as.vector(unclass(factor(dd[[id]]))) 25 | } else { 26 | as.vector(unclass(factor(id))) 27 | } 28 | attr(Terms, "intercept") <- 1 29 | X <- model.matrix(Terms, m)[, -1, drop = FALSE] 30 | type <- attr(Y, "type") 31 | if (type != "right") 32 | stop("weibull.frailty() currently supports only right-censored data.\n") 33 | if (missing(init)) 34 | init <- NULL 35 | out <- weibull.frailty.fit(logT, d, X, id, init, control) 36 | out$y <- Y 37 | out$x <- X 38 | out$id <- id 39 | out$nam.id <- nam.id 40 | out$terms <- Terms 41 | out$data <- if (missing(data)) m else data 42 | out$call <- call 43 | class(out) <- "weibull.frailty" 44 | out 45 | } 46 | -------------------------------------------------------------------------------- /R/weibull.frailty.fit.R: -------------------------------------------------------------------------------- 1 | weibull.frailty.fit <- 2 | function (logT, d, X, id, init.thetas, control = list()) { 3 | Time <- exp(logT) 4 | p <- ncol(X) 5 | N <- nrow(X) 6 | n <- length(unique(id)) 7 | D <- as.vector(tapply(d, id, sum)) 8 | if (!ncol(X)) 9 | X <- as.matrix(rep(0, N)) 10 | Xd <- colSums(X * d) 11 | sum.d <- sum(d) 12 | sum.dlogT <- sum(d * logT) 13 | con <- list(optimizer = "optim", parscale = NULL, maxit = 500, numeriDeriv = "cd", eps.Hes = 1e-03) 14 | con[names(control)] <- control 15 | clnams <- colnames(X) 16 | dimnames(X) <- names(logT) <- names(Time) <- names(d) <- names(id) <- names(Xd) <- NULL 17 | fn <- function (thetas) { 18 | betas <- thetas[seq_len(p)] 19 | scale <- exp(thetas[p + 1]) 20 | shape <- exp(thetas[p + 2]) 21 | var.fr <- exp(thetas[p + 3]) 22 | theta <- 1 / var.fr 23 | eta <- if (p > 0) c(X %*% betas) else rep(0, N) 24 | log.lambda0 <- log(shape * scale) + (shape - 1) * logT 25 | Lambda0 <- scale * Time^shape 26 | P1 <- sum(d * (log.lambda0 + eta)) 27 | P2 <- n * (theta * log(theta) - lgamma(theta)) 28 | P3 <- sum(lgamma(D + theta) - (D + theta) * log(theta + c(tapply(Lambda0 * exp(eta), id, sum)))) 29 | - (P1 + P2 + P3) 30 | } 31 | gr <- function (thetas) { 32 | betas <- thetas[seq_len(p)] 33 | scale <- exp(thetas[p + 1]) 34 | shape <- exp(thetas[p + 2]) 35 | var.fr <- exp(thetas[p + 3]) 36 | theta <- 1 / var.fr 37 | eta <- if (p > 0) c(X %*% betas) else rep(0, N) 38 | exp.eta <- exp(eta) 39 | log.lambda0 <- log(shape * scale) + (shape - 1) * logT 40 | Lambda0 <- scale * Time^shape 41 | Lambda0.eta <- Lambda0 * exp(eta) 42 | mat.id <- cbind(Lambda0.eta, Time^shape * exp(eta), logT * Lambda0.eta, Lambda0.eta * X) 43 | P <- rowsum(mat.id, id, FALSE) 44 | Lambda0.eta <- P[, 1] 45 | theta.Lambda0.eta <- theta + Lambda0.eta 46 | log.theta.Lambda0.eta <- log(theta.Lambda0.eta) 47 | X.Lambda0.eta <- P[, seq(4, ncol(P)), drop = FALSE] 48 | sc.betas <- - c(Xd - colSums((D + theta) * X.Lambda0.eta / theta.Lambda0.eta)) 49 | sc.scale <- - scale * c(sum.d / scale - sum((D + theta) * P[, 2] / theta.Lambda0.eta)) 50 | sc.shape <- - shape * (sum.d / shape + sum.dlogT - sum((D + theta) * P[, 3] / theta.Lambda0.eta)) 51 | sc.var.fr <- theta * sum(log(theta) + 1 - digamma(theta) + digamma(D + theta) - 52 | log.theta.Lambda0.eta - (D + theta) / theta.Lambda0.eta) 53 | if (p > 0) c(sc.betas, sc.scale, sc.shape, sc.var.fr) else c(sc.scale, sc.shape, sc.var.fr) 54 | } 55 | if (is.null(init.thetas) || length(init.thetas) != p + 3) 56 | init.thetas <- rep(0.01, p + 3) 57 | names(init.thetas) <- NULL 58 | psc <- if (is.null(xx <- con$parscale)) rep(c(1, 0.1), c(p, 3)) else xx 59 | opt <- if (con$optimizer == "optim") { 60 | optim(init.thetas, fn, gr, method = "BFGS", control = list(maxit = con$maxit, parscale = psc)) 61 | } else { 62 | nlminb(init.thetas, fn, gr, scale = psc, control = list(iter.max = con$maxit)) 63 | } 64 | H <- if (con$numeriDeriv == "cd") cd.vec(opt$par, gr, eps = con$eps.Hes) else fd.vec(opt$par, gr, eps = con$eps.Hes) 65 | if (any(is.na(H) | !is.finite(H))) { 66 | warning("infinite or missing values in Hessian at convergence.\n") 67 | } else { 68 | ev <- eigen(H, symmetric = TRUE, only.values = TRUE)$values 69 | if (!all(ev >= -1e-06 * abs(ev[1]))) 70 | warning("Hessian matrix at convergence is not positive definite.\n") 71 | } 72 | betas <- opt$par[seq_len(p)] 73 | names(betas) <- clnams 74 | scale <- exp(opt$par[p + 1]) 75 | shape <- exp(opt$par[p + 2]) 76 | var.fr <- exp(opt$par[p + 3]) 77 | list(coefficients = list(betas = betas, scale = scale, shape = shape, var.frailty = var.fr), hessian = H, 78 | logLik = -opt[[2]], control = con) 79 | } 80 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | JM: Joint Models for Longitudinal and Survival Data using Maximum Likelihood 2 | ================ 3 | [![Travis-CI Build Status](https://travis-ci.org/drizopoulos/JM.svg?branch=master)](https://travis-ci.org/drizopoulos/JM) [![CRAN status](http://www.r-pkg.org/badges/version/JM)](https://cran.r-project.org/package=JM) [![](https://cranlogs.r-pkg.org/badges/grand-total/JM)](https://CRAN.R-project.org/package=JM) [![Download counter](http://cranlogs.r-pkg.org/badges/JM)](https://cran.r-project.org/package=JM) 4 | [![Research software impact](http://depsy.org/api/package/cran/JM/badge.svg)](http://depsy.org/package/r/JM) 5 | 6 | Description 7 | ------------ 8 | 9 | This repository contains the source files for the R package JM. 10 | This package fits joint models for longitudinal and time-to-event data using maximum 11 | likelihood. These models are applicable in mainly two settings. First, when focus 12 | is on the survival outcome and we wish to account for the effect of an endogenous 13 | (aka internal) time-dependent covariates measured with error. Second, when focus is on the 14 | longitudinal outcome and we wish to correct for nonrandom dropout. 15 | 16 | The basic joint-model-fitting function of the package is `jointModel()`. This accepts as 17 | main arguments a linear mixed model fitted by function `lme()` from the 18 | [**nlme**](https://CRAN.R-project.org/package=nlme) package and a Cox model fitted using 19 | function `coxph()` from the [**survival**](https://CRAN.R-project.org/package=survival) 20 | package. 21 | 22 | Basic Features 23 | ------------ 24 | 25 | - It can fit joint models for a single continuous longitudinal outcome and a time-to-event 26 | outcome. 27 | 28 | - For the survival outcome a relative risk models is assumed. The `method` argument of 29 | `jointModel()` can be used to define the type of baseline hazard function. Options are a 30 | B-spline approximation, a piecewise-constant function, the Weibull hazard and a completely 31 | unspecified function (i.e., a discrete function with point masses at the unique event 32 | times). 33 | 34 | - The user has now the option to define custom transformation functions for the terms of 35 | the longitudinal submodel that enter into the linear predictor of the survival submodel 36 | (arguments `derivForm`, `parameterization`). For example, the current value of the 37 | longitudinal outcomes, the velocity of the longitudinal outcome (slope), the area under 38 | the longitudinal profile. From the aforementioned options, in each model up to two terms 39 | can be included. In addition, using argument `InterFact` interactions terms can be 40 | considered. 41 | 42 | Dynamic predictions 43 | ------------ 44 | 45 | * Function `survfitJM()` computes dynamic survival probabilities. 46 | 47 | * Function `predict()` computes dynamic predictions for the longitudinal outcome. 48 | 49 | * Function `aucJM()` calculates time-dependent AUCs for joint models, and function 50 | `rocJM()` calculates the corresponding time-dependent sensitivities and specifies. 51 | 52 | * Function `prederrJM()` calculates prediction errors for joint models. 53 | -------------------------------------------------------------------------------- /data/aids.id.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/drizopoulos/JM/7ca2f6826b068c9530128673c111a2a4616aafe3/data/aids.id.rda -------------------------------------------------------------------------------- /data/aids.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/drizopoulos/JM/7ca2f6826b068c9530128673c111a2a4616aafe3/data/aids.rda -------------------------------------------------------------------------------- /data/pbc2.id.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/drizopoulos/JM/7ca2f6826b068c9530128673c111a2a4616aafe3/data/pbc2.id.rda -------------------------------------------------------------------------------- /data/pbc2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/drizopoulos/JM/7ca2f6826b068c9530128673c111a2a4616aafe3/data/pbc2.rda -------------------------------------------------------------------------------- /data/prothro.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/drizopoulos/JM/7ca2f6826b068c9530128673c111a2a4616aafe3/data/prothro.rda -------------------------------------------------------------------------------- /data/prothros.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/drizopoulos/JM/7ca2f6826b068c9530128673c111a2a4616aafe3/data/prothros.rda -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citHeader("To cite JM in publications use:") 2 | 3 | citEntry(entry = "Article", 4 | title = "{JM}: An {R} Package for the Joint Modelling of Longitudinal and Time-to-Event Data", 5 | author = personList(as.person("Dimitris Rizopoulos")), 6 | journal = "Journal of Statistical Software", 7 | year = "2010", 8 | volume = "35", 9 | number = "9", 10 | pages = "1--33", 11 | url = "https://doi.org/10.18637/jss.v035.i09", 12 | 13 | textVersion = 14 | paste("Dimitris Rizopoulos (2010).", 15 | "JM: An R Package for the Joint Modelling of Longitudinal and Time-to-Event Data.", 16 | "Journal of Statistical Software, 35(9), 1-33.", 17 | "URL https://doi.org/10.18637/jss.v035.i09") 18 | ) 19 | 20 | -------------------------------------------------------------------------------- /man/DerivIntSplines.Rd: -------------------------------------------------------------------------------- 1 | \name{DerivSplines} 2 | 3 | \alias{dns} 4 | \alias{dbs} 5 | \alias{ins} 6 | \alias{ibs} 7 | 8 | 9 | 10 | \title{ Derivatives and Integrals of B-splines and Natural Cubic splines } 11 | 12 | \description{ 13 | Numerical derivatives and integrals of functions \code{bs()} and \code{ns()} at their first argument. 14 | } 15 | 16 | \usage{ 17 | dns(x, df = NULL, knots = NULL, intercept = FALSE, 18 | Boundary.knots = range(x), eps = 1e-03) 19 | 20 | dbs(x, df = NULL, knots = NULL, intercept = FALSE, 21 | Boundary.knots = range(x), eps = 1e-03) 22 | 23 | ins(x, df = NULL, knots = NULL, intercept = FALSE, 24 | Boundary.knots = range(x), from = 0, weight.fun = NULL, \dots) 25 | 26 | ibs(x, df = NULL, knots = NULL, intercept = FALSE, 27 | Boundary.knots = range(x), from = 0, weight.fun = NULL, \dots) 28 | } 29 | 30 | \arguments{ 31 | \item{x, df, knots, intercept, Boundary.knots}{see the help pages of functions \code{ns()} and \code{bs()}.} 32 | \item{eps}{a numeric scalar denoting the step length for the central difference approximation, which 33 | calculates the derivative.} 34 | \item{from}{a numeric scalar denoting the lower limit of the integral.} 35 | \item{weight.fun}{a function to applied as weights.} 36 | \item{\dots}{extra arguments passed to \code{weight.fun}.} 37 | } 38 | 39 | 40 | \value{ 41 | an object of class \code{dns}, \code{dbs}, \code{ins} or \code{ibs}. 42 | } 43 | 44 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 45 | 46 | \examples{ 47 | x <- rnorm(10) 48 | dns(x, df = 4) 49 | ins(x, df = 4) 50 | } 51 | 52 | \keyword{regression} 53 | 54 | -------------------------------------------------------------------------------- /man/aids.Rd: -------------------------------------------------------------------------------- 1 | \name{aids} 2 | \alias{aids} 3 | \alias{aids.id} 4 | 5 | \docType{data} 6 | 7 | \title{Didanosine versus Zalcitabine in HIV Patients} 8 | 9 | \description{ 10 | A randomized clinical trial in which both longitudinal and survival data were collected to compare the efficacy and 11 | safety of two antiretroviral drugs in treating patients who had failed or were intolerant of zidovudine (AZT) therapy. 12 | } 13 | 14 | \format{ 15 | A data frame with 1408 observations on the following 9 variables. 16 | \describe{ 17 | \item{\code{patient}}{patients identifier; in total there are 467 patients.} 18 | \item{\code{Time}}{the time to death or censoring.} 19 | \item{\code{death}}{a numeric vector with 0 denoting censoring and 1 death.} 20 | \item{\code{CD4}}{the CD4 cells count.} 21 | \item{\code{obstime}}{the time points at which the CD4 cells count was recorded.} 22 | \item{\code{drug}}{a factor with levels \code{ddC} denoting zalcitabine and \code{ddI} denoting didanosine.} 23 | \item{\code{gender}}{a factor with levels \code{female} and \code{male}.} 24 | \item{\code{prevOI}}{a factor with levels \code{AIDS} denoting previous opportunistic infection (AIDS 25 | diagnosis) at study entry, and \code{noAIDS} denoting no previous infection.} 26 | \item{\code{AZT}}{a factor with levels \code{intolerance} and \code{failure} denoting AZT intolerance and 27 | AZT failure, respectively.} 28 | } 29 | } 30 | 31 | \references{ 32 | Goldman, A., Carlin, B., Crane, L., Launer, C., Korvick, J., Deyton, L. and Abrams, D. (1996) Response of CD4+ and 33 | clinical consequences to treatment using ddI or ddC in patients with advanced HIV infection. \emph{Journal of Acquired 34 | Immune Deficiency Syndromes and Human Retrovirology} \bold{11}, 161--169. 35 | 36 | Guo, X. and Carlin, B. (2004) Separate and joint modeling of longitudinal and event time data using standard 37 | computer packages. \emph{The American Statistician} \bold{58}, 16--24. 38 | } 39 | 40 | \note{ 41 | The data frame \code{aids.id} contains the first CD4 cell count measurement for each patient. This data frame is used to 42 | fit the survival model. 43 | } 44 | 45 | \examples{ 46 | summary(aids.id) 47 | } 48 | 49 | \keyword{datasets} 50 | -------------------------------------------------------------------------------- /man/anova.Rd: -------------------------------------------------------------------------------- 1 | \name{anova} 2 | 3 | \alias{anova.jointModel} 4 | 5 | \title{Anova Method for Fitted Joint Models} 6 | 7 | \description{ 8 | Produces marginal Wald tests or Performs a likelihood 9 | ratio test between two nested joint models. 10 | } 11 | 12 | \usage{ 13 | \method{anova}{jointModel}(object, object2, test = TRUE, 14 | process = c("both", "Longitudinal", "Event"), L = NULL, \dots) 15 | } 16 | 17 | \arguments{ 18 | \item{object}{an object inheriting from class \code{jointModel}, nested in \code{object2}.} 19 | \item{object2}{an object inheriting from class \code{jointModel}.} 20 | \item{test}{logical; if \code{TRUE} the likelihood ratio test is performed.} 21 | \item{process}{for which of the two submodels to produce the marginal Wald tests table.} 22 | \item{L}{a numeric matrix of appropriate dimensions defining the contrasts of interest.} 23 | \item{\dots}{additional arguments; currently none is used.} 24 | } 25 | 26 | \value{ 27 | An object of class \code{aov.jointModel} with components, 28 | \item{nam0}{the name of \code{object}.} 29 | \item{L0}{the log-likelihood under the null hypothesis (\code{object}).} 30 | \item{aic0}{the AIC value for the model given by \code{object}.} 31 | \item{bic0}{the BIC value for the model given by \code{object}. } 32 | \item{nam1}{the name of \code{object2}.} 33 | \item{L1}{the log-likelihood under the alternative hypothesis (\code{object2}).} 34 | \item{aic1}{the AIC value for the model given by \code{object2}.} 35 | \item{bic1}{the BIC value for the model given by \code{object2}.} 36 | \item{df}{the degrees of freedom for the test (i.e., the difference in the number of parameters).} 37 | \item{LRT}{the value of the Likelihood Ratio Test statistic (returned if \code{test = TRUE}).} 38 | \item{p.value}{the \eqn{p}-value of the test (returned if \code{test = TRUE}).} 39 | \item{aovTab.Y}{a data.frame with the marginal Wald tests for the longitudinal process; 40 | produced only when \code{object2} is missing.} 41 | \item{aovTab.T}{a data.frame with the marginal Wald tests for the event process; 42 | produced only when \code{object2} is missing.} 43 | \item{aovTab.L}{a data.frame with the marginal Wald tests for the user-defined contrasts matrix; 44 | produced only when \code{object2} is missing and \code{L} is not \code{NULL}.} 45 | } 46 | 47 | \section{Warning}{ 48 | The code minimally checks whether the models are nested! The user is responsible to supply nested models in 49 | order the LRT to be valid. 50 | } 51 | 52 | \references{ 53 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 54 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 55 | 56 | Rizopoulos, D. (2010) JM: An R Package for the Joint Modelling of Longitudinal and Time-to-Event Data. 57 | \emph{Journal of Statistical Software} \bold{35} (9), 1--33. \doi{10.18637/jss.v035.i09} 58 | } 59 | 60 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 61 | 62 | \seealso{\code{\link{jointModel}}} 63 | 64 | \examples{ 65 | \dontrun{ 66 | # linear mixed model fit without treatment effect 67 | fitLME.null <- lme(sqrt(CD4) ~ obstime, 68 | random = ~ 1 | patient, data = aids) 69 | # cox model fit without treatment effect 70 | fitCOX.null <- coxph(Surv(Time, death) ~ 1, 71 | data = aids.id, x = TRUE) 72 | # joint model fit without treatment effect 73 | fitJOINT.null <- jointModel(fitLME.null, fitCOX.null, 74 | timeVar = "obstime", method = "weibull-PH-aGH") 75 | 76 | # linear mixed model fit with treatment effect 77 | fitLME.alt <- lme(sqrt(CD4) ~ obstime * drug - drug, 78 | random = ~ 1 | patient, data = aids) 79 | # cox model fit with treatment effect 80 | fitCOX.alt <- coxph(Surv(Time, death) ~ drug, 81 | data = aids.id, x = TRUE) 82 | # joint model fit with treatment effect 83 | fitJOINT.alt <- jointModel(fitLME.alt, fitCOX.alt, timeVar = "obstime", 84 | method = "weibull-PH-aGH") 85 | 86 | # likelihood ratio test for treatment effect 87 | anova(fitJOINT.null, fitJOINT.alt) 88 | } 89 | } 90 | 91 | \keyword{methods} 92 | -------------------------------------------------------------------------------- /man/coef.Rd: -------------------------------------------------------------------------------- 1 | \name{coef} 2 | 3 | \alias{coef.jointModel} 4 | \alias{fixef.jointModel} 5 | 6 | \title{Estimated Coefficients for Joint Models} 7 | 8 | \description{ 9 | Extracts estimated coefficients from fitted joint models. 10 | } 11 | 12 | \usage{ 13 | \method{coef}{jointModel}(object, process = c("Longitudinal", "Event"), 14 | include.splineCoefs = FALSE, \dots) 15 | \method{fixef}{jointModel}(object, process = c("Longitudinal", "Event"), 16 | include.splineCoefs = FALSE, \dots) 17 | } 18 | 19 | \arguments{ 20 | \item{object}{an object inheriting from class \code{jointModel}.} 21 | \item{process}{for which model (i.e., linear mixed model or survival model) to extract the estimated 22 | coefficients.} 23 | \item{include.splineCoefs}{logical; if \code{TRUE} and the method argument in \code{jointModel()} is 24 | \code{"ch-Laplace"}, the estimated B-spline coefficients are included as well.} 25 | \item{\dots}{additional arguments; currently none is used.} 26 | } 27 | 28 | \details{ 29 | When \code{process = "Event"} both methods return the same output. However, for \code{process = "Longitudinal"}, 30 | the \code{coef()} method returns the subject-specific coefficients, whereas \code{fixef()} only the fixed effects. 31 | } 32 | 33 | \value{A numeric vector or a matrix of the estimated parameters for the fitted model.} 34 | 35 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 36 | 37 | 38 | \seealso{\code{\link{ranef.jointModel}}} 39 | 40 | \examples{ 41 | \dontrun{ 42 | # linear mixed model fit 43 | fitLME <- lme(sqrt(CD4) ~ obstime * drug - drug, 44 | random = ~ 1 | patient, data = aids) 45 | # cox model fit 46 | fitCOX <- coxph(Surv(Time, death) ~ drug, data = aids.id, x = TRUE) 47 | 48 | # joint model fit 49 | fitJOINT <- jointModel(fitLME, fitCOX, 50 | timeVar = "obstime") 51 | 52 | # fixed effects for the longitudinal process 53 | fixef(fitJOINT) 54 | 55 | # fixed effects + random effects estimates for the longitudinal 56 | # process 57 | coef(fitJOINT) 58 | 59 | # fixed effects for the event process 60 | fixef(fitJOINT, process = "Event") 61 | coef(fitJOINT, process = "Event") 62 | } 63 | } 64 | 65 | \keyword{ methods } 66 | -------------------------------------------------------------------------------- /man/crLong.Rd: -------------------------------------------------------------------------------- 1 | \name{crLong} 2 | \alias{crLong} 3 | 4 | \title{ Transform Competing Risks Data in Long Format } 5 | 6 | \description{ 7 | In a competing risks setting this function expands the data frame with a 8 | single row per subject to the a data frame in long format in which each 9 | subject has as many rows as the number of competing events. 10 | } 11 | 12 | \usage{ 13 | crLong(data, statusVar, censLevel, 14 | nameStrata = "strata", nameStatus = "status2") 15 | } 16 | 17 | \arguments{ 18 | \item{data}{the data frame containing the competing risk data with a single 19 | row per subject.} 20 | \item{statusVar}{a character string denoting the name of the variable in 21 | \code{data} that identifies the status variable which equals 1 if the 22 | subject had any of the competing events and 0 otherwise.} 23 | \item{censLevel}{a character string or a scalar denoting the censoring level 24 | in the \code{statusVar} variable of \code{data}.} 25 | \item{nameStrata}{a character string denoting the variable that will be added 26 | in the long version of \code{data} denoting the various causes of event.} 27 | \item{nameStatus}{a character string denoting the variable that will be added 28 | in the long version of \code{data} denoting if the subject experience any 29 | of the competing events.} 30 | } 31 | 32 | \value{ 33 | A data frame in the long format with multiple rows per subject. 34 | } 35 | 36 | \references{ 37 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 38 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 39 | 40 | Putter, H., Fiocco, M., and Geskus, R. (2007). Tutorial in biostatistics: 41 | Competing risks and multi-state models. \emph{Statistics in Medicine} \bold{26}, 42 | 2389--2430. 43 | } 44 | 45 | \author{ 46 | Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl} 47 | } 48 | 49 | \examples{ 50 | head(crLong(pbc2.id, "status", "alive")) 51 | } 52 | 53 | \keyword{methods} 54 | -------------------------------------------------------------------------------- /man/fitted.Rd: -------------------------------------------------------------------------------- 1 | \name{fitted} 2 | 3 | \alias{fitted.jointModel} 4 | 5 | \title{Fitted Values for Joint Models} 6 | 7 | \description{ 8 | Calculates fitted values for joint models. 9 | } 10 | 11 | \usage{ 12 | \method{fitted}{jointModel}(object, process = c("Longitudinal", "Event"), 13 | type = c("Marginal", "Subject", "EventTime", "Slope"), scale = c("survival", 14 | "cumulative-Hazard", "log-cumulative-Hazard"), M = 200, \dots) 15 | } 16 | 17 | \arguments{ 18 | \item{object}{an object inheriting from class \code{jointModel}.} 19 | \item{process}{for which model (i.e., linear mixed model or survival model) to calculate the fitted values.} 20 | \item{type}{what type of fitted values to calculate for the survival outcome. See \bold{Details}.} 21 | \item{scale}{in which scale to calculate; relevant only when \code{process = "Event"}.} 22 | \item{M}{how many times to simulate random effects; see \bold{Details} for more info.} 23 | \item{\dots}{additional arguments; currently none is used.} 24 | } 25 | 26 | \details{ 27 | For \code{process = "Longitudinal"}, let \eqn{X} denote the design matrix for the fixed effects \eqn{\beta}, and 28 | \eqn{Z} the design matrix for the random effects \eqn{b}. Then for \code{type = "Marginal"} the fitted values are 29 | \eqn{X \hat{\beta},} whereas for \code{type = "Subject"} they are \eqn{X \hat{\beta} + Z \hat{b}}. For \code{type = "EventTime"} 30 | is the same as \code{type = "Subject"} but evaluated at the observed event times. Finally, \code{type == "Slope"} 31 | returns \eqn{Xs \hat{\beta} + Zs \hat{b}} where \eqn{Xs} and \eqn{Zs} denote the fixed- and random-effects design 32 | matrices corresponding to the slope term which is specified in the \code{derivForm} argument of \code{\link{jointModel}}. 33 | 34 | For \code{process = "Event"} and \code{type = "Subject"} the linear predictor conditional on the random effects 35 | estimates is calculated for each sample unit. Depending on the value of the \code{scale} argument the fitted survival 36 | function, cumulative hazard function or log cumulative hazard function is returned. For \code{type = "Marginal"}, 37 | random effects values for each sample unit are simulated \code{M} times from a normal distribution with zero mean and 38 | covariance matrix the estimated covariance matrix for the random effects. The marginal survival function for the 39 | \eqn{i}th sample unit is approximated by \deqn{S_i(t) = \int S_i(t | b_i) p(b_i) db_i \approx (1/M) \sum_{m = 1}^M 40 | S_i(t | b_{im}),} where \eqn{p(b_i)} denotes the normal probability density function, and \eqn{b_{im}} the \eqn{m}th 41 | simulated value for the random effect of the \eqn{i}th sample unit. The cumulative hazard and log cumulative hazard 42 | functions are calculated as \eqn{H_i(t) = - \log S_i(t)} and \eqn{\log H_i(t) = \log \{ - \log S_i(t)\},} respectively. 43 | } 44 | 45 | \value{ 46 | a numeric vector of fitted values. 47 | } 48 | 49 | \references{ 50 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 51 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 52 | 53 | Rizopoulos, D. (2010) JM: An R Package for the Joint Modelling of Longitudinal and Time-to-Event Data. 54 | \emph{Journal of Statistical Software} \bold{35} (9), 1--33. \doi{10.18637/jss.v035.i09} 55 | } 56 | 57 | 58 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 59 | 60 | \seealso{\code{\link{residuals.jointModel}}} 61 | 62 | \examples{ 63 | \dontrun{ 64 | # linear mixed model fit 65 | fitLME <- lme(log(serBilir) ~ drug * year, 66 | random = ~ 1 | id, data = pbc2) 67 | # survival regression fit 68 | fitSURV <- survreg(Surv(years, status2) ~ drug, 69 | data = pbc2.id, x = TRUE) 70 | # joint model fit, under the (default) Weibull model 71 | fitJOINT <- jointModel(fitLME, fitSURV, timeVar = "year") 72 | 73 | # fitted for the longitudinal process 74 | head(cbind( 75 | "Marg" = fitted(fitJOINT), 76 | "Subj" = fitted(fitJOINT, type = "Subject") 77 | )) 78 | 79 | # fitted for the event process - survival function 80 | head(cbind( 81 | "Marg" = fitted(fitJOINT, process = "Ev"), 82 | "Subj" = fitted(fitJOINT, process = "Ev", type = "Subject") 83 | )) 84 | 85 | # fitted for the event process - cumulative hazard function 86 | head(cbind( 87 | "Marg" = fitted(fitJOINT, process = "Ev", 88 | scale = "cumulative-Hazard"), 89 | "Subj" = fitted(fitJOINT, process = "Ev", type = "Subject", 90 | scale = "cumulative-Hazard") 91 | )) 92 | } 93 | } 94 | 95 | \keyword{methods} 96 | -------------------------------------------------------------------------------- /man/pbc.Rd: -------------------------------------------------------------------------------- 1 | \name{pbc2} 2 | \alias{pbc2} 3 | \alias{pbc2.id} 4 | 5 | 6 | \docType{data} 7 | 8 | \title{Mayo Clinic Primary Biliary Cirrhosis Data} 9 | 10 | \description{ 11 | Followup of 312 randomised patients with primary biliary cirrhosis, a rare autoimmune liver disease, at Mayo Clinic. 12 | } 13 | 14 | \format{ 15 | A data frame with 1945 observations on the following 20 variables. 16 | \describe{ 17 | \item{\code{id}}{patients identifier; in total there are 312 patients.} 18 | \item{\code{years}}{number of years between registration and the earlier of death, transplantion, or study 19 | analysis time.} 20 | \item{\code{status}}{a factor with levels \code{alive}, \code{transplanted} and \code{dead}.} 21 | \item{\code{drug}}{a factor with levels \code{placebo} and \code{D-penicil}.} 22 | \item{\code{age}}{at registration in years.} 23 | \item{\code{sex}}{a factor with levels \code{male} and \code{female}.} 24 | \item{\code{year}}{number of years between enrollment and this visit date, remaining values on the line of 25 | data refer to this visit.} 26 | \item{\code{ascites}}{a factor with levels \code{No} and \code{Yes}.} 27 | \item{\code{hepatomegaly}}{a factor with levels \code{No} and \code{Yes}.} 28 | \item{\code{spiders}}{a factor with levels \code{No} and \code{Yes}.} 29 | \item{\code{edema}}{a factor with levels \code{No edema} (i.e., no edema and no diuretic therapy for edema), 30 | \code{edema no diuretics} (i.e., edema present without diuretics, or edema resolved by diuretics), and 31 | \code{edema despite diuretics} (i.e., edema despite diuretic therapy).} 32 | \item{\code{serBilir}}{serum bilirubin in mg/dl.} 33 | \item{\code{serChol}}{serum cholesterol in mg/dl.} 34 | \item{\code{albumin}}{albumin in gm/dl.} 35 | \item{\code{alkaline}}{alkaline phosphatase in U/liter.} 36 | \item{\code{SGOT}}{SGOT in U/ml.} 37 | \item{\code{platelets}}{platelets per cubic ml / 1000.} 38 | \item{\code{prothrombin}}{prothrombin time in seconds.} 39 | \item{\code{histologic}}{histologic stage of disease.} 40 | \item{\code{status2}}{a numeric vector with the value 1 denoting if the patient was dead, 41 | and 0 if the patient was alive or transplanted.} 42 | } 43 | } 44 | 45 | \references{ 46 | Fleming, T. and Harrington, D. (1991) \emph{Counting Processes and Survival Analysis}. Wiley, New York. 47 | 48 | Therneau, T. and Grambsch, P. (2000) \emph{Modeling Survival Data: Extending the Cox Model}. Springer-Verlag, New York. 49 | } 50 | 51 | \note{ 52 | The data frame \code{pbc2.id} contains the first measurement for each patient. This data frame is used to 53 | fit the survival model. 54 | } 55 | 56 | 57 | \examples{ 58 | summary(pbc2.id) 59 | } 60 | 61 | \keyword{datasets} 62 | -------------------------------------------------------------------------------- /man/piecewiseExp.ph.Rd: -------------------------------------------------------------------------------- 1 | \name{piecewiseExp.ph} 2 | 3 | \alias{piecewiseExp.ph} 4 | 5 | \title{ Proportional Hazards Models with Piecewise Constant Baseline Hazard Function } 6 | 7 | \description{ 8 | Based on a fitted Cox model this function fits the corresponding relative risk model with a 9 | piecewise constant baseline hazard using the Poisson regression equivalence 10 | } 11 | 12 | \usage{ 13 | piecewiseExp.ph(coxObject, knots = NULL, length.knots = 6) 14 | } 15 | 16 | \arguments{ 17 | \item{coxObject}{ an object of class \code{coxph}.} 18 | \item{knots}{A numeric vector denoting the internal knots (cut points) defining the intervals in which the baseline hazard is assumed constant.} 19 | \item{length.knots}{a numeric value denoting the number of internal knots to use in the fit. 20 | Used when \code{knots = NULL}.} 21 | } 22 | 23 | \value{ 24 | an object of class \code{glm}. 25 | } 26 | 27 | \references{ 28 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 29 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 30 | } 31 | 32 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 33 | 34 | \examples{ 35 | coxFit <- coxph(Surv(Time, death) ~ drug, data = aids.id, x = TRUE) 36 | piecewiseExp.ph(coxFit) 37 | } 38 | 39 | \keyword{multivariate} 40 | \keyword{regression} 41 | 42 | -------------------------------------------------------------------------------- /man/plot-rocJM.Rd: -------------------------------------------------------------------------------- 1 | \name{plot.rocJM} 2 | 3 | \alias{plot.rocJM} 4 | 5 | \title{Plot Method for rocJM Objects} 6 | 7 | \description{ 8 | Produces plots of ROC curves and the corresponding areas under the curve. 9 | } 10 | 11 | \usage{ 12 | \method{plot}{rocJM}(x, which = NULL, type = c("ROC", "AUC"), 13 | ndt = "all", main = NULL, caption = NULL, xlab = NULL, 14 | ylab = NULL, ask = NULL, legend = FALSE, lx = NULL, ly = NULL, 15 | lty = NULL, col = NULL, cex.caption = 0.8, cex.axis = NULL, 16 | cex.lab = NULL, cex.main = NULL, \dots) 17 | } 18 | 19 | \arguments{ 20 | \item{x}{an object inheriting from class \code{rocJM}.} 21 | \item{which}{a numeric vector specifying for which generic subjects to produce the plots. 22 | This refers to the different cases identified by the \code{idVar} argument in \code{\link{rocJM}}.} 23 | \item{type}{a character string specifying which plot to produce the ROC curves or the areas under 24 | the ROC curves.} 25 | \item{ndt}{the character string \code{"all"} or a numeric scalar specifying for which time windows 26 | (\code{dt} argument of \code{\link{rocJM}}) to produce the plots.} 27 | \item{main}{a character string specifying the title in the plot.} 28 | \item{caption}{a character string specifying a caption in the plot.} 29 | \item{xlab}{a character string specifying the x-axis label in the plot.} 30 | \item{ylab}{a character string specifying the y-axis label in the plot.} 31 | \item{ask}{logical; if \code{TRUE}, the user is asked before each plot, see \code{par()}.} 32 | \item{legend}{logical; if \code{TRUE}, a legend is included in the plot.} 33 | \item{lx,ly}{the \code{x} and \code{y} arguments of \code{legend()}.} 34 | \item{lty}{what types of lines to use.} 35 | \item{col}{which colors to use.} 36 | \item{cex.caption}{font size for the caption.} 37 | \item{cex.axis, cex.lab, cex.main}{graphical parameters; see \code{par} for more info.} 38 | \item{\dots}{extra graphical parameters passed to \code{plot()}.} 39 | } 40 | 41 | \references{ 42 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 43 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 44 | 45 | Rizopoulos, D. (2011). Dynamic predictions and prospective accuracy in joint models for 46 | longitudinal and time-to-event data. \emph{Biometrics} \bold{67}, 819--829. 47 | } 48 | 49 | 50 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 51 | 52 | \seealso{\code{\link{rocJM}}} 53 | 54 | \examples{ 55 | \dontrun{ 56 | fitLME <- lme(sqrt(CD4) ~ obstime + obstime:(drug + AZT + prevOI + gender), 57 | random = ~ obstime | patient, data = aids) 58 | fitSURV <- coxph(Surv(Time, death) ~ drug + AZT + prevOI + gender, 59 | data = aids.id, x = TRUE) 60 | fit.aids <- jointModel(fitLME, fitSURV, timeVar = "obstime", 61 | method = "piecewise-PH-aGH") 62 | 63 | ND <- aids[aids$patient == "7", ] 64 | roc <- rocJM(fit.aids, dt = c(2, 4, 8), ND, idVar = "patient") 65 | plot(roc, lwd = 2, legend = TRUE) 66 | plot(roc, type = "AUC") 67 | } 68 | } 69 | 70 | \keyword{methods} 71 | -------------------------------------------------------------------------------- /man/plot.Rd: -------------------------------------------------------------------------------- 1 | \name{plot} 2 | 3 | \alias{plot.jointModel} 4 | 5 | \title{Plot Diagnostics for Joint Models} 6 | 7 | \description{ 8 | Produces a variety of plots for fitted joint models. 9 | } 10 | 11 | \usage{ 12 | \method{plot}{jointModel}(x, which = 1:4, caption = c("Residuals vs Fitted", 13 | "Normal Q-Q", "Marginal Survival", "Marginal Cumulative Hazard", 14 | "Marginal log Cumulative Hazard", "Baseline Hazard", 15 | "Cumulative Baseline Hazard", "Subject-specific Survival", 16 | "Subject-specific Cumulative Hazard", 17 | "Subject-specific log Cumulative Hazard"), survTimes = NULL, 18 | main = "", 19 | ask = prod(par("mfcol")) < length(which) && dev.interactive(), 20 | \dots, ids = NULL, add.smooth = getOption("add.smooth"), 21 | add.qqline = TRUE, add.KM = FALSE, cex.caption = 1, return = FALSE) 22 | } 23 | 24 | \arguments{ 25 | \item{x}{an object inheriting from class \code{jointModel}.} 26 | \item{which}{which types of plots to produce, specify a subset of the numbers 1:10.} 27 | \item{caption}{captions to appear above the plots defined by argument \code{which}.} 28 | \item{survTimes}{a vector of survival times for which the survival, cumulative hazard or 29 | log cumulative hazard will be computed. Default is \code{seq(minT, maxT, length = 15)}, where \code{minT} and 30 | \code{maxT} are the minimum and maximum observed survival times, respectively.} 31 | \item{main}{a character string specifying the title in the plot.} 32 | \item{ask}{logical; if \code{TRUE}, the user is asked before each plot, see \code{par(ask=.)}.} 33 | \item{\dots}{other parameters to be passed through to plotting functions.} 34 | \item{ids}{a numeric vector specifying which subjects, the subject-specific plots will include; 35 | default is all subjects.} 36 | \item{add.smooth}{logical; if \code{TRUE} a smooth line is superimposed in the "Residuals vs Fitted" plot.} 37 | \item{add.qqline}{logical; if \code{TRUE} a qq-line is superimposed in the "Normal Q-Q" plot.} 38 | \item{add.KM}{logical; if \code{TRUE} the Kaplan-Meier estimate of the survival function is superimposed in the 39 | "Marginal Survival" plot.} 40 | \item{cex.caption}{magnification of captions.} 41 | \item{return}{logical; if \code{TRUE} and \code{which} takes in values in \code{c(3:5, 8:10)}, 42 | then the values used to create the plot are returned.} 43 | } 44 | 45 | \note{ 46 | The plots of the baseline hazard and the cumulative baseline hazard are only produced when the joint model has 47 | been fitted using \code{method = "Cox-PH-GH"}. 48 | } 49 | 50 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 51 | 52 | \references{ 53 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 54 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 55 | 56 | Rizopoulos, D. (2010) JM: An R package for the joint modelling of longitudinal and time-to-event data. 57 | \emph{Journal of Statistical Software} \bold{35} (9), 1--33. \doi{10.18637/jss.v035.i09} 58 | } 59 | 60 | \seealso{\code{\link{jointModel}}} 61 | 62 | \examples{ 63 | \dontrun{ 64 | # linear mixed model fit 65 | fitLME <- lme(log(serBilir) ~ drug * year, random = ~ 1 | id, data = pbc2) 66 | # survival regression fit 67 | fitSURV <- survreg(Surv(years, status2) ~ drug, data = pbc2.id, x = TRUE) 68 | # joint model fit, under the (default) Weibull model 69 | fitJOINT <- jointModel(fitLME, fitSURV, timeVar = "year") 70 | 71 | plot(fitJOINT, 3, add.KM = TRUE, col = "red", lwd = 2) 72 | 73 | par(mfrow = c(2, 2)) 74 | plot(fitJOINT) 75 | } 76 | } 77 | 78 | \keyword{methods} 79 | -------------------------------------------------------------------------------- /man/prothro.Rd: -------------------------------------------------------------------------------- 1 | \name{prothro} 2 | \alias{prothro} 3 | \alias{prothros} 4 | 5 | \docType{data} 6 | 7 | \title{Prednisone versus Placebo in Liver Cirrhosis Patients} 8 | 9 | \description{ 10 | A randomized trial on 488 liver cirrhosis patients 11 | } 12 | 13 | \format{ 14 | Two data frames with the following variable. 15 | \describe{ 16 | \item{\code{id}}{patients identifier; in total there are 467 patients.} 17 | \item{\code{pro}}{prothrobin measurements.} 18 | \item{\code{time}}{for data frame \code{prothro} the time points at which the prothrobin measurements were taken; 19 | for data frame \code{prothros} the time to death or censoring.} 20 | \item{\code{death}}{a numeric vector with 0 denoting censoring and 1 death.} 21 | \item{\code{treat}}{randomized treatment; a factor with levels "placebo" and "prednisone".} 22 | } 23 | } 24 | 25 | \source{ 26 | \url{http://www.gllamm.org/books/readme.html#14.6}, 27 | } 28 | 29 | \references{ 30 | 31 | Andersen, P. K., Borgan, O., Gill, R. D. and Keiding, N. (1993). 32 | \emph{Statistical Models Based on Counting Processes}. New York: Springer. 33 | 34 | } 35 | 36 | 37 | \examples{ 38 | summary(prothros) 39 | } 40 | 41 | \keyword{datasets} 42 | -------------------------------------------------------------------------------- /man/ranef.Rd: -------------------------------------------------------------------------------- 1 | \name{ranef} 2 | 3 | \alias{ranef.jointModel} 4 | 5 | \title{Random Effects Estimates for Joint Models} 6 | 7 | \description{ 8 | Extracts the random effects estimates from a fitted joint model. 9 | } 10 | 11 | \usage{ 12 | \method{ranef}{jointModel}(object, type = c("mean", "mode"), postVar = FALSE, \dots) 13 | } 14 | 15 | \arguments{ 16 | \item{object}{an object inheriting from class \code{jointModel}.} 17 | \item{type}{what type of empirical Bayes estimates to compute, the mean of the posterior distribution or 18 | the mode of the posterior distribution.} 19 | \item{postVar}{logical; if \code{TRUE} the variance of the posterior distribution is also returned. When 20 | \code{type == "mode"}, then this equals \eqn{\{- \partial^2 \log p(b_i | T_i, 21 | \delta_i, y_i) / \partial b_i^\top \partial b_i \}^{-1}}.} 22 | \item{\dots}{additional arguments; currently none is used.} 23 | } 24 | 25 | \value{ 26 | a numeric matrix with rows denoting the individuals and columns the random effects (e.g., intercepts, slopes, etc.). 27 | If \code{postVar = TRUE}, the numeric matrix has an extra attribute ``postVar". 28 | } 29 | 30 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 31 | 32 | \references{ 33 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 34 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 35 | } 36 | 37 | \seealso{\code{\link{coef.jointModel}}, \code{\link{fixef.jointModel}}} 38 | 39 | \examples{ 40 | \dontrun{ 41 | # linear mixed model fit 42 | fitLME <- lme(log(serBilir) ~ drug * year, random = ~ 1 | id, data = pbc2) 43 | # survival regression fit 44 | fitSURV <- survreg(Surv(years, status2) ~ drug, data = pbc2.id, x = TRUE) 45 | 46 | # joint model fit, under the (default) Weibull model 47 | fitJOINT <- jointModel(fitLME, fitSURV, timeVar = "year") 48 | ranef(fitJOINT) 49 | } 50 | } 51 | 52 | \keyword{methods} 53 | -------------------------------------------------------------------------------- /man/simulate.Rd: -------------------------------------------------------------------------------- 1 | \name{simulate} 2 | 3 | \alias{simulateJM} 4 | \alias{simulate.jointModel} 5 | 6 | \title{Simulate from Joint Models.} 7 | 8 | \description{ 9 | simulate longitudinal responses and event times from joint models 10 | } 11 | 12 | \usage{ 13 | simulateJM(nsim, nsub, thetas, times, formulas, Data = NULL, 14 | method = c("weibull-PH", "weibull-AFT", "piecewise-PH", "spline-PH"), 15 | lag = 0, censoring = "uniform", max.FUtime = NULL, seed = NULL, 16 | return.ranef = FALSE) 17 | \method{simulate}{jointModel}(object, nsim, seed = NULL, times = NULL, 18 | Data = NULL, \dots) 19 | } 20 | 21 | \arguments{ 22 | \item{nsim}{number of data sets to be simulated.} 23 | \item{nsub}{the number of subjects in each data set.} 24 | \item{thetas}{a list with the parameter values. This should be of the same structure as 25 | the \code{coefficients} component returned by \code{jointModel()}.} 26 | \item{times}{a numeric vector denoting the time points at which longitudinal measurements 27 | are planned to be taken.} 28 | \item{formulas}{a list with components: \code{Yfixed} a formula for the fixed-effects part 29 | of the linear mixed model, \code{Yrandom} a formula for the random-effects part of the 30 | linear mixed model, \code{Tfixed} a formula for the baseline covariates part of the 31 | survival submodel, \code{timeVar} a character string indicating the name of the time 32 | variable in the linear mixed model.} 33 | \item{Data}{a data frame containing any covariates used in the formulas defined in the 34 | \code{formulas} argument.} 35 | \item{method}{a character string indicating from what type of survival submodel to simulate. 36 | There are the same options as the ones provided by \code{\link{jointModel}}.} 37 | \item{lag}{a numeric value denoting a lagged effect; the same as the \code{lag} 38 | argument of \code{\link{jointModel}}.} 39 | \item{censoring}{a character string or a numeric vector.} 40 | \item{max.FUtime}{a numeric value denoting the maximum follow-up time for the study. The default 41 | is \code{max(times) + 2 * IQR(times)}.} 42 | \item{seed}{an object specifying if and how the random number generator should 43 | be initialized ('seeded'). It could be either \code{NULL} or an integer that 44 | will be used in a call to \code{set.seed()} before simulating the response 45 | vectors. If set, the value is saved as the "seed" attribute of the returned value.} 46 | \item{return.ranef}{logical; if \code{TRUE}, each component of the returned list has the attributed 47 | \code{"ranef"} that contains the random-effects values used in the simulation.} 48 | \item{object}{an object inheriting from class \code{jointModel}.} 49 | \item{\dots}{additional arguments; currently none is used.} 50 | } 51 | 52 | \value{A list of length \code{nsim} of data frames that contains the simulated responses 53 | for the longitudinal process "y", the simulated event times "Time", the event indicator 54 | "Event", and the subject identification number "id". If extra covariates were assumed, 55 | these are also included.} 56 | 57 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 58 | 59 | 60 | \seealso{\code{\link{jointModel}}} 61 | 62 | \examples{ 63 | \dontrun{ 64 | prothro$t0 <- as.numeric(prothro$time == 0) 65 | lmeFit <- lme(pro ~ treat * (time + t0), random = ~ time | id, data = prothro) 66 | survFit <- coxph(Surv(Time, death) ~ treat, data = prothros, x = TRUE) 67 | jointFit <- jointModel(lmeFit, survFit, timeVar = "time", 68 | method = "weibull-PH-aGH") 69 | 70 | newData <- simulate(jointFit, nsim = 1, times = seq(0, 11, len = 15)) 71 | newData 72 | } 73 | } 74 | 75 | \keyword{ methods } 76 | -------------------------------------------------------------------------------- /man/summary.weibull.frailty.Rd: -------------------------------------------------------------------------------- 1 | \name{summary.weibull.frailty} 2 | 3 | \alias{summary.weibull.frailty} 4 | 5 | \title{ Summary Method for weibull.frailty Objects} 6 | 7 | \description{ 8 | Summarizes the fit of a Weibull model with Gamma frailties 9 | } 10 | 11 | \usage{ 12 | \method{summary}{weibull.frailty}(object, sand.se = FALSE, \dots) 13 | } 14 | 15 | \arguments{ 16 | \item{object}{an object inheriting from class \code{weibull.frailty}.} 17 | \item{sand.se}{logical; if \code{TRUE}, sandwich standard errors are also produced.} 18 | \item{\dots}{ additional arguments; currently none is used.} 19 | } 20 | 21 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 22 | 23 | \seealso{\code{\link{weibull.frailty}}} 24 | 25 | \examples{ 26 | fit <- weibull.frailty(Surv(time, status) ~ age + sex, kidney) 27 | summary(fit) 28 | summary(fit, TRUE) 29 | } 30 | 31 | \keyword{methods} 32 | 33 | -------------------------------------------------------------------------------- /man/wald.strata.Rd: -------------------------------------------------------------------------------- 1 | \name{wald.strata} 2 | 3 | \alias{wald.strata} 4 | 5 | \title{ Wald Test for Stratification Factors } 6 | 7 | \description{ 8 | It performs a Wald test to test the hypothesis of equal spline coefficients among strata 9 | in the approximation of baseline risk function. 10 | } 11 | 12 | \usage{ 13 | wald.strata(fit) 14 | } 15 | 16 | \arguments{ 17 | \item{fit}{an object of class \code{jointModel} with \code{method = "spline-PH-GH"} 18 | and with a strata specification in the survival part.} 19 | } 20 | 21 | \value{ 22 | an object of class \code{wald.strata} with components: 23 | \item{alternative}{a character string naming the alternative.} 24 | \item{Result}{a numeric matrix with the results of the Wald test.} 25 | } 26 | 27 | \note{ 28 | This test is valid when the same knots have been used across strata. 29 | } 30 | 31 | \references{ 32 | Rizopoulos, D. (2012) \emph{Joint Models for Longitudinal and Time-to-Event Data: with 33 | Applications in R}. Boca Raton: Chapman and Hall/CRC. 34 | } 35 | 36 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 37 | 38 | \examples{ 39 | \dontrun{ 40 | fitLME <- lme(log(serBilir) ~ drug * year - drug, random = ~ year | id, 41 | data = pbc2) 42 | fitSURV <- coxph(Surv(years, status2) ~ drug + strata(hepatomegaly), 43 | data = pbc2.id, x = TRUE) 44 | fit.pbc <- jointModel(fitLME, fitSURV, timeVar = "year", method = "spline-PH-aGH") 45 | wald.strata(fit.pbc) 46 | } 47 | } 48 | 49 | \keyword{multivariate} 50 | \keyword{regression} 51 | 52 | -------------------------------------------------------------------------------- /man/weibull.frailty.Rd: -------------------------------------------------------------------------------- 1 | \name{weibull.frailty} 2 | 3 | \alias{weibull.frailty} 4 | 5 | \title{ Weibull Model with Gamma Frailties } 6 | 7 | \description{ 8 | Fits a Weibull model with Gamma frailties for multivariate survival data under maximum likelihood 9 | } 10 | 11 | \usage{ 12 | weibull.frailty(formula = formula(data), data = parent.frame(), 13 | id = "id", subset, na.action, init, control = list()) 14 | } 15 | 16 | \arguments{ 17 | \item{formula}{ an object of class \code{formula}: a symbolic description of the model to be fitted. The response must 18 | be a survival object as returned by function \code{Surv()}.} 19 | \item{data}{ an optional data frame containing the variables specified in the model. } 20 | \item{id}{ either a character string denoting a variable name in \code{data} or a numeric vector specifying which event times belong to 21 | the same cluster (e.g., hospital, patient, etc.).} 22 | \item{subset}{ an optional vector specifying a subset of observations to be used in the fitting process. } 23 | \item{na.action}{ what to do with missing values. } 24 | \item{init}{ a numeric vector of length \eqn{p + 3} of initial values. The first \eqn{p} elements should correspond to the regression coefficients 25 | for the covariates, and the last \eqn{3} to log-scale, log-shape, and log-frailty-variance, respectively. See \bold{Details}.} 26 | \item{control}{a list of control values with components: 27 | \describe{ 28 | \item{optimizer}{a character string indicating which optimizer to use; options are "optim" (default) and 29 | "nlminb".} 30 | \item{parscale}{the \code{parscale} control argument for \code{optim()}, or the \code{scale} argument for 31 | \code{nlminb()}. It should be a numeric vector of length equal to the number of parameters. Default is 0.01 32 | for all parameters.} 33 | \item{maxit}{the maximum number of iterations. Default is 500.} 34 | \item{numeriDeriv}{a character string indicating which type of numerical derivative to use to compute the 35 | Hessian matrix; options are "fd" denoting the forward difference approximation, and "cd" (default) 36 | denoting the central difference approximation.} 37 | \item{eps.Hes}{tolerance value used in the numerical derivative method. Default is 1e-03.} 38 | } 39 | } 40 | } 41 | 42 | \details{ 43 | The fitted model is defined as follows: \deqn{\lambda(t_i | \omega_i) = \lambda_0(t_i) \omega_i \exp(x_i^T \beta),}{ 44 | \lambda(t_i | \omega_i) = \lambda_0(t_i) \omega_i \exp(x_i^T \beta),} where \eqn{i} denotes the subject, \eqn{\lambda(\cdot)}{\lambda(.)} 45 | denotes the hazard function, conditionally on the frailty \eqn{\omega_i}, \eqn{x_i} is a vector of covariates with corresponding regression 46 | coefficients \eqn{\beta}, and \eqn{\lambda_0(\cdot)}{\lambda_0(.)} is the Weibull baseline hazard defined as \eqn{\lambda_0(t) = shape * 47 | scale * t^{shape -1}}. Finally, for the frailties we assume \eqn{\omega_i \sim Gamma(\eta, \eta)}{\omega_i ~ Gamma(\eta, \eta)}, with 48 | \eqn{\eta^{-1}} denoting the unknown variance of \eqn{\omega_i}'s. 49 | } 50 | 51 | \note{ 52 | \code{weibull.frailty()} currently supports only right-censored data. 53 | } 54 | 55 | \value{ 56 | an object of class \code{weibull.frailty} with components: 57 | \item{coefficients}{a list with the estimated coefficients values. The components of this list are: \code{betas}, \code{scale}, \code{shape}, 58 | and \code{var.frailty}, and correspond to the coefficients with the same name.} 59 | \item{hessian}{the hessian matrix at convergence. For the shape, scale, and var-frailty parameters the Hessian is computed on the log scale.} 60 | \item{logLik}{the log-likelihood value.} 61 | \item{control}{a copy of the \code{control} argument.} 62 | \item{y}{an object of class \code{Surv} containing the observed event times and the censoring indicator.} 63 | \item{x}{the design matrix of the model.} 64 | \item{id}{a numeric vector specifying which event times belong to the same cluster.} 65 | \item{nam.id}{the value of argument \code{id}, if that was a character string.} 66 | \item{terms}{the term component of the fitted model.} 67 | \item{data}{a copy of \code{data} or the created \code{model.frame}.} 68 | \item{call}{the matched call.} 69 | } 70 | 71 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 72 | 73 | \examples{ 74 | weibull.frailty(Surv(time, status) ~ age + sex, kidney) 75 | } 76 | 77 | \keyword{multivariate} 78 | \keyword{regression} 79 | 80 | -------------------------------------------------------------------------------- /man/xtable.Rd: -------------------------------------------------------------------------------- 1 | \name{xtable} 2 | 3 | \alias{xtable.jointModel} 4 | 5 | \title{xtable Method from Joint Models.} 6 | 7 | \description{ 8 | produces a LaTeX table with the results of a joint model using package xtable. 9 | } 10 | 11 | \usage{ 12 | \method{xtable}{jointModel}(x, caption = NULL, label = NULL, align = NULL, 13 | digits = NULL, display = NULL, which = c("all", "Longitudinal", "Event"), 14 | varNames.Long = NULL, varNames.Event = NULL, p.values = TRUE, 15 | digits.pval = 4, \dots) 16 | } 17 | 18 | \arguments{ 19 | \item{x}{an object inheriting from class \code{jointModel}.} 20 | \item{caption}{the \code{caption} argument of \code{xtable()}.} 21 | \item{label}{the \code{label} argument of \code{xtable()}.} 22 | \item{align}{the \code{align} argument of \code{xtable()}.} 23 | \item{digits}{the \code{digits} argument of \code{xtable()}.} 24 | \item{display}{the \code{display} argument of \code{xtable()}.} 25 | \item{which}{a character string indicating which results to include in the 26 | LaTeX table. Options are all results, the results of longitudinal 27 | submodel or the results of the survival submodel.} 28 | \item{varNames.Long}{a character vector of the variable names for the 29 | longitudinal submodel.} 30 | \item{varNames.Event}{a character vector of the variable names for the 31 | survival submodel.} 32 | \item{p.values}{logical; should p-values be included in the table.} 33 | \item{digits.pval}{a numeric scalare denoting the number of significance 34 | digits in the \eqn{p}-value.} 35 | \item{\dots}{additional arguments; currently none is used.} 36 | } 37 | 38 | \value{A LaTeX code chunk with the results of the joint modeling analysis.} 39 | 40 | \author{Dimitris Rizopoulos \email{d.rizopoulos@erasmusmc.nl}} 41 | 42 | 43 | \seealso{\code{\link{jointModel}}} 44 | 45 | \examples{ 46 | \dontrun{ 47 | require(xtable) 48 | prothro$t0 <- as.numeric(prothro$time == 0) 49 | lmeFit <- lme(pro ~ treat * (time + t0), random = ~ time | id, data = prothro) 50 | survFit <- coxph(Surv(Time, death) ~ treat, data = prothros, x = TRUE) 51 | jointFit <- jointModel(lmeFit, survFit, timeVar = "time", 52 | method = "weibull-PH-aGH") 53 | 54 | xtable(jointFit, math.style.negative = TRUE) 55 | } 56 | } 57 | 58 | \keyword{ methods } 59 | --------------------------------------------------------------------------------