Binary files 0.6-2.1-1/build/vignette.rds and 1.0.4-2/build/vignette.rds differ diff -pruN 0.6-2.1-1/ChangeLog 1.0.4-2/ChangeLog --- 0.6-2.1-1/ChangeLog 2014-12-09 13:08:17.000000000 +0000 +++ 1.0.4-2/ChangeLog 1970-01-01 00:00:00.000000000 +0000 @@ -1,147 +0,0 @@ -9-12-2014 Arthur Allignol - - * help page for ggtransfo + exmaples - * ggplot2 in suggest - * remove changeLOS from suggest. Update tests and - help pages accordingly - * rerun of the tests - -7-10-2014 Arthur Allignol - - Version 0.6-2 - * etm: Implementation of the variance of CIF with Lai and Ying - transformation. - -24-3-2014 Arthur Allignol - - Version 0.6-1 - * etmprep: Bug fix in error handling of the start argument - * etmprep: Bug fix in the dealing of to and from when state - names are given - -2013-9-19 Arthur Allignol - - * Version number 0.6 - * NEW: pseudo value regression for excess LoS (see closPseudo) - -2012-04-02 Arthur Allignol - - * new version 0.5-3 - * clos: All references to the changeLOS package removed from the doc - * etm: removed the use of .internal() - -2011-11-3 Arthur Allignol - - * etm: *EXPERIMENTAL* Product limit modification following Lai and Ying - -2010-12-6 Arthur Allignol - - * New version 0.5-2 - * sir.cont: Two new covariates age and sex - -2010-11-24 Arthur Allignol - - * New version number 0.5-1 - * CITATION: new file - -2010-11-3 Arthur Allignol - - * fourD : New data set - * etmCIF and methods print, summary, plot: New functions - Lead to add survival package in the dependencies - * etm: Fixed warning message when no censoring but still defined in the call - * etm and methods: Fix to deal with more complicated state names (e.g., - with characters with spaces) - * vignette: A vignette on etmCIF has been added. Has a view towards CIFs for pregnancy data - -2009-11-11 Arthur Allignol - - * lines.etm: New function - - * plot.etm: Rewritten. - Possibility to draw confidence intervals. - - * xyplot.etm: Consistency checking on tr.choice argument modified. - -2009-8-21 Arthur Allignol - - * Bug fix: in clos.cp and clos.nocp, O's were not in the right place for computing - the weighted summary when P(X_s = 1) . P(X_s = 0) = 0 - -2009-7-30 Arthur Allignol - - * print.etm and print.summary.etm now return nothing, - while before they returned x with the invisible flag set - - * Choice of the transformation for the confidence intervals - in the avec.cov function is now done with switch instead of - using several ifs - - * Bug correction: Tests on the tr.choice argument in xyplot, - trprob and trcov methods was done comparing it to the rownames - of the covariance matrix, which didn't make sense when etm was - called with argument covariance set to FALSE, and thrown an error - even if tr.choice was good. - -2009-7-28 Arthur Allignol - - * New function etmprep that transform data in the wide format - into the long format, in a way suitable for using the etm function. - - * New generics trprob and trcov and methods for etm objects. - -2009-6-12 Arthur Allignol - - * New plot function for clos.etm objects - -2009-6-9 Arthur Allignol - - * New aw argument to clos. Whether use alternative weighting - to compute the expected change in LOS - * Implementation of the alternative weighting - -2009-6-8 Arthur Allignol - - * New argument to etm: delta.na which decides whether to include in - the output the increments of the Nelson-Aalen estimator - * Implementation of the Change of Length of Stay following changeLOS - package. Though here, it works with left-truncated data, and - doesn't require competing outcomes - -2009-4-9 Arthur Allignol - - * New internal function ci.transfo() that transforms etm objects and computes pointwise CIs - * Modification of summary.etm that now uses ci.transform - * Modification of xyplot.etm. Uses ci.transform, and plots CI - * New data set abortion - -2009-2-4 Arthur Allignol - - * bug correction - -2009-1-9 Arthur Allignol - - * Modification of sir.cont.Rd - -2008-12-9 Arthur Allignol - - * Modification of print and summary - new arguments - * cov.dna now in C - -2008-11-19 Arthur Allignol - - * Modification of the print an summary methods - * Now result of summary is printed via print.summary.etm() - * In etm: better handling when there's no event between (s, t] - -2008-10-14 Arthur Allignol - - * Bug correction: now works when there is only 1 transient state. - * Modification of the part which transforms the data into counting process - * Modification of the C++ routine - that is now faster nd computes the increments - of the Nelson-Aalen estimator - * Add a plot function - - diff -pruN 0.6-2.1-1/debian/changelog 1.0.4-2/debian/changelog --- 0.6-2.1-1/debian/changelog 2018-06-14 07:59:44.000000000 +0000 +++ 1.0.4-2/debian/changelog 2018-09-10 07:19:56.000000000 +0000 @@ -1,3 +1,25 @@ +r-cran-etm (1.0.4-2) unstable; urgency=medium + + * Test-Depends: r-cran-kmi + Closes: #903672, #903719 + * Standards-Version: 4.2.1 + + -- Andreas Tille Mon, 10 Sep 2018 09:19:56 +0200 + +r-cran-etm (1.0.4-1) unstable; urgency=medium + + * New upstream version + * Standards-Version: 4.1.5 + + -- Andreas Tille Fri, 13 Jul 2018 14:09:54 +0200 + +r-cran-etm (1.0.3-1) unstable; urgency=medium + + * New upstream version + * dh-update-R to update Build-Depends + + -- Andreas Tille Mon, 09 Jul 2018 08:59:21 +0200 + r-cran-etm (0.6-2.1-1) unstable; urgency=medium * New upstream version diff -pruN 0.6-2.1-1/debian/control 1.0.4-2/debian/control --- 0.6-2.1-1/debian/control 2018-06-14 07:59:44.000000000 +0000 +++ 1.0.4-2/debian/control 2018-09-10 07:19:56.000000000 +0000 @@ -7,8 +7,11 @@ Build-Depends: debhelper (>= 11~), dh-r, r-base-dev, r-cran-survival, - r-cran-lattice -Standards-Version: 4.1.4 + r-cran-lattice, + r-cran-data.table, + r-cran-rcpp (>= 0.11.4), + r-cran-rcpparmadillo +Standards-Version: 4.2.1 Vcs-Browser: https://salsa.debian.org/r-pkg-team/r-cran-etm Vcs-Git: https://salsa.debian.org/r-pkg-team/r-cran-etm.git Homepage: https://cran.r-project.org/package=etm diff -pruN 0.6-2.1-1/debian/tests/control 1.0.4-2/debian/tests/control --- 0.6-2.1-1/debian/tests/control 2018-06-14 07:59:44.000000000 +0000 +++ 1.0.4-2/debian/tests/control 2018-09-10 07:19:56.000000000 +0000 @@ -1,3 +1,3 @@ Tests: run-unit-test -Depends: @ +Depends: @, r-cran-kmi Restrictions: allow-stderr diff -pruN 0.6-2.1-1/DESCRIPTION 1.0.4-2/DESCRIPTION --- 0.6-2.1-1/DESCRIPTION 2018-06-12 05:35:21.000000000 +0000 +++ 1.0.4-2/DESCRIPTION 2018-07-11 20:10:04.000000000 +0000 @@ -1,21 +1,16 @@ Package: etm +Type: Package Title: Empirical Transition Matrix -Version: 0.6-2.1 +Version: 1.0.4 Author: Arthur Allignol -Description: Matrix of transition probabilities for any time-inhomogeneous multistate model with finite state space. -Maintainer: ORPHANED -License: GPL (>= 2) -Depends: R (>= 2.14), survival -Imports: lattice +Description: The etm (empirical transition matrix) package permits to estimate the matrix of transition probabilities for any time-inhomogeneous multistate model with finite state space using the Aalen-Johansen estimator. Functions for data preparation and for displaying are also included (Allignol et al., 2011 ). Functionals of the Aalen-Johansen estimator, e.g., excess length-of-stay in an intermediate state, can also be computed (Allignol et al. 2011 ). +Maintainer: Arthur Allignol +License: MIT + file LICENSE +Depends: R (>= 3.0.0) +Imports: survival, lattice, data.table, Rcpp (>= 0.11.4) Suggests: ggplot2, kmi, geepack -Packaged: 2018-06-11 10:05:37 UTC; ripley +LinkingTo: Rcpp, RcppArmadillo NeedsCompilation: yes +Packaged: 2018-07-11 19:24:14 UTC; arthur Repository: CRAN -Date/Publication: 2018-06-11 12:38:32 -X-CRAN-Comment: Orphaned and corrected on 2018-06-11 as maintainer's - email address bounced. - . - and the other address for Arthur Allignol produced no response. The - 'obvious' C++ container error was corrected. -X-CRAN-Original-Maintainer: Arthur Allignol - +Date/Publication: 2018-07-11 20:10:04 UTC Binary files 0.6-2.1-1/inst/doc/etmCIF_tutorial.pdf and 1.0.4-2/inst/doc/etmCIF_tutorial.pdf differ diff -pruN 0.6-2.1-1/inst/doc/etmCIF_tutorial.R 1.0.4-2/inst/doc/etmCIF_tutorial.R --- 0.6-2.1-1/inst/doc/etmCIF_tutorial.R 2014-12-09 13:12:39.000000000 +0000 +++ 1.0.4-2/inst/doc/etmCIF_tutorial.R 2018-07-11 19:24:14.000000000 +0000 @@ -1,80 +1,81 @@ ### R code from vignette source 'etmCIF_tutorial.Rnw' ################################################### -### code chunk number 1: etmCIF_tutorial.Rnw:34-36 +### code chunk number 1: etmCIF_tutorial.Rnw:34-37 ################################################### -require(etm) +library(etm) +library(survival) data(abortion) ################################################### -### code chunk number 2: etmCIF_tutorial.Rnw:50-51 +### code chunk number 2: etmCIF_tutorial.Rnw:51-52 ################################################### head(abortion) ################################################### -### code chunk number 3: etmCIF_tutorial.Rnw:95-98 +### code chunk number 3: etmCIF_tutorial.Rnw:96-99 ################################################### -cif.abortion <- etmCIF(Surv(entry, exit, cause != 0) ~ group, +cif.abortion <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, etype = cause, failcode = 3) cif.abortion ################################################### -### code chunk number 4: etmCIF_tutorial.Rnw:107-108 +### code chunk number 4: etmCIF_tutorial.Rnw:108-109 ################################################### s.cif.ab <- summary(cif.abortion) ################################################### -### code chunk number 5: etmCIF_tutorial.Rnw:115-116 +### code chunk number 5: etmCIF_tutorial.Rnw:116-117 ################################################### s.cif.ab ################################################### -### code chunk number 6: etmCIF_tutorial.Rnw:128-129 +### code chunk number 6: etmCIF_tutorial.Rnw:129-130 ################################################### plot(cif.abortion) ################################################### -### code chunk number 7: etmCIF_tutorial.Rnw:144-147 +### code chunk number 7: etmCIF_tutorial.Rnw:145-148 ################################################### -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = 27, col = c(1, 2), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = 27, col = c(1, 2), ci.lwd = 6, lwd = 2, lty = 1, cex = 1.3) ################################################### -### code chunk number 8: etmCIF_tutorial.Rnw:166-169 +### code chunk number 8: etmCIF_tutorial.Rnw:167-170 ################################################### -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, lwd = 2, lty = c(2, 1), cex = 1.3) ################################################### -### code chunk number 9: etmCIF_tutorial.Rnw:182-184 +### code chunk number 9: etmCIF_tutorial.Rnw:183-185 ################################################### -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.5), +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.5), ci.type = "pointwise", col = c(1, 2), lwd = 2, lty = 1, cex = 1.3) ################################################### -### code chunk number 10: etmCIF_tutorial.Rnw:199-205 +### code chunk number 10: etmCIF_tutorial.Rnw:200-206 ################################################### plot(cif.abortion, which.cif = c(1, 2), ylim = c(0, 0.8), lwd = 2, col = c(1, 1, 2, 2), lty = c(1, 2, 1, 2), legend = FALSE) -legend(0, 0.8, c("Control", "Exposed"), col = c(1, 2), lty = 1, +legend(0, 0.8, c("Control", "Exposed"), col = c(1, 2), lty = 1, bty = "n", lwd = 2) -legend(0, 0.7, c("ETOP", "Life Birth"), col = 1, lty = c(1, 2), +legend(0, 0.7, c("ETOP", "Life Birth"), col = 1, lty = c(1, 2), bty = "n", lwd = 2) ################################################### -### code chunk number 11: etmCIF_tutorial.Rnw:225-231 +### code chunk number 11: etmCIF_tutorial.Rnw:226-232 ################################################### abortion$status <- with(abortion, ifelse(cause == 2, "life birth", ifelse(cause == 1, "ETOP", "spontaneous abortion"))) @@ -85,30 +86,30 @@ abortion$treat <- factor(abortion$treat) ################################################### -### code chunk number 12: etmCIF_tutorial.Rnw:236-239 +### code chunk number 12: etmCIF_tutorial.Rnw:237-240 ################################################### -new.cif <- etmCIF(Surv(entry, exit, status != 0) ~ treat, abortion, +new.cif <- etmCIF(Surv(entry, exit, status != 0) ~ treat, abortion, etype = status, failcode = "spontaneous abortion") new.cif ################################################### -### code chunk number 13: etmCIF_tutorial.Rnw:260-261 +### code chunk number 13: etmCIF_tutorial.Rnw:261-262 ################################################### trprob(new.cif[[1]], "0 spontaneous abortion", c(1, 10, 27)) ################################################### -### code chunk number 14: etmCIF_tutorial.Rnw:275-276 (eval = FALSE) +### code chunk number 14: etmCIF_tutorial.Rnw:276-277 (eval = FALSE) ################################################### ## lines(cif.abortion[[2]], tr.choice = "0 1", col = 2, lwd = 2) ################################################### -### code chunk number 15: etmCIF_tutorial.Rnw:281-285 +### code chunk number 15: etmCIF_tutorial.Rnw:282-286 ################################################### -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, lwd = 2, lty = c(2, 1), cex = 1.3) lines(cif.abortion[[2]], tr.choice = "0 1", col = 2, lwd = 2) diff -pruN 0.6-2.1-1/inst/doc/etmCIF_tutorial.Rnw 1.0.4-2/inst/doc/etmCIF_tutorial.Rnw --- 0.6-2.1-1/inst/doc/etmCIF_tutorial.Rnw 2014-12-09 13:12:39.000000000 +0000 +++ 1.0.4-2/inst/doc/etmCIF_tutorial.Rnw 2018-01-30 21:45:39.000000000 +0000 @@ -23,7 +23,7 @@ \section{Introduction} -This paper documents the use of the {\tt etmCIF} function to compute +This paper documents the use of the {\tt etmCIF} function to compute the cumulative incidence function (CIF) in pregnancy data. \section{Data Example} @@ -32,9 +32,10 @@ The data set {\tt abortion}, included in used to illustrate the computation of the CIFs. We first load the {\bf etm} package and the data set. <<>>= -require(etm) +library(etm) +library(survival) data(abortion) -@ +@ Briefly, the data set contains information on \Sexpr{nrow(abortion)} pregnant women collected prospectively by the Teratology Information @@ -43,13 +44,13 @@ Service of Berlin, Germany \citep{meiste to coumarin derivatives, a class of orally active anticoagulant, and \Sexpr{with(abortion, table(group)[1])} women served as controls. Coumarin derivatives are suspected to increase the number of -spontaneous abortions. Competing events are elective abortion (ETOP) and +spontaneous abortions. Competing events are elective abortion (ETOP) and life birth. Below is an excerpt of the data set <<>>= head(abortion) -@ +@ {\tt id} is the individual number, {\tt entry} is the gestational age at which the women entered the study, {\tt exit} is the gestational @@ -75,46 +76,46 @@ to facilitate the computation of the CIF means that any value different from 0 in {\tt cause} will be considered as an event -- which is the case in our example, as we don't have censoring. - + \item {\tt data}: A data set in which to interpret the terms of the formula. In our case, it will be {\tt abortion}. - + \item {\tt etype}: Competing risks event indicator. When the status indicator is 1 (or TRUE) in the formula, {\tt etype} describes the type of event, otherwise, for censored observation, the value of {\tt etype} is ignored. - + \item {\tt failcode}: Indicates the failure type of interest. Default is one. This option is only interesting for some features of the - plot function. + plot function. \end{itemize} \subsection{Estimation and display of the CIFs} We know compute the CIFs <<>>= -cif.abortion <- etmCIF(Surv(entry, exit, cause != 0) ~ group, +cif.abortion <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, etype = cause, failcode = 3) cif.abortion -@ +@ Above is the display provided by the {\tt print} function. It gives, at the last event time, the probabilities ({\tt P}) standard errors ({\tt se(P)}), and the total number of events ({\tt n.event}) for the -three possible pregnancy outcomes and for both groups. +three possible pregnancy outcomes and for both groups. More information is provided by the {\tt summary} function. <<>>= s.cif.ab <- summary(cif.abortion) -@ +@ The function returns a list of data.frames that contain probabilities, variances, pointwise confidence intervals, number at risk and number -of events for each event times. the {\tt print} function displays this +of events for each event times. the {\tt print} function displays this information for some selected event times. <<>>= s.cif.ab -@ +@ \subsection{Plotting the CIFs} @@ -127,7 +128,7 @@ CIFs for the event of interest, i.e., th \begin{center} <>= plot(cif.abortion) -@ +@ \caption{CIFs of spontaneous abortion for the controls (solid line) and the exposed (dashed line), using the default settings of the {\tt plot} function.} @@ -136,16 +137,16 @@ plot(cif.abortion) \clearpage -We now add confidence intervals taken at week 27, plus a +We now add confidence intervals taken at week 27, plus a bit of customisation. \setkeys{Gin}{width=0.9\textwidth} \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = 27, col = c(1, 2), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = 27, col = c(1, 2), ci.lwd = 6, lwd = 2, lty = 1, cex = 1.3) -@ +@ \caption{CIFs of spontaneous abortion for the controls (black) and the exposed (red), along with pointwise confidence intervals taken at week 27.} @@ -164,10 +165,10 @@ manipulating the {\tt pos.ci} argument: \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, lwd = 2, lty = c(2, 1), cex = 1.3) -@ +@ \caption{CIFs of spontaneous abortion for the controls (dashed line) and the exposed (solid line), along with pointwise confidence intervals.}\label{decalage} \end{center} @@ -180,9 +181,9 @@ follow-up period. \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.5), +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.5), ci.type = "pointwise", col = c(1, 2), lwd = 2, lty = 1, cex = 1.3) -@ +@ \caption{Same as the last pictures, except for the confidence intervals, that are displayed for the whole follow-up period.} \end{center} @@ -199,11 +200,11 @@ in the call to {\tt plot}. <>= plot(cif.abortion, which.cif = c(1, 2), ylim = c(0, 0.8), lwd = 2, col = c(1, 1, 2, 2), lty = c(1, 2, 1, 2), legend = FALSE) -legend(0, 0.8, c("Control", "Exposed"), col = c(1, 2), lty = 1, +legend(0, 0.8, c("Control", "Exposed"), col = c(1, 2), lty = 1, bty = "n", lwd = 2) -legend(0, 0.7, c("ETOP", "Life Birth"), col = 1, lty = c(1, 2), +legend(0, 0.7, c("ETOP", "Life Birth"), col = 1, lty = c(1, 2), bty = "n", lwd = 2) -@ +@ \end{center} \caption{CIFs of ETOP (solid lines) and life birth (dashed lines) for the exposed, in red, and the controls, in black.} @@ -219,7 +220,7 @@ For those who don't like using plain num events or the group allocation, it is of course possible to give more informative names, either as factors or character vectors. For instance, we define a new group variable that takes value {\tt 'control'} -or {\tt 'exposed'}, and we give more informative names for the pregnancy +or {\tt 'exposed'}, and we give more informative names for the pregnancy outcomes. <<>>= @@ -234,13 +235,13 @@ abortion$treat <- factor(abortion$treat) We can compute the CIFs as before, taking care of changing the {\tt failcode} argument. <<>>= -new.cif <- etmCIF(Surv(entry, exit, status != 0) ~ treat, abortion, +new.cif <- etmCIF(Surv(entry, exit, status != 0) ~ treat, abortion, etype = status, failcode = "spontaneous abortion") new.cif -@ +@ The {\tt summary} and {\tt plot} functions will work as before, except -for a more informative outcome from scratch. +for a more informative outcome from scratch. \paragraph{Taking advantage of the miscellaneous functions defined for {\tt etm} objects} @@ -249,17 +250,17 @@ The {\tt etmCIF} function uses the more for computing the CIFs. Thus the returned {\tt etmCIF} object is for part a list of {\tt etm} objects (one for each covariate level). It is therefore relatively easy to use the methods defined for {\tt etm} on -{\tt etmCIF} objects. +{\tt etmCIF} objects. An example would be to use the {\tt trprob} function to extract the CIF of spontaneous abortion for the controls. This function takes as arguments an {\tt etm} object, the transition we are interested in, in the form ``from to'' (the state a patient comes from is automatically -defined as being 0 in {\tt etmCIF}), and possibly some time points. +defined as being 0 in {\tt etmCIF}), and possibly some time points. Using {\tt new.cif} from the example above: <<>>= trprob(new.cif[[1]], "0 spontaneous abortion", c(1, 10, 27)) -@ +@ We applied the {\tt trprob} function to the {\tt etm} object for the controls (which is in the first item of the output, for the exposed in the second). The transition of interest is from {\tt 0} to {\tt @@ -274,16 +275,16 @@ in the {\tt trprob} function. <>= lines(cif.abortion[[2]], tr.choice = "0 1", col = 2, lwd = 2) -@ +@ \setkeys{Gin}{width=0.9\textwidth} \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, lwd = 2, lty = c(2, 1), cex = 1.3) lines(cif.abortion[[2]], tr.choice = "0 1", col = 2, lwd = 2) -@ +@ \caption{Figure \ref{decalage} along with the CIF of ETOP for the exposed in red.} \end{center} \end{figure} diff -pruN 0.6-2.1-1/LICENSE 1.0.4-2/LICENSE --- 0.6-2.1-1/LICENSE 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/LICENSE 2017-03-08 09:46:04.000000000 +0000 @@ -0,0 +1,2 @@ +YEAR: 2016 +COPYRIGHT HOLDER: Arthur Allignol \ No newline at end of file diff -pruN 0.6-2.1-1/man/closPseudo.Rd 1.0.4-2/man/closPseudo.Rd --- 0.6-2.1-1/man/closPseudo.Rd 2014-12-08 21:11:58.000000000 +0000 +++ 1.0.4-2/man/closPseudo.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -8,8 +8,11 @@ Pseudo Value Regression for the Extra Length-of-Stay } \usage{ -closPseudo(data, state.names, tra, cens.name, s = 0, formula, - aw = FALSE, ratio = FALSE, ncores = 1) +closPseudo(data, state.names, tra, cens.name, s = 0, + formula, na.action, + aw = FALSE, ratio = FALSE, + ncores = 1, + trick_ties = FALSE) } \arguments{ \item{data}{ @@ -33,13 +36,19 @@ closPseudo(data, state.names, tra, cens. \item{s}{Starting value for computing the transition probabilities.} \item{formula}{A formula with the covariates at the right of a \code{~} operator. Leave the left part empty.} - \item{aw}{Logical. Whether to compute the expected change of LOS using + \item{na.action}{A function which indicates what should happen when the data + contain 'NA's. The default is set by the 'na.action' setting + of 'options', and is 'na.fail' if that is unset. The + 'factory-fresh' default is 'na.omit'.} + \item{aw}{Logical. Whether to compute the expected change of LOS using alternative weighting. Default is \code{FALSE}.} \item{ratio}{Logical. Compute the ratio of the expected length-of-stay given instermediate event status instead of a difference. Default value is \code{FALSE}} \item{ncores}{Number of cores used if doing parallel computation using - the \pkg{parallel} package} + the \pkg{parallel} package} + \item{trick_ties}{If \code{TRUE}, pseudo values are computed only one + per subject sharing the same entry, exit times / transition types.} } \details{ The function calculates the pseudo-observations for the extra @@ -68,7 +77,7 @@ closPseudo(data, state.names, tra, cens. } \author{ - Arthur Allignol \email{arthur.allignol@uni-ulm.de} + Arthur Allignol \email{arthur.allignol@gmail.com} } \seealso{ diff -pruN 0.6-2.1-1/man/clos.Rd 1.0.4-2/man/clos.Rd --- 0.6-2.1-1/man/clos.Rd 2014-12-08 21:55:06.000000000 +0000 +++ 1.0.4-2/man/clos.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -1,12 +1,16 @@ \name{clos} \alias{clos} +\alias{clos.etm} +\alias{clos.msfit} \title{Change in Length of Stay} \description{ The function estimates the expected change in length of stay (LOS) associated with an intermediate event. } \usage{ -clos(x, aw = FALSE, ratio = FALSE) +clos(x, aw, ratio, ...) +\S3method{clos}{etm}(x, aw = FALSE, ratio = FALSE, ...) +\S3method{clos}{msfit}(x, aw = FALSE, ratio = FALSE, cox_model, ...) } \arguments{ \item{x}{An object of class \code{etm}. Argument \code{delta.na} in @@ -17,6 +21,8 @@ clos(x, aw = FALSE, ratio = FALSE) \item{ratio}{Logical. Compute the ratio of the expected length-of-stay given instermediate event status instead of a difference. Default value is \code{FALSE}} + \item{cox_model}{TODO} + \item{...}{Further arguments} } \details{ @@ -95,7 +101,7 @@ clos(x, aw = FALSE, ratio = FALSE) Aalen-Johansen estimator. \emph{R News} 6(2), 31--35. } -\author{Arthur Allignol \email{arthur.allignol@uni-ulm.de}, +\author{Arthur Allignol \email{arthur.allignol@gmail.com}, Matthias Wangler, Jan Beyersmann} \seealso{\code{\link{etm}}} \examples{ diff -pruN 0.6-2.1-1/man/etmCIF.Rd 1.0.4-2/man/etmCIF.Rd --- 0.6-2.1-1/man/etmCIF.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/etmCIF.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -46,17 +46,18 @@ etmCIF(formula, data, etype, subset, na. the levels of this covariate.} } \author{ - Arthur Allignol \email{arthur.alignol@uni-ulm.de} + Arthur Allignol \email{arthur.alignol@gmail.com} } \seealso{ \code{\link{etm}}, \code{\link{print.etmCIF}}, \code{\link{summary.etmCIF}}, \code{\link{plot.etmCIF}} } \examples{ + data(abortion) -cif.ab <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, - etype = cause, failcode = 3) +cif.ab <- etmCIF(survival::Surv(entry, exit, cause != 0) ~ group, abortion, + etype = cause, failcode = 3) cif.ab diff -pruN 0.6-2.1-1/man/etmprep.Rd 1.0.4-2/man/etmprep.Rd --- 0.6-2.1-1/man/etmprep.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/etmprep.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -60,7 +60,7 @@ start = NULL, id = NULL, keep) \item{\dots}{Further columns specified in \code{keep}} } \author{ - Arthur Allignol, \email{arthur.allignol@uni-ulm.de} + Arthur Allignol, \email{arthur.allignol@gmail.com} } \seealso{ \code{\link{etm}} diff -pruN 0.6-2.1-1/man/etm.Rd 1.0.4-2/man/etm.Rd --- 0.6-2.1-1/man/etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/etm.Rd 2018-02-04 21:03:14.000000000 +0000 @@ -1,5 +1,6 @@ \name{etm} \alias{etm} +\alias{etm.data.frame} \title{Computation of the empirical transition matrix} \description{ @@ -8,12 +9,12 @@ multistate model. The covariance matrix is also computed. } \usage{ -etm(data, state.names, tra, cens.name, s, t = "last", +\S3method{etm}{data.frame}(data, state.names, tra, cens.name, s, t = "last", covariance = TRUE, delta.na = TRUE, modif = FALSE, - alpha = 1/4, c = 1) + c = 1, alpha = NULL, strata, ...) } \arguments{ - \item{data}{ data.frame of the form data.frame(id,from,to,time) + \item{data}{data.frame of the form data.frame(id,from,to,time) or (id,from,to,entry,exit) \describe{ \item{id:}{patient id} @@ -43,8 +44,18 @@ etm(data, state.names, tra, cens.name, s increments of the Nelson-Aalen estimator. Default is \code{TRUE}.} \item{modif}{Logical. Whether to apply the modification of Lai and Ying for small risk sets} - \item{alpha}{Constant} - \item{c}{Constant} + \item{c}{Constant for the Lai and Ying modification. Either \code{c} + contains only one value that will be used for all the states, + otherwise \code{c} should be the same length as + \code{state.names}.} + \item{alpha}{Constant for the Lai and Ying modification. If NULL (the + default) then only \code{c} is used and the Lai and Ying + modification discards the event times for which \eqn{Y(t) \geq + t}{Y(t) >= t}. Otherwise \eqn{cn^\alpha}{cn^alpha} is used. It is + recommanded to let \code{alpha} equal NULL for multistate models.} + \item{strata}{Character vector giving variables on which to stratify + the analysis.} + \item{...}{Not used} } \details{ Data are considered to arise from a time-inhomogeneous Markovian @@ -95,6 +106,9 @@ etm(data, state.names, tra, cens.name, s Nelson-Aalen estimator.} \item{ind.n.risk}{When \code{modif} is true, risk set size for which the indicator function is 1} + + If the analysis is stratified, a list of \code{etm} objects is + returned. } \references{ Beyersmann J, Allignol A, Schumacher M: Competing Risks and Multistate @@ -124,7 +138,7 @@ etm(data, state.names, tra, cens.name, s Glidden, D. (2002). Robust inference for event probabilities with non-Markov data. \emph{Biometrics}, 58: 361-368. } -\author{Arthur Allignol, \email{arthur.allignol@uni-ulm.de}} +\author{Arthur Allignol, \email{arthur.allignol@gmail.com}} \note{Transitions into a same state, mathematically superfluous, are not allowed. If transitions into the same state are detected in the data, diff -pruN 0.6-2.1-1/man/ggtransfo.Rd 1.0.4-2/man/ggtransfo.Rd --- 0.6-2.1-1/man/ggtransfo.Rd 2014-12-09 13:12:29.000000000 +0000 +++ 1.0.4-2/man/ggtransfo.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,128 +0,0 @@ -\name{ggtransfo.etm} -\alias{ggtransfo.etm} -\alias{ggtransfo} - -\title{ - Prepare etm output for plotting with ggplot2 -} -\description{ - The \code{ggtransfo} function permits to transform the output of - \code{etm} such that transition probabilities along with confidence - intervals can be plotted more easily using the \pkg{ggplot2} package. -} -\usage{ -ggtransfo(x, ...) - -\S3method{ggtransfo}{etm}(x, tr.choice, ...) -} - -\arguments{ - \item{x}{An object of class 'etm'} - \item{tr.choice}{Character vector of the form 'c("from to","from - to")' specifying which transitions should be plotted. Default, all - the transition probabilities are plotted} - \item{\dots}{Further arguments. In particular for - \code{\link{summary.etm}} that is called internally} -} - -\value{ - A data frame with the same variables returned by - \code{\link{summary.etm}}. Addtional variables are - \item{trans}{transition type. In the same format as given by - \code{tr.choice}} - \item{timemax}{Lagged transition times for drawing confidence - intervals with \code{geom_rect}} - -} -\author{ - Arthur Allignol, \email{arthur.allignol@uni-ulm.de} -} - -\seealso{ -\code{\link{etm}}, \code{\link[ggplot2]{ggplot}}, -\code{\link[ggplot2]{geom_rect}} \code{\link[ggplot2]{geom_step}} -} -\examples{ -data(sir.cont) - -# Modification for patients entering and leaving a state -# at the same date -# Change on ventilation status is considered -# to happen before end of hospital stay -sir.cont <- sir.cont[order(sir.cont$id, sir.cont$time), ] -for (i in 2:nrow(sir.cont)) { - if (sir.cont$id[i]==sir.cont$id[i-1]) { - if (sir.cont$time[i]==sir.cont$time[i-1]) { - sir.cont$time[i-1] <- sir.cont$time[i-1] - 0.5 - } - } -} - -### Computation of the transition probabilities -# Possible transitions. -tra <- matrix(ncol=3,nrow=3,FALSE) -tra[1, 2:3] <- TRUE -tra[2, c(1, 3)] <- TRUE - -# etm -tr.prob <- etm(sir.cont, c("0", "1", "2"), tra, "cens", 1) - -to_plot <- ggtransfo(tr.prob, tr.choice = c("0 1", "1 0")) - -\dontrun{ -require(ggplot2) -print(ggplot(to_plot, aes(x = time, y = P)) + - facet_grid(. ~ trans) + - geom_step() + - geom_rect(aes(xmin = time, xmax = timemax, ymin = lower, ymax = upper), - alpha = 0.5) -) -} - -## abortion -data(abortion) - -cif.ab <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, - etype = cause, failcode = 3) - -pcif.ab <- lapply(cif.ab[1:2], ggtransfo, - tr.choice = c("0 1", "0 2", "0 3"), - ci.fun = "cloglog") - -pcif.ab[[1]]$Group <- "Control" -pcif.ab[[2]]$Group <- "Exposed" - -pcif.ab <- do.call(rbind, pcif.ab) -pcif.ab$Group <- factor(pcif.ab$Group) -pcif.ab$Group <- relevel(pcif.ab$Group, ref = "Exposed") -pcif.ab$out <- factor(pcif.ab$trans, labels = c("Spontaneous abortion", - "Induced abortion", - "Live birth"), - ordered = TRUE) - -\dontrun{ -require(ggplot2) - -ggplot(pcif.ab, aes(x = time, y = P)) + - facet_grid(. ~ out) + - geom_step(aes(colour = Group), size = 1.3) + - geom_rect(aes(xmin = time, xmax = timemax, ymin = lower, ymax = upper, fill = Group), - alpha = 0.5) + - scale_x_continuous("Week of gestation", limits = c(0, 45)) + - scale_y_continuous("CIF", limits = c(0, 1), breaks = seq(0, 1, 0.1)) + - theme(axis.text.x = element_text(size = 18), - axis.title.x = element_text(size = 18), - axis.text.y = element_text(size = 18), - axis.title.y = element_text(size = 18), - strip.text = element_text(size = 18, face = 2), - legend.text = element_text(size = 18), - legend.title = element_blank(), - legend.position = "top", - panel.background = element_rect(fill = grey(.93))) + - scale_colour_brewer(type = "qual", palette = 6) + - scale_fill_brewer(type = "qual", palette = 6) -} -} - -\keyword{hplot} -\keyword{dplot} diff -pruN 0.6-2.1-1/man/lines.etm.Rd 1.0.4-2/man/lines.etm.Rd --- 0.6-2.1-1/man/lines.etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/lines.etm.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -40,7 +40,7 @@ } \author{ - Arthur Allignol, \email{arthur.allignol@uni-ulm.de} + Arthur Allignol, \email{arthur.allignol@gmail.com} } \seealso{ diff -pruN 0.6-2.1-1/man/phiPseudo.Rd 1.0.4-2/man/phiPseudo.Rd --- 0.6-2.1-1/man/phiPseudo.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/phiPseudo.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -\name{phiPseudo} -\alias{phiPseudo} -%- Also NEED an '\alias' for EACH other topic documented here. -\title{ - Pseudo Value Regression for the Expected Excess Length of Stay -} -\description{ - Pseudo value regression for the expected excess length of stay for - each landmark time -} -\usage{ -phiPseudo(data, state.names, tra, cens.name, s = 0, formula, timepoints, ncores = 1) -} -%- maybe also 'usage' for other objects documented here. -\arguments{ - \item{data}{A data.frame in a format suitable for \code{\link{etm}}.} - \item{state.names}{A vector of characters giving the states names.} - \item{tra}{A quadratic matrix of logical values describing the possible - transitions within the multistate model.} - \item{cens.name}{ A character giving the code for censored - observations in the column 'to' of \code{data}. If there is no - censored observations in your data, put \code{NULL}} - \item{s}{Starting time for computing the transition probabilities.} - \item{formula}{A formula with the covariates at the right of a - \code{~} operator. The left hand side can be left empty.} - \item{timepoints}{Landmark time points at which the pseudo values are - computed.} - \item{ncores}{Number of cores used if doing parallel computation using - the \pkg{parallel} package} -} - -\details{ - The function calculates the pseudo-observations for the extra - length-of-stay at several landmark time points for each - individual. These pseudo-observations can then - be used to fit a direct regression model using generalized estimating - equation (e.g., package \pkg{geepack}). - - Computation of the pseudo-observations can be parallelised using the - \code{mclapply} function of the \pkg{parallel} package. See argument - \code{ncores}. -} -\value{ - An object of class \code{phiPseudo} with the following components: - \item{pseudoData}{a data.frame containing \code{id}, computed pseudo - values (see details) and the covariates as specified in the formula} - \item{phi}{Estimates of excess LoS in the whole sample} - \item{ps}{} -} -\references{ - Andersen, P.K, Klein, J.P, Rosthoj, S. (2003). Generalised - linear models for correlated pseudo-observations, - with applications to multi-state models. \emph{Biometrika}, - 90(1):15--27. -} - -\author{ - Arthur Allignol \email{arthur.allignol@uni-ulm.de} -} - -\seealso{ - \code{\link[parallel]{mclapply}}, \code{\link[etm]{clos}} -} - -\examples{ -## TODO -} -% Add one or more standard keywords, see file 'KEYWORDS' in the -% R documentation directory. -\keyword{survival} diff -pruN 0.6-2.1-1/man/plot.clos.etm.Rd 1.0.4-2/man/plot.clos.etm.Rd --- 0.6-2.1-1/man/plot.clos.etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/plot.clos.etm.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -45,7 +45,7 @@ legend.bty = "n", ...) No value returned } \author{ - Arthur Allignol \email{arthur.allignol@uni-ulm.de}, Matthias Wangler + Arthur Allignol \email{arthur.allignol@gmail.com}, Matthias Wangler } \seealso{ \code{\link{clos}} diff -pruN 0.6-2.1-1/man/plot.etmCIF.Rd 1.0.4-2/man/plot.etmCIF.Rd --- 0.6-2.1-1/man/plot.etmCIF.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/plot.etmCIF.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -60,7 +60,7 @@ No value returned } \author{ - Arthur Allignol \email{arthur.allignol@uni-ulm.de} + Arthur Allignol \email{arthur.allignol@gmail.com} } \seealso{ \code{\link{etmCIF}}, \code{\link{plot.etm}}, \code{\link{lines.etm}} @@ -68,8 +68,8 @@ \examples{ data(abortion) -cif.ab <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, - etype = cause, failcode = 3) +cif.ab <- etmCIF(survival::Surv(entry, exit, cause != 0) ~ group, abortion, + etype = cause, failcode = 3) cif.ab diff -pruN 0.6-2.1-1/man/plot.etm.Rd 1.0.4-2/man/plot.etm.Rd --- 0.6-2.1-1/man/plot.etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/plot.etm.Rd 2018-01-29 21:10:45.000000000 +0000 @@ -43,10 +43,20 @@ \item{legend.bty}{Box type for the legend} \item{\dots}{Further arguments for plot} } +\details{ + By default, if the argument \code{strata} was used for creating the \code{etm} + object, the first transition probability for all strata will be + plotted. If there is no strata, all transition probabilities are + plotted by default. + + In any case, a legend with be created by the labels are likely to be + ugly. Please use the \code{curvlab} argument to control the test or + use \code{legend = FALSE} and build your own legend. +} \value{ No value returned } -\author{Arthur Allignol, \email{arthur.allignol@uni-ulm.de}} +\author{Arthur Allignol, \email{arthur.allignol@gmail.com}} \seealso{\code{\link{plot.default}}, \code{\link{legend}}, \code{\link{etm}} } \examples{ data(sir.cont) diff -pruN 0.6-2.1-1/man/print.clos.etm.Rd 1.0.4-2/man/print.clos.etm.Rd --- 0.6-2.1-1/man/print.clos.etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/print.clos.etm.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -17,7 +17,7 @@ No value returned } \author{ - Arthur Allignol, \email{arthur.allignol@uni-ulm.de} + Arthur Allignol, \email{arthur.allignol@gmail.com} } \seealso{ \code{\link{clos}} diff -pruN 0.6-2.1-1/man/print.etmCIF.Rd 1.0.4-2/man/print.etmCIF.Rd --- 0.6-2.1-1/man/print.etmCIF.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/print.etmCIF.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -1,7 +1,7 @@ \name{print.etmCIF} \alias{print.etmCIF} \title{ - Print function for cifETM objects + Print function for \code{cifETM} objects } \description{ Print method for \code{cifETM} objects @@ -17,7 +17,7 @@ No value returned } \author{ - Arthur Allignol \email{arthur.allignol@uni-ulm.de} + Arthur Allignol \email{arthur.allignol@gmail.com} } \seealso{ \code{\link{etmCIF}} diff -pruN 0.6-2.1-1/man/print.etm.Rd 1.0.4-2/man/print.etm.Rd --- 0.6-2.1-1/man/print.etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/print.etm.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -5,7 +5,7 @@ Print method for objects of class \code{etm}. } \usage{ -\S3method{print}{etm}(x, covariance = TRUE, whole = TRUE, ...) +\S3method{print}{etm}(x, covariance = FALSE, whole = TRUE, ...) } \arguments{ \item{x}{An object of class \code{etm}.} @@ -24,6 +24,6 @@ \value{ No value returned } -\author{Arthur Allignol, \email{arthur.allignol@uni-ulm.de}} +\author{Arthur Allignol, \email{arthur.allignol@gmail.com}} \seealso{\code{\link{etm}}} \keyword{print} diff -pruN 0.6-2.1-1/man/summary.etmCIF.Rd 1.0.4-2/man/summary.etmCIF.Rd --- 0.6-2.1-1/man/summary.etmCIF.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/summary.etmCIF.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -33,7 +33,7 @@ \item{n.event}{Number of events at time \eqn{t}{t}} } \author{ - Arthur Allignol \email{arthur.allignol@uni-ulm.de} + Arthur Allignol \email{arthur.allignol@gmail.com} } \seealso{ \code{\link{etmCIF}} diff -pruN 0.6-2.1-1/man/summary.etm.Rd 1.0.4-2/man/summary.etm.Rd --- 0.6-2.1-1/man/summary.etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/summary.etm.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -6,14 +6,15 @@ Summary method for objects of class \code{etm} } \usage{ -\S3method{summary}{etm}(object, all = FALSE, - ci.fun = "linear", level = 0.95, ...) +\S3method{summary}{etm}(object, tr.choice, + ci.fun = "linear", level = 0.95, times, ...) \S3method{print}{summary.etm}(x, ...) } \arguments{ \item{object}{An object of class \code{etm}.} - \item{all}{If set to TRUE, a data.frame will be computed for all - transitions that are not 0 in the empirical transition matrix.} + \item{tr.choice}{Character vector of the form 'c("from to","from + to")' specifying which transitions should be summarized. Default to all + the transition probabilities} \item{ci.fun}{A character vector specifying the transformation to be applied to the pointwise confidence intervals. It could be different for each transition probability, though if \code{length(ci.fun) != @@ -27,6 +28,8 @@ \item{level}{Level of the two-sided confidence intervals. Default is 0.95.} \item{x}{A \code{summary.cpf} object} + \item{times}{Time points for which estimates should be + returned. Default to all transition times.} \item{\dots}{Further arguments} } \value{ @@ -42,7 +45,7 @@ just before time \eqn{t}{t}} \item{n.event}{Number of events at time \eqn{t}{t}} } -\author{Arthur Allignol \email{arthur.allignol@uni-ulm.de}} +\author{Arthur Allignol \email{arthur.allignol@gmail.com}} \seealso{\code{\link{etm}}} \keyword{methods} \keyword{print} diff -pruN 0.6-2.1-1/man/tra.Rd 1.0.4-2/man/tra.Rd --- 0.6-2.1-1/man/tra.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/tra.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -40,7 +40,7 @@ tra_surv(state.names = c("0", "1")) } \author{ - Arthur Allignol \email{arthur.allignol@uni-ulm.de} + Arthur Allignol \email{arthur.allignol@gmail.com} } \seealso{ diff -pruN 0.6-2.1-1/man/trprob_trcov.Rd 1.0.4-2/man/trprob_trcov.Rd --- 0.6-2.1-1/man/trprob_trcov.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/trprob_trcov.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -31,7 +31,7 @@ transition times. } \author{ - Arthur Allignol, \email{arthur.allignol@uni-ulm.de} + Arthur Allignol, \email{arthur.allignol@gmail.com} } \seealso{ \code{\link{etm}} diff -pruN 0.6-2.1-1/man/xyplot.etm.Rd 1.0.4-2/man/xyplot.etm.Rd --- 0.6-2.1-1/man/xyplot.etm.Rd 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/man/xyplot.etm.Rd 2018-01-13 22:38:06.000000000 +0000 @@ -38,6 +38,6 @@ \value{ An object of class \code{trellis}. } -\author{Arthur Allignol, \email{arthur.allignol@uni-ulm.de}} +\author{Arthur Allignol, \email{arthur.allignol@gmail.com}} \seealso{\code{\link{etm}}, \code{\link[lattice]{xyplot}}} \keyword{hplot} diff -pruN 0.6-2.1-1/MD5 1.0.4-2/MD5 --- 0.6-2.1-1/MD5 2018-06-12 05:35:22.000000000 +0000 +++ 1.0.4-2/MD5 2018-07-11 20:10:04.000000000 +0000 @@ -1,67 +1,71 @@ -d669fb109b9e87292da9d4201b52c7c9 *ChangeLog -fd87a6b41a19e36d21553d2a81ae90e5 *DESCRIPTION -b370cabe08c50082034b35ef18b337ac *NAMESPACE -c769759089889310b44037f7e19f70e7 *R/ci.transfo.R -161631858c05a6977a4d54263bb78266 *R/clos.R -d139e9461403cfe36837c0439720c1a7 *R/etm.R -3181f08b7c8e6c9c306ef4b299deca2f *R/etmCIF.R -91c190eca501eb828fb96f4fd476519f *R/extract.R -441c49e0a746a7db6a8a4a1215b751fd *R/ggtransfo.etm.R -34526139ea7e43e28181a7a04624b279 *R/lines.etm.R -02a37d5e97f248e95c43dcdac6388624 *R/misc.R -294bf2ed86d5a09fb528b776e0350eb9 *R/plot.clos.etm.R -d8cba6e584cbfb681e5e23d99f9315fc *R/plot.etm.R -13326457eca65d52983c2d6694026c3d *R/plot.etmCIF.R +346dfa103c4de2642957868d58949156 *DESCRIPTION +bf4771a352eea182f8857ae19ab39f31 *LICENSE +5b727d383e1ea6bef8ce90fee8d0534c *NAMESPACE +81e563f2b8cd21851f3d912c92cd3de9 *R/ci.transfo.R +c4795e68aac06a6ddadac766da16fe58 *R/clos.R +94e754d78ab8e1a9d0ac25318af1402d *R/clos_intern.R +31f457ed77326cc80ce76c90eba5e7d8 *R/clos_pure.R +b6b986414400880201eda0cbbe3d1ace *R/etm.R +f2f91c73d9d8437ee38b0c93ba3c5e75 *R/etmCIF.R +9eba3fc1a82886fd02c25d342765d5cb *R/etm_intern.R +1c839bfcf2d515d0263d523d1e9164db *R/extract.R +35b0bcccc2953598f9264c29afba5b0a *R/lines.etm.R +6b82e8c5d51e477168b184b9d36551e9 *R/misc.R +c97cc25b23be2232b60ee852a79f2742 *R/plot.clos.etm.R +41895dae402ca72ca3bbb27b27b66c62 *R/plot.etm.R +858c4c2bc25f0d57d74f76d6fc685a19 *R/plot.etmCIF.R 20031106830e8896903538717169541a *R/prepare.los.data.R f18f5b80b9470edaa72732e1852b3c81 *R/print.clos.etm.R -f293e5e4a831f1636abf65446b5a3f6c *R/print.etm.R -f087d944a523516bee415d5bdab898d0 *R/print.etmCIF.R -cf52ae3579e299ad0a6f57d998c960b0 *R/print.summary.etm.R -9639135f498d9298226ae02df87db62c *R/pseudo_clos.R -6b60e2b1f5e65ecf5480fd858cae7e98 *R/summary.etm.R -e65aacbc0b2bf7de232d5a419dc4e820 *R/summary.etmCIF.R -1c0e9ec7428a9f91839b880b22ec7565 *R/transfoData.R -ccbc25c8a47d56c4961cba60d48d9671 *R/xyplot.etm.R -2aaf40c683563d5bf3db07140fde8e94 *build/vignette.rds +abbecad22b15eebfd894218b38d9efb5 *R/print.etm.R +d5c58eef22053d56c05fa47ec6bf910f *R/print.etmCIF.R +60dd0e4ad256d9a9865fa83a6be5e357 *R/print.summary.etm.R +77d7c26f36805a040a7dd2d4dba5397e *R/pseudo_clos.R +cc734a939394a9a94a9473c5705ae13b *R/summary.etm.R +3d95d0044e7f34dae51be145af4d0cf4 *R/summary.etmCIF.R +e271dfe8da75a7ef545c085a158b63ee *R/transfoData.R +51ce105f7d32832c7ae823b78e5d2362 *R/xyplot.etm.R +22ffeb4077655dafa2616b2d62a50258 *R/zzz.R +81075f4111ecf686ba3e8248e748144c *README.md +89cef505068b8112456bbc040469c298 *build/vignette.rds 476bcb434771e9b96558abd030d09396 *data/abortion.txt.gz 6ab49cb48191ac4da0f54e4804f19ea1 *data/fourD.rda dcae240445955c2f848e08eb333100c2 *data/los.data.csv.gz baba7e394ff9255728343ee4dc10b546 *data/sir.cont.txt.gz 36b4ecf2f670d7cc5dbd8ffc8393bf39 *inst/CITATION -c04ec76345a113c49c88ff0015dd6976 *inst/doc/etmCIF_tutorial.R -1d3dd06a96abe63ec23af1df8a759eda *inst/doc/etmCIF_tutorial.Rnw -d5d343bc22b8b2afc41e7dff0b76a999 *inst/doc/etmCIF_tutorial.pdf +3c6bb46d26563280b6d7bf86a82b760e *inst/doc/etmCIF_tutorial.R +d995bff8026f0562f9b944ada1ed995c *inst/doc/etmCIF_tutorial.Rnw +0aa2ffe67815979fbd7d1b97f38ce150 *inst/doc/etmCIF_tutorial.pdf 5541acbfe1040be8fbb765e7d2f193fe *man/abortion.Rd -298fe0940bb5d53ace5a0e9d4cb790e6 *man/clos.Rd -e986af8cf8fbeaaf64fd080cb74f6014 *man/closPseudo.Rd -d10655aab3b4473c458db8a728c9cd42 *man/etm.Rd -87813817aac9adb8355c24aa48acf1df *man/etmCIF.Rd -24e166bb6e78e768b8686a2348afadaa *man/etmprep.Rd +6989cdf3614ab98dc901a9acd4ebe1ae *man/clos.Rd +a6b1f284f0091d00ec110eb6df56a64c *man/closPseudo.Rd +ba630645f4c94eee35e270c73c82ec80 *man/etm.Rd +271989b496081f4fd77463a7ecc82f1a *man/etmCIF.Rd +adc14b5a4c20fd0cdb15f1ce51480d3e *man/etmprep.Rd fd38028a1eabb4129f91a55efe1b1ea1 *man/fourD.Rd -49df768ad47ee3ddb9b92fe2ee7b5500 *man/ggtransfo.Rd -fb345ee72450087492d23b43bb67f33e *man/lines.etm.Rd +beafa275eb3031638c9c2ba9a70ddcfb *man/lines.etm.Rd c1b89e51669d0c7a05cced57bcb65931 *man/los.data.Rd -150641802b829978725aadc8fd7f7f95 *man/phiPseudo.Rd -b47923be875349fadae3ab51e17b3561 *man/plot.clos.etm.Rd -47989b691389928ae10d0aaa2c4c95c9 *man/plot.etm.Rd -3306d47cd6d768ca9869f4b544ace52f *man/plot.etmCIF.Rd +f17dca99e74128f1328ec1319537ca23 *man/plot.clos.etm.Rd +b19292b32bfa6ac5ca48353e21a22841 *man/plot.etm.Rd +cc29202e4d5e747bdeaf04d8755f5a05 *man/plot.etmCIF.Rd 37ece37de86bb13e66c65dd32fe9f884 *man/prepare.los.data.Rd -73575602cc041aea49b64a0fff90e29f *man/print.clos.etm.Rd -3de6acf45b4d863641b46b8d99cbab83 *man/print.etm.Rd -9e459a95d651bc276391c0dfdf6f58cf *man/print.etmCIF.Rd +00b1458078dc4e1f9622ecb700d5e21e *man/print.clos.etm.Rd +4ca64940f92d9b71c0dbc4efdb7b3efc *man/print.etm.Rd +56daf01bfa198bce09b75d76f71b7427 *man/print.etmCIF.Rd 474d026085ee1807de4de6426dcf549c *man/sir.cont.Rd -fe0facea35751ae612521566750302b5 *man/summary.etm.Rd -83bcbc426557dcec08f02a99eae3f229 *man/summary.etmCIF.Rd -c7061cba7c3e3106b2074ca58beba9fb *man/tra.Rd -6dd847e3ac794979dce68bc193d7018b *man/trprob_trcov.Rd -b8d5092f9391804dce102fd1998e28df *man/xyplot.etm.Rd -c7f5114c2954466b8fda5207bd5c7ee5 *src/cov_dna.c -5badeb419fe333c5a5cb7f423855d456 *src/los_etm.cc -a58cd565dd706afa4346ddd996a82959 *src/matrix.cc -bef22e0261a86cdd7d4044ac94c550e5 *src/matrix.h -d4c110cdbcab77b2f6a7b123065726df *src/risk_set_etm.c -3d17b4ab9ed7ca8a3663c169d20e251b *tests/test.etmCIF.R -272293fad90eb63d397f365a49a4fd6f *tests/test.etmCIF.Rout.save -5bc88e30c083317f1f35cc2de10ae812 *tests/tests.etm.R -b39cb79846ef3382614861486df05be5 *tests/tests.etm.Rout.save -1d3dd06a96abe63ec23af1df8a759eda *vignettes/etmCIF_tutorial.Rnw +e8a6b0d2101968441cba31902f4c77cc *man/summary.etm.Rd +c673ffbe169fc14c22762e957331e5eb *man/summary.etmCIF.Rd +b864fd140417a12c804315ad061a427a *man/tra.Rd +9b3d2c7f15770074499e0c75e844971a *man/trprob_trcov.Rd +c4f6038afd25a1e7d383d8e91cbb1ebf *man/xyplot.etm.Rd +ba32818dd84685090cce692c2a92298b *src/Makevars +8d46d69896a1f1d31ed76035a0e49d67 *src/Makevars.win +8b4a6007502cf8b2c74e3712e025dbc0 *src/cov_aj.cc +4a12b4c678109f26df68007d2d7eea41 *src/gen_msm.cpp +d5f5f251eb8f170e07624d9b308643c7 *src/init.c +8c8d9c0557fd89b3c9a725a238e6bb42 *src/los_etm.cpp +c6d79c413224332c4e5f9fbb55881da2 *src/utils.cpp +41dbe4abd670152e765d38d8cecc9239 *tests/test.etmCIF.R +da40f2ba3fb10cd13f538ff58d79391e *tests/test.etmCIF.Rout.save +08f54cfdacf2b09faf630b0fe20c3567 *tests/tests.etm.R +970c1508dc790d1f4b4c9e6cc88004da *tests/tests.etm.Rout.save +d995bff8026f0562f9b944ada1ed995c *vignettes/etmCIF_tutorial.Rnw diff -pruN 0.6-2.1-1/NAMESPACE 1.0.4-2/NAMESPACE --- 0.6-2.1-1/NAMESPACE 2018-06-11 09:59:53.000000000 +0000 +++ 1.0.4-2/NAMESPACE 2018-01-30 22:10:58.000000000 +0000 @@ -1,23 +1,49 @@ -import(lattice, survival, parallel) -export(etm, summary.etm, clos, trcov, trprob, ggtransfo, etmprep, - etmCIF, summary.etmCIF, closPseudo, phiPseudo, - tra_ill, tra_ill_comp, tra_comp, tra_surv, prepare.los.data) +useDynLib(etm, .registration = TRUE) + +importFrom(Rcpp, evalCpp) + +import(parallel, data.table) +importFrom("survival", "Surv", "survfit", "is.Surv") +importFrom("lattice", "xyplot") + +importFrom("graphics", "axis", "box", "close.screen", "lines", "par", + "plot", "screen", "split.screen", "segments") +importFrom("stats", "qnorm", "quantile", "model.extract", "terms", "model.frame") + +export(etm, + clos, + tra_ill, + tra_ill_comp, + tra_comp, + tra_surv, + prepare.los.data, + trprob, + trcov, + etmCIF, + etmprep, + closPseudo) + +S3method(etm, data.frame) +S3method(clos, msfit) +S3method(clos, etm) +S3method(print, clos.etm) +S3method(plot, clos.etm) S3method(xyplot, etm) S3method(print, etm) +S3method("[", etm) S3method(summary, etm) S3method(print, summary.etm) S3method(plot, etm) S3method(lines, etm) -S3method(print, clos.etm) -S3method(plot, clos.etm) S3method(trprob, etm) S3method(trcov, etm) S3method(print, etmCIF) S3method(plot, etmCIF) S3method(summary, etmCIF) S3method(print, summary.etmCIF) -S3method(ggtransfo, etm) -importFrom("graphics", "axis", "box", "close.screen", "lines", "par", - "plot", "screen", "segments", "split.screen") -importFrom("stats", "model.extract", "qnorm", "quantile", "terms") -useDynLib(etm, risk_set_etm, cov_dna, los_cp, los_nocp) + +## useDynLib(etm, .registration = TRUE) + +## exportPattern("^[[:alpha:]]+") + + diff -pruN 0.6-2.1-1/R/ci.transfo.R 1.0.4-2/R/ci.transfo.R --- 0.6-2.1-1/R/ci.transfo.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/ci.transfo.R 2018-01-23 21:16:47.000000000 +0000 @@ -34,15 +34,15 @@ avec.cov <- function(i, object, transfo, upper <- pmin(upper, 1) data.frame(P, time, var, lower, upper, n.risk, n.event) } - + +## Should be used without strata (Give it single etm object) ci.transfo <- function(object, tr.choice, level = 0.95, transfo = "linear") { - if (!inherits(object, "etm")) { - stop ("'x' must be of class 'etm'") - } + lt <- length(tr.choice) trs <- tr.choice trs.sep <- lapply(trs, strsplit, split = " ") + ## Fixing separation of states with names including a space for (i in seq_along(trs.sep)) { if (length(trs.sep[[i]][[1]]) == 2) { @@ -52,6 +52,7 @@ ci.transfo <- function(object, tr.choice trs.sep[[i]][[1]] <- object$state.names[tt] } } + trs.sep <- matrix(unlist(trs.sep), length(trs.sep), 2, byrow = TRUE) if (length(transfo) != lt) transfo <- rep(transfo[1], lt) @@ -65,4 +66,4 @@ ci.transfo <- function(object, tr.choice names(res) <- tr.choice res } - + diff -pruN 0.6-2.1-1/R/clos_intern.R 1.0.4-2/R/clos_intern.R --- 0.6-2.1-1/R/clos_intern.R 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/R/clos_intern.R 2017-03-08 09:46:04.000000000 +0000 @@ -0,0 +1,145 @@ +### To be used for single endpoint +clos.nocp <- function(x, aw, ratio) { + + dims <- dim(x$est) + los <- matrix(rep(x$time, 3), ncol = 3, byrow = FALSE) + tau <- max(x$data$exit) + times <- x$time + surv <- x$est[1, 1, ] + + ## Call to C++ function + out <- .Call("los_nocp", + times, + x$delta.na, + tau) + + los[, 2] <- out$los0 + los[, 3] <- out$los1 + indi <- apply(x$n.event, 3, function(x) {sum(x[1, ]) != 0}) + wait.times <- x$time[indi] + wait.prob <- x$est[1, 1, ][indi] + + pp <- x$n.risk[-1, ] + ev.last <- apply(x$n.event[, , dims[3]], 1, sum)[1:2] + pp <- rbind(pp, pp[nrow(pp), ] - ev.last) + filtre <- pp[, 1] <= 0 | pp[, 2] <= 0 + + if (ratio) { + los.diff <- los[, 3] / los[, 2] + } else { + los.diff <- los[, 3] - los[, 2] + } + los.diff[filtre] <- 0 + my.weights <- diff(c(0, 1 - wait.prob)) + estimate <- matrix(los.diff[is.element(los[, 1], wait.times)], nrow = 1) %*% + matrix(my.weights, ncol=1) + + e.phi.w1 <- e.phi.w2 <- my.weights1 <- my.weights2 <- NULL + if (aw) { + I <- diag(1, dims[1]) + tr.mat <- array(apply(x$delta.na, 3, "+", I), dim = dims) + cif1 <- cumsum(c(1, x$est[1, 1, 1:(dims[3] - 1)]) * tr.mat[1, 2, ]) + my.weights1 <- diff(c(0, cif1[indi])) / cif1[length(cif1)] + cif2 <- cumsum(c(1, x$est[1, 1, 1:(dims[3] - 1)]) * tr.mat[1, 3, ]) + my.weights2 <- diff(c(0, cif2[indi])) / cif2[length(cif2)] + weights.aw <- list(my.weights1, my.weights2) + estimates.aw <- lapply(weights.aw, function(z) { + ldiff <- los[, 3] - los[, 2] + ldiff[filtre] <- 0 + estimate <- matrix(ldiff[is.element(los[, 1], wait.times)], nrow = 1) %*% + matrix(z, ncol = 1) + estimate + }) + e.phi.w1 <- estimates.aw[[1]] + e.phi.w2 <- estimates.aw[[2]] + } + + res <- list(e.phi = estimate[[1]], phi.case = los[, 3], + phi.control = los[, 2], weights = my.weights, + w.time = wait.times, time = x$time, e.phi.weights.1 = e.phi.w1, + e.phi.weights.other = e.phi.w2, weights.1 = my.weights1, + weights.other = my.weights2) + res +} + + +####################################### +## The competing risks version +####################################### +clos.cp <- function(x, aw, ratio) { + + dims <- dim(x$est) + los <- matrix(rep(x$time, 3), ncol = 3, byrow = FALSE) + phi2 <- matrix(data=c(x$time, rep(0, dims[3]), rep(0, dims[3])), + ncol=3, byrow=FALSE) + phi3 <- matrix(data=c(x$time, rep(0, dims[3]), rep(0, dims[3])), + ncol=3, byrow=FALSE) + ind.cens <- apply(x$n.event, 3, function(r) all(r == 0)) + times <- x$time + tau <- max(x$time) + + out <- .Call("los_cp", + times, + x$delta.na, + tau) + + los[, 2] <- out$los0 + los[, 3] <- out$los1 + phi2[, 3] <- out$phi2case; phi2[, 2] <- out$phi2control + phi3[, 3] <- out$phi3case; phi3[, 2] <- out$phi3control + indi <- apply(x$n.event, 3, function(x) {sum(x[1, ]) != 0}) + wait.times <- x$time[indi] + wait.prob <- x$est[1, 1, ][indi] + my.weights <- diff(c(0, 1 - wait.prob)) + + pp <- x$n.risk[-1, ] + ev.last <- apply(x$n.event[, , dims[3]], 1, sum)[1:2] + pp <- rbind(pp, pp[nrow(pp), ] - ev.last) + filtre <- pp[, 1] <= 0 | pp[, 2] <= 0 + + tmp <- list(los, phi2, phi3) + estimates <- lapply(tmp, function(z) { + if (ratio) { + ldiff <- z[, 3] / z[, 2] + } else { + ldiff <- z[, 3] - z[, 2] + } + ldiff[filtre] <- 0 + estimate <- matrix(ldiff[is.element(z[, 1], wait.times)], nrow = 1) %*% + matrix(my.weights, ncol=1) + estimate + }) + + e.phi.w1 <- e.phi.w23 <- my.weights1 <- my.weights23 <- NULL + if (aw) { + I <- diag(1, dims[1]) + tr.mat <- array(apply(x$delta.na, 3, "+", I), dim = dims) + cif1 <- cumsum(c(1, x$est[1, 1, 1:(dims[3] - 1)]) * tr.mat[1, 2, ]) + my.weights1 <- diff(c(0, cif1[indi])) / cif1[length(cif1)] + cif23 <- cumsum(c(1, x$est[1, 1, 1:(dims[3] - 1)]) * + (tr.mat[1, 3, ] + tr.mat[1, 4, ])) + my.weights23 <- diff(c(0, cif23[indi])) / cif23[length(cif23)] + weights.aw <- list(my.weights1, my.weights23) + estimates.aw <- lapply(weights.aw, function(z) { + ldiff <- los[, 3] - los[, 2] + ldiff[filtre] <- 0 + estimate <- matrix(ldiff[is.element(los[, 1], wait.times)], nrow = 1) %*% + matrix(z, ncol = 1) + estimate + }) + e.phi.w1 <- estimates.aw[[1]] + e.phi.w23 <- estimates.aw[[2]] + } + + res <- list(e.phi = estimates[[1]], phi.case = los[, 3], + phi.control = los[, 2], e.phi2 = estimates[[2]], + phi2.case = phi2[, 3], phi2.control = phi2[, 2], + e.phi3 = estimates[[3]], phi3.case = phi3[, 3], + phi3.control = phi3[, 2], weights = my.weights, + w.time = wait.times, time = x$time, e.phi.weights.1 = e.phi.w1, + e.phi.weights.other = e.phi.w23, weights.1 = my.weights1, + weights.other = my.weights23) + res +} + + diff -pruN 0.6-2.1-1/R/clos_pure.R 1.0.4-2/R/clos_pure.R --- 0.6-2.1-1/R/clos_pure.R 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/R/clos_pure.R 2017-03-08 09:46:04.000000000 +0000 @@ -0,0 +1,192 @@ +clos_pure <- function(x, aw = FALSE) { + if (!inherits(x, "etm")) { + stop("'x' must be an 'etm' object") + } + if (is.null(x$delta.na)) { + stop("Needs the increment of the Nelson-Aalen estimator") + } + absorb <- setdiff(levels(x$trans$to), levels(x$trans$from)) + transient <- unique(x$state.names[!(x$state.names %in% absorb)]) + if (!(length(transient) == 2 && length(absorb) %in% c(1, 2))) + stop("The multistate model must have 2 transient states \n and 1 or 2 absorbing states") + dims <- dim(x$est) + comp.risk <- FALSE + if (dims[1] == 4) comp.risk <- TRUE + I <- diag(1, dims[1]) + tr.mat <- array(apply(x$delta.na, 3, "+", I), dim = dims) + #tr.mat <- x$delta.na + if (comp.risk) { + res <- clos.cp(x, tr.mat, aw) + } + else res <- clos.nocp(x, tr.mat, aw) + class(res) <- "clos.etm" + res +} + +clos.cp_pure <- function(x, tr.mat, aw) { + dims <- dim(x$est) + times <- if (sum(x$n.event[, , dims[3]]) != 0) x$time else x$time[-length(x$time)] + los <- matrix(rep(times, 3), ncol = 3, byrow = FALSE) + phi2 <- phi3 <- matrix(0, nrow(los), 3) + phi2[, 1] <- times; phi3[, 1] <- times + lt <- length(times) + tau <- max(times) + los[length(times)-1, 2:3] <- rep(tau, 2) + aj <- array(NA, c(4, 4, 1)) + aj[, , 1] <- diag(1, 4, 4) + + funn <- function(x, y) { + x %*% aj[ , , y] + } + + for (i in (lt - 2):1) { + diffs <- diff(times[(i + 1):length(times)]) + mat <- tr.mat[ , , length(x$time[x$time <= times[i + 1]])] + aj <- array(apply(X = diag(1:dim(aj)[3]), 1, funn, x = mat), c(4, 4, dim(aj)[3])) + los[i, 3] <- times[i + 1] + matrix(diffs, nrow=1) %*% + matrix(aj[2, 2, ], ncol = 1) + los[i, 2] <- times[i + 1] + matrix(diffs, nrow=1) %*% + matrix((aj[1, 1, ] + aj[1, 2, ]),ncol=1) + phi2[i, 2] <- aj[2, 3, dim(aj)[3]] * los[i, 3] + aj <- array(c(diag(1, 4, 4), aj), c(4, 4, (dim(aj)[3] + 1))) + } + +## phi2[, 3] <- out$phi2case; phi2[, 2] <- out$phi2control +## phi3[, 3] <- out$phi3case; phi3[, 2] <- out$phi3control + indi <- apply(x$n.event, 3, function(x) {sum(x[1, ]) != 0}) + wait.times <- x$time[indi] + wait.prob <- x$est["0", "0", ][indi] + my.weights <- diff(c(0, 1 - wait.prob)) + + pp <- x$n.risk[-1, ] + ev.last <- apply(x$n.event[, , dims[3]], 1, sum)[1:2] + pp <- rbind(pp, pp[nrow(pp), ] - ev.last) + filtre <- pp[, 1] <= 0 | pp[, 2] <= 0 + + tmp <- list(los)#, phi2, phi3) + estimates <- lapply(tmp, function(z) { + ldiff <- z[, 3] - z[, 2] + ldiff[filtre] <- 0 + estimate <- matrix(ldiff[is.element(z[, 1], wait.times)], nrow = 1) %*% + matrix(my.weights, ncol=1) + estimate + }) + + e.phi.w1 <- e.phi.w23 <- my.weights1 <- my.weights23 <- NULL + if (aw) { + cif1 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * tr.mat[1, 2, ]) + my.weights1 <- diff(c(0, cif1[indi])) / cif1[length(cif1)] + cif23 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * + (tr.mat[1, 3, ] + tr.mat[1, 4, ])) + my.weights23 <- diff(c(0, cif23[indi])) / cif23[length(cif23)] + weights.aw <- list(my.weights1, my.weights23) + estimates.aw <- lapply(weights.aw, function(z) { + ldiff <- los[, 3] - los[, 2] + ldiff[filtre] <- 0 + estimate <- matrix(ldiff[is.element(los[, 1], wait.times)], nrow = 1) %*% + matrix(z, ncol = 1) + estimate + }) + e.phi.w1 <- estimates.aw[[1]] + e.phi.w23 <- estimates.aw[[2]] + } + res <- list(e.phi = estimates[[1]], phi.case = los[, 3], + phi.control = los[, 2], ## e.phi2 = estimates[[2]], +## phi2.case = phi2[, 3] +## phi2.control = phi2[, 2] +## e.phi3 = estimates[[3]], phi3.case = phi3[, 3], +## phi3.control = phi3[, 2], + weights = my.weights, + w.time = wait.times, time = x$time, e.phi.weights.1 = e.phi.w1, + e.phi.weights.other = e.phi.w23, weights.1 = my.weights1, + weights.other = my.weights23) + res +} + + + +clos.nocp_pure <- function(x, tr.mat, aw) { + dims <- dim(x$est) + times <- if (sum(x$n.event[, , dims[3]]) != 0) x$time else x$time[-length(x$time)] + los <- matrix(rep(times, 3), ncol = 3, byrow = FALSE) + lt <- length(times) + tau <- max(times) + los[length(times)-1, 2:3] <- rep(tau, 2) + aj <- array(NA, c(3, 3, 1)) + aj[, , 1] <- diag(1, 3, 3) + + funn <- function(x, y) { + x %*% aj[ , , y] + } + + for (i in (lt - 2):1) { + print(i) + diffs <- diff(times[(i + 1):length(times)]) + mat <- tr.mat[ , , length(x$time[x$time <= times[i + 1]])] + aj <- array(apply(X = diag(1:dim(aj)[3]), 1, funn, + x = mat), c(3, 3, dim(aj)[3])) + los[, 3][i] <- times[i + 1] + matrix(diffs, nrow=1) %*% + matrix(aj[2, 2, ], ncol = 1) + los[, 2][i] <- times[i + 1] + matrix(diffs, nrow=1) %*% + matrix((aj[1, 1, ] + aj[1,2,]),ncol=1) + aj <- array(c(diag(1, 3, 3), aj), c(3, 3, (dim(aj)[3] + 1))) + } + + pp <- x$n.risk[-1, ] + ev.last <- apply(x$n.event[, , dims[3]], 1, sum)[1:2] + pp <- rbind(pp, pp[nrow(pp), ] - ev.last) + filtre <- pp[, 1] <= 0 | pp[, 2] <= 0 + + indi <- apply(x$n.event, 3, function(x) {sum(x[1, ]) != 0}) + wait.times <- x$time[indi] + wait.prob <- x$est["0", "0", ][indi] + los.diff <- los[, 3] - los[, 2] + los.diff[filtre] <- 0 + my.weights <- diff(c(0, 1 - wait.prob)) + estimate <- matrix(los.diff[is.element(los[, 1], wait.times)], nrow = 1) %*% + matrix(my.weights, ncol=1) + e.phi.w1 <- e.phi.w2 <- my.weights1 <- my.weights2 <- NULL + if (aw) { + cif1 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * tr.mat[1, 2, ]) + my.weights1 <- diff(c(0, cif1[indi])) / cif1[length(cif1)] + cif2 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * tr.mat[1, 3, ]) + my.weights2 <- diff(c(0, cif2[indi])) / cif2[length(cif2)] + weights.aw <- list(my.weights1, my.weights2) + estimates.aw <- lapply(weights.aw, function(z) { + ldiff <- los[, 3] - los[, 2] + ldiff[filtre] <- 0 + estimate <- matrix(ldiff[is.element(los[, 1], wait.times)], nrow = 1) %*% + matrix(z, ncol = 1) + estimate + }) + e.phi.w1 <- estimates.aw[[1]] + e.phi.w2 <- estimates.aw[[2]] + } + res <- list(e.phi = estimate[[1]], phi.case = los[, 3], + phi.control = los[, 2], weights = my.weights, + w.time = wait.times, time = x$time, e.phi.weights.1 = e.phi.w1, + e.phi.weights.other = e.phi.w2, weights.1 = my.weights1, + weights.other = my.weights2, aj = aj) + res +} + + +boot.clos <- function(data, state.names, tra, cens.name, s = 0, nboot) { + res <- double(nboot) + for (i in seq_len(nboot)) { + index <- sample(unique(data$id), replace = TRUE) + inds <- new.id <- NULL + for (j in seq_along(index)){ + ind <- which(data$id == index[j]) + new.id <- c(new.id, rep(j, length(ind))) + inds <- c(inds, ind) + } + dboot <- cbind(data[inds, ], new.id) + dboot[, which(names(dboot) == "id")] + dboot$id <- dboot$new.id + tr.prob <- etm(dboot, state.names, tra, cens.name, s, cova = FALSE) + res[i] <- clos(tr.prob)$e.phi + } + res +} + diff -pruN 0.6-2.1-1/R/clos.R 1.0.4-2/R/clos.R --- 0.6-2.1-1/R/clos.R 2014-12-08 21:11:58.000000000 +0000 +++ 1.0.4-2/R/clos.R 2018-01-29 20:57:07.000000000 +0000 @@ -1,172 +1,139 @@ -### To be used for competing endpoints -clos.cp <- function(x, tr.mat, aw, ratio) { - dims <- dim(x$est) - los <- matrix(rep(x$time, 3), ncol = 3, byrow = FALSE) - phi2 <- matrix(data=c(x$time, rep(0, dims[3]), rep(0, dims[3])), - ncol=3, byrow=FALSE) - phi3 <- matrix(data=c(x$time, rep(0, dims[3]), rep(0, dims[3])), - ncol=3, byrow=FALSE) - ind.cens <- apply(x$n.event, 3, function(r) all(r == 0)) - tau <- max(x$time[ind.cens], x$time) - - out <- .C(los_cp, - as.double(x$time), - as.double(tr.mat), - as.integer(dims[3]), - as.integer(dims[1]), - as.integer(dims[2]), - los1 = as.double(los[,2]), - los0 = as.double(los[,3]), - phi2case = as.double(phi2[,2]), - phi2control = as.double(phi2[,3]), - phi3case = as.double(phi3[,2]), - phi3control = as.double(phi3[,3]), - as.double(tau)) - - los[, 2] <- out$los0 - los[, 3] <- out$los1 - phi2[, 3] <- out$phi2case; phi2[, 2] <- out$phi2control - phi3[, 3] <- out$phi3case; phi3[, 2] <- out$phi3control - indi <- apply(x$n.event, 3, function(x) {sum(x[1, ]) != 0}) - wait.times <- x$time[indi] - wait.prob <- x$est["0", "0", ][indi] - my.weights <- diff(c(0, 1 - wait.prob)) - - pp <- x$n.risk[-1, ] - ev.last <- apply(x$n.event[, , dims[3]], 1, sum)[1:2] - pp <- rbind(pp, pp[nrow(pp), ] - ev.last) - filtre <- pp[, 1] <= 0 | pp[, 2] <= 0 - - tmp <- list(los, phi2, phi3) - estimates <- lapply(tmp, function(z) { - if (ratio) { - ldiff <- z[, 3] / z[, 2] - } else { - ldiff <- z[, 3] - z[, 2] - } - ldiff[filtre] <- 0 - estimate <- matrix(ldiff[is.element(z[, 1], wait.times)], nrow = 1) %*% - matrix(my.weights, ncol=1) - estimate - }) - - e.phi.w1 <- e.phi.w23 <- my.weights1 <- my.weights23 <- NULL - if (aw) { - cif1 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * tr.mat[1, 2, ]) - my.weights1 <- diff(c(0, cif1[indi])) / cif1[length(cif1)] - cif23 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * - (tr.mat[1, 3, ] + tr.mat[1, 4, ])) - my.weights23 <- diff(c(0, cif23[indi])) / cif23[length(cif23)] - weights.aw <- list(my.weights1, my.weights23) - estimates.aw <- lapply(weights.aw, function(z) { - ldiff <- los[, 3] - los[, 2] - ldiff[filtre] <- 0 - estimate <- matrix(ldiff[is.element(los[, 1], wait.times)], nrow = 1) %*% - matrix(z, ncol = 1) - estimate - }) - e.phi.w1 <- estimates.aw[[1]] - e.phi.w23 <- estimates.aw[[2]] - } - - res <- list(e.phi = estimates[[1]], phi.case = los[, 3], - phi.control = los[, 2], e.phi2 = estimates[[2]], - phi2.case = phi2[, 3], phi2.control = phi2[, 2], - e.phi3 = estimates[[3]], phi3.case = phi3[, 3], - phi3.control = phi3[, 2], weights = my.weights, - w.time = wait.times, time = x$time, e.phi.weights.1 = e.phi.w1, - e.phi.weights.other = e.phi.w23, weights.1 = my.weights1, - weights.other = my.weights23) - res -} +### Expected change of LoS +### Arthur Allignol +##################################################################### -### To be used for single endpoint -clos.nocp <- function(x, tr.mat, aw, ratio) { - dims <- dim(x$est) - los <- matrix(rep(x$time, 3), ncol = 3, byrow = FALSE) - tau <- max(x$time) - - out <- .C(los_nocp, - as.double(x$time), - as.double(tr.mat), - as.integer(dims[3]), - as.integer(dims[1]), - as.integer(dims[2]), - los1 = as.double(los[,2]), - los0 = as.double(los[,3]), - as.double(tau)) - - los[, 2] <- out$los0 - los[, 3] <- out$los1 - indi <- apply(x$n.event, 3, function(x) {sum(x[1, ]) != 0}) - wait.times <- x$time[indi] - wait.prob <- x$est["0", "0", ][indi] - - pp <- x$n.risk[-1, ] - ev.last <- apply(x$n.event[, , dims[3]], 1, sum)[1:2] - pp <- rbind(pp, pp[nrow(pp), ] - ev.last) - filtre <- pp[, 1] <= 0 | pp[, 2] <= 0 - - if (ratio) { - los.diff <- los[, 3] / los[, 2] - } else { - los.diff <- los[, 3] - los[, 2] - } - los.diff[filtre] <- 0 - my.weights <- diff(c(0, 1 - wait.prob)) - estimate <- matrix(los.diff[is.element(los[, 1], wait.times)], nrow = 1) %*% - matrix(my.weights, ncol=1) - - e.phi.w1 <- e.phi.w2 <- my.weights1 <- my.weights2 <- NULL - if (aw) { - cif1 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * tr.mat[1, 2, ]) - my.weights1 <- diff(c(0, cif1[indi])) / cif1[length(cif1)] - cif2 <- cumsum(c(1, x$est["0", "0", 1:(dims[3] - 1)]) * tr.mat[1, 3, ]) - my.weights2 <- diff(c(0, cif2[indi])) / cif2[length(cif2)] - weights.aw <- list(my.weights1, my.weights2) - estimates.aw <- lapply(weights.aw, function(z) { - ldiff <- los[, 3] - los[, 2] - ldiff[filtre] <- 0 - estimate <- matrix(ldiff[is.element(los[, 1], wait.times)], nrow = 1) %*% - matrix(z, ncol = 1) - estimate - }) - e.phi.w1 <- estimates.aw[[1]] - e.phi.w2 <- estimates.aw[[2]] - } - - res <- list(e.phi = estimate[[1]], phi.case = los[, 3], - phi.control = los[, 2], weights = my.weights, - w.time = wait.times, time = x$time, e.phi.weights.1 = e.phi.w1, - e.phi.weights.other = e.phi.w2, weights.1 = my.weights1, - weights.other = my.weights2) - res +clos <- function(x, aw, ratio, ...) { + UseMethod("clos") } - - - -clos <- function(x, aw = FALSE, ratio = FALSE) { +clos.etm <- function(x, aw = FALSE, ratio = FALSE, ...) { if (!inherits(x, "etm")) { stop("'x' must be an 'etm' object") } if (is.null(x$delta.na)) { stop("Needs the increment of the Nelson-Aalen estimator") } - absorb <- setdiff(levels(x$trans$to), levels(x$trans$from)) - transient <- unique(x$state.names[!(x$state.names %in% absorb)]) - if (!(length(transient) == 2 && length(absorb) %in% c(1, 2))) - stop("The multistate model must have 2 transient states \n and 1 or 2 absorbing states") + + if (!is.null(x$strata)) stop("'clos' is not yet implemented for etm objects with strata. Please use e.g., 'clos(etm_object_name[1]'") + + ## test if we have an illness-death model dims <- dim(x$est) comp.risk <- FALSE if (dims[1] == 4) comp.risk <- TRUE - I <- diag(1, dims[1]) - tr.mat <- array(apply(x$delta.na, 3, "+", I), dim = dims) + ## I <- diag(1, dims[1]) + ## tr.mat <- array(apply(x$delta.na, 3, "+", I), dim = dims) + if (comp.risk) { + res <- clos.cp(x, aw, ratio) + ## stop("not yet") + } + else res <- clos.nocp(x, aw, ratio) + + class(res) <- "clos.etm" + res +} + + +clos.msfit <- function(x, aw = FALSE, ratio = FALSE, cox_model, ...) { + + if (!inherits(x, "msfit")) { + stop("'x' must be an 'msfit' object") + } + + if (missing(cox_model)) { + stop("cox model fit is missing") + } + + ## CumHaz <- dplyr::group_by(x$Haz, trans) + ## CumHaz <- dplyr::mutate(CumHaz, dhaz = diff(c(0, Haz))) + CumHaz <- data.table(x$Haz) + CumHaz[, dhaz := diff(c(0, Haz)), by = trans] + + trans <- x$trans[!is.na(x$trans)] + ltrans <- dim(x$trans) + ltimes <- unique(CumHaz[, length(time), by = trans][, V1]) + + times <- sort(unique(CumHaz$time)) + + + dna <- nev <- array(0, dim = c(ltrans[1], ltrans[1], ltimes)) + nrisk <- matrix(0, nrow = ltimes, ncol = ltrans[1]) + + ## Take care of the cox model and do the transformations in the + ## same loop + temp_surv <- survival::survfit(cox_model) + dat_surv <- data.frame(time = temp_surv$time, + n.risk = temp_surv$n.risk, + n.event = temp_surv$n.event, + trans = rep(trans, temp_surv$strata)) + + for (i in trans) { + aa <- which(x$trans == i, arr.ind = TRUE) + dna[aa[1], aa[2], ] <- CumHaz$dhaz[CumHaz$trans == i] + + ## fill nev and nrisk + dat_temp <- dat_surv[dat_surv$trans == i, ] + ind <- findInterval(times, dat_temp$time) + place <- which(ind != 0) + tmp <- integer(ltimes) + tmp <- cumsum(dat_temp$n.event)[ind] + + nev[aa[1], aa[2], place] <- c(tmp[1], diff(tmp)) + nrisk[place, aa[1]] <- dat_temp$n.risk[ind] + + tt <- nrisk[2:ltimes, aa[1]] - nev[aa[1], aa[2], 1:(ltimes-1)] + + if (!all((tt == 0) == FALSE)) { + uu <- max(times[tt == 0]) + + if (uu < max(times)) { + vv <- which(times == uu) + nrisk[(vv + 1):nrow(nrisk), aa[1]] <- 0 + } + } + } + + ## Ugly risk set fix for illness-death models where nobody starts + ## in state 1 at time 0 + ind <- which(nrisk[, 2] != 0)[1] + dni <- which(nev[1, 2, ] != 0)[1] + + if ((ind - 1) > dni) { + nrisk[(dni + 1):(ind - 1), 2] <- cumsum(nev[1, 2, dni:(ind - 2)]) + } + + ii <- seq_len(ltrans[1]) + for (i in seq_along(times)) { + dna[cbind(ii, ii, i)] <- -(.rowSums(dna[, , i], ltrans[1], ltrans[1], FALSE)) + } + + ## Need to compute AJ (again) + which.compute <- rep(1, ltimes) + first <- 1; last <- ltimes + est <- prodint(dna, times, first, last, which.compute) + + comp.risk <- FALSE + if (ltrans[1] == 4) comp.risk <- TRUE + ## I <- diag(1, ltrans[1]) + ## tr.mat <- array(apply(dna, 3, "+", I), dim = c(ltrans, ltimes)) + + d_tmp <- data.frame(exit = cox_model$y[, 2]) + + zzz <- list(est = est$est, + delta.na = dna, + time = est$time, + n.event = nev, + n.risk = nrisk[, 1:2], ## dirty. but these should be illness-death models + data = d_tmp + ) + + if (comp.risk) { - res <- clos.cp(x, tr.mat, aw, ratio) + stop("'clos.msfit' is not yet implemented with competing risks") } - else res <- clos.nocp(x, tr.mat, aw, ratio) + else res <- clos.nocp(zzz, aw, ratio) class(res) <- "clos.etm" + res } + diff -pruN 0.6-2.1-1/R/etmCIF.R 1.0.4-2/R/etmCIF.R --- 0.6-2.1-1/R/etmCIF.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/etmCIF.R 2017-03-08 09:46:04.000000000 +0000 @@ -3,6 +3,12 @@ etmCIF <- function(formula, data, etype, subset, na.action, failcode = 1) { + if (!requireNamespace("survival", quietly = TRUE)) + stop("This function requires the 'survival' package") + + Surv <- survival::Surv + is.Surv <- survival::is.Surv + if (missing(data)) stop("A data frame in which to interpret the formula must be supplied") if (missing(etype)) stop("'etype' is missing, with no default") diff -pruN 0.6-2.1-1/R/etm_intern.R 1.0.4-2/R/etm_intern.R --- 0.6-2.1-1/R/etm_intern.R 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/R/etm_intern.R 2017-03-08 09:46:04.000000000 +0000 @@ -0,0 +1,49 @@ +##################################################################### +### The etm machinery +### Arthur Allignol s & times <= t] + + if (length(times) == 0) { + zzz <- list() + zzz$est <- array(diag(1, nrow = nstate, nstate), dim = list(nstate, nstate, 1)) + zzz$dna <- array(matrix(0, nrow = nstate, ncol = nstate), dim = list(nstate, nstate, 1)) + zzz$n.risk <- zzz$time <- zzz$n.event <- NULL + return(zzz) + } else { + + c_modif <- matrix(const_modif, length(times), nstate, byrow = TRUE) + + zzz <- .Call("gen_msm", times, entry, exit, from, to, nstate, c_modif) + + } + + if (covariance) { + + cov_etm <- .Call("cov_aj", + zzz$time, + zzz$est, + zzz$n.risk, + zzz$n.event, + zzz$dna) + + zzz$cov <- cov_etm + + } + + zzz +} + diff -pruN 0.6-2.1-1/R/etm.R 1.0.4-2/R/etm.R --- 0.6-2.1-1/R/etm.R 2014-12-08 21:13:44.000000000 +0000 +++ 1.0.4-2/R/etm.R 2018-06-27 20:14:42.000000000 +0000 @@ -1,133 +1,15 @@ -prodint <- function(dna, times, first, last, indi) { - I <- array(0, dim=dim(dna)[c(1, 2)]) - diag(I) <- 1 - if (first >= last) { - est <- array(I, dim=c(dim(dna)[c(1, 2)], 1)) - time <- NULL - } else { - est <- array(0, dim=c(dim(dna)[c(1, 2)], (last-first+1))) - est[, , 1] <- I + dna[, , first] * indi[1] - j <- 2 - for (i in (first + 1):last) { - est[, , j] <- est[, , j-1] %*% (I + dna[, , i] * indi[j]) - j <- j + 1 - } - time <- times[first:last] - } - list(est=est, time=time) +etm <- function(data, ...) { + UseMethod("etm") } +etm.data.frame <- function(data, state.names, tra, cens.name, s, t = "last", + covariance = TRUE, delta.na = TRUE, modif = FALSE, + c = 1, alpha = NULL, strata, ...) { -################################################# -### Variance Lai and Ying for competing risks ### -################################################# - -var.ly <- function(est, state.names, nrisk, nev, times, first, last, indi) { - - if (first >= last) { - return(NULL) - - } else { - - nCompRisks <- length(state.names) - 1 - - ## prepare what we need - cif <- n.event <- matrix(nrow = last - first + 1, ncol = nCompRisks) - nev <- nev[, , first:last] - nrisk <- nrisk[first:last, ] - time <- times[first:last] - lt <- length(time) - - for (i in seq_len(last - first + 1)) { - cif[i, ] <- est[1, 2:(nCompRisks + 1), i] - n.event[i, ] <- nev[1, 2:(nCompRisks + 1), i] - } - sminus <- c(1, est[1, 1, 1:(last - first)]) - S <- est[1, 1, ] - - ## create the matrix of covariances - out <- array(0, dim = c((nCompRisks + 1)^2, (nCompRisks + 1)^2, (last-first+1))) - - ## get the indices on where to put the variance - pos <- sapply(1:length(state.names), function(i) { - paste(state.names, state.names[i]) - }) - pos <- matrix(pos) - dimnames(out) <- list(pos, pos, time) - pos.cp <- sapply(seq_along(state.names), function(i) - paste(state.names[1], state.names[i], sep = " "))[-1] - ind.cp <- which(pos %in% pos.cp, arr.ind = TRUE) - - ## the real shebang - for (i in seq_along(ind.cp)) { - for (j in seq_len(lt)) { - f <- cif[1:j, i] - s <- sminus[1:j] - spasminus <- S[1:j] - y <- nrisk[1:j, 1] - dn <- rowSums(array(n.event[1:j, ], dim = c(j, nCompRisks))) - dnt <- n.event[1:j, i] - indi.loop <- indi[1:j] - ## from biomJ paper eq. (6) - vly <- sum(((f[j] - f)^2 / (y - dn)) * (dn/y) * indi.loop + - s^2/y^3 * (y - dnt - 2 * (y - dn) * ((f[j] - f)/spasminus)) * dnt * indi.loop) - out[ind.cp[i], ind.cp[i], j] <- vly - } - } - } - - return(out) -} - - -#################################### -### Variance of the AJ estimator ### -#################################### - -var.aj <- function(est, dna, nrisk, nev, times, first, last) { - d <- dim(nev)[1] - if (first >= last) { - return(NULL) - } else { - out <- array(0, dim=c(dim(dna)[c(1, 2)]^2, (last-first+1))) - cov.dna <- matrix(.C(cov_dna, - as.double(nrisk[first, ]), - as.double(nev[, , first]), - as.integer(d), - cov = double(d^2 * d^2) - )$cov, d^2, d^2) - bI <- diag(1, d^2) - out[, , 1] <- bI %*% cov.dna %*% bI - Id <- diag(1, d) - for (i in 1:length(times[(first + 1):last])) { - step <- first + i - cov.dna <- matrix(.C(cov_dna, - as.double(nrisk[step, ]), - as.double(nev[, , step]), - as.integer(d), - cov = double(d^2 * d^2) - )$cov, d^2, d^2) - out[, , i + 1] <- (t(Id + dna[, , step]) %x% Id) %*% out[, , i] %*% - ((Id + dna[, , step]) %x% Id) + - (Id %x% est[, , i]) %*% cov.dna %*% (Id %x% t(est[, , i])) - } - } - return(out) -} - - - -########### -### etm ### -########### - -etm <- function(data, state.names, tra, cens.name, s, t="last", - covariance=TRUE, delta.na = TRUE, modif = FALSE, - alpha = 1/4, c = 1) { - if (missing(data)) stop("Argument 'data' is missing with no default") + x <- data.table(data) if (missing(tra)) stop("Argument 'tra' is missing with no default") if (missing(state.names)) @@ -136,10 +18,10 @@ etm <- function(data, state.names, tra, stop("Argument 'cens.name' is missing with no default") if (missing(s)) stop("Argument 's' is missing with no default") - if (!is.data.frame(data)) - stop("Argument 'data' must be a data.frame") - if (!(xor(sum(c("id", "from", "to", "time") %in% names(data)) != 4, - sum(c("id", "from", "to", "entry", "exit") %in% names(data)) != 5))) + if (!is.data.frame(x)) + stop("Argument 'x' must be a data.frame") + if (!(xor(sum(c("id", "from", "to", "time") %in% names(x)) != 4, + sum(c("id", "from", "to", "entry", "exit") %in% names(x)) != 5))) stop("'data' must contain the right variables") if (nrow(tra) != ncol(tra)) stop("Argument 'tra' must be a quadratic matrix.") @@ -159,6 +41,18 @@ etm <- function(data, state.names, tra, stop("The name of the censoring variable just is a name of the model states.") } } + ## The stratification variable + if (missing(strata)) { + strat_var <- "X" + x$X <- "1" + is_stratified <- FALSE + } else { + if (!all(strata %in% names(x))) + stop("Stratification variables not in data") + strat_var <- strata + x[, (strat_var) := lapply(.SD, as.character), .SDcols = strat_var] + is_stratified <- TRUE + } ## if modif TRUE, check that the model is competing risks. else ## set to false and issue a warning @@ -170,8 +64,29 @@ etm <- function(data, state.names, tra, warning("The variance of the estimator with the Lay and Ying transformation is only computed for competing risks data") } } - -### transitions + + ## keep only the variables we need + reg <- names(x) + names_msm <- intersect(c("id", "entry", "exit", "time", "from", "to", strat_var), reg) + x <- x[, names_msm, with = FALSE] + + ## Work through the stratification variables + combi <- unique(x[, strat_var, with = FALSE]) + if (length(strat_var) == 1) { + conditions <- lapply(seq_len(nrow(combi)), function(i) { + parse(text = paste0(strat_var, " == '", combi[i], "'")) + }) + } else { + conditions <- lapply(seq_len(nrow(combi)), function(i) { + parse(text = paste(sapply(strat_var, + function(j) { + paste0(j, "== '", combi[i, j, with = FALSE], "'") + }), + collapse = " & ")) + }) + } + + ## transitions colnames(tra) <- rownames(tra) <- state.names t.from <- lapply(1:dim(tra)[2], function(i) { rep(rownames(tra)[i], sum(tra[i, ])) @@ -183,9 +98,9 @@ etm <- function(data, state.names, tra, t.to <- unlist(t.to) trans <- data.frame(from=t.from, to=t.to) namen <- paste(trans[, 1], trans[, 2]) - + ## test on transitions - test <- unique(paste(data$from, data$to)) + test <- x[, unique(paste(from, to))] if (!(is.null(cens.name))) { ref <- c(paste(trans$from, trans$to), paste(unique(trans$from), cens.name)) } else { @@ -194,142 +109,171 @@ etm <- function(data, state.names, tra, ref.wo.cens <- paste(trans$from, trans$to) if (!(all(test %in% ref)==TRUE)) stop("There is undefined transitions in the data set") - if (sum(as.character(data$from)==as.character(data$to)) > 0) + if (x[, sum(as.character(from) == as.character(to))] > 0) stop("Transitions into the same state are not allowed") if (!(all(ref.wo.cens %in% test) == TRUE)) warning("You may have specified more possible transitions than actually present in the data") - n <- length(unique(data$id)) -### data.frame transformation - data$id <- if (is.character(data$id)) as.factor(data$id) else data$id - data$from <- as.factor(data$from) - data$to <- as.factor(data$to) + n <- length(unique(x$id)) + +### data.table transformation + x[, id := if (is.character(id)) as.factor(id) else id] if (!(is.null(cens.name))) { - data$from <- factor(data$from, levels = c(cens.name, state.names), ordered = TRUE) - levels(data$from) <- 0:length(state.names) - data$to <- factor(data$to, levels = c(cens.name, state.names), ordered = TRUE) - levels(data$to) <- 0:length(state.names) + x[, from := factor(from, levels = c(cens.name, state.names), ordered = TRUE)] + levels(x$from) <- 0:length(state.names) + x[, to := factor(to, levels = c(cens.name, state.names), ordered = TRUE)] + levels(x$to) <- 0:length(state.names) } else{ - data$from <- factor(data$from, levels = state.names, ordered = TRUE) - levels(data$from) <- 1:length(state.names) - data$to <- factor(data$to, levels = state.names, ordered = TRUE) - levels(data$to) <- 1:length(state.names) - } - -### if not, put like counting process data - if ("time" %in% names(data)) { - data <- data[order(data$id, data$time), ] - idd <- as.integer(data$id) - entree <- double(length(data$time)) - masque <- rbind(1, apply(as.matrix(idd), 2, diff)) - entree <- c(0, data$time[1:(length(data$time) - 1)]) * (masque == 0) - data <- data.frame(id = data$id, from = data$from, - to = data$to, entry = entree, exit = data$time) - if (sum(data$entry < data$exit) != nrow(data)) + x[, from := factor(from, levels = state.names, ordered = TRUE)] + levels(x$from) <- 1:length(state.names) + x[, to := factor(x$to, levels = state.names, ordered = TRUE)] + levels(x$to) <- 1:length(state.names) + } + + ## if not, put like counting process data + if ("time" %in% names(x)) { + setorder(x, id, time) + x[, idd := as.integer(id)] + x[, masque := rbind(1, apply(as.matrix(idd), 2, diff))] + x[, entree := c(0, time[1:(length(time) - 1)]) * (masque == 0)] + x[, ':='(entry = entree, + exit = time, + entree = NULL, + time = NULL, + masque = NULL)] + if (sum(x$entry < x$exit) != nrow(x)) stop("Exit time from a state must be > entry time") } else { - if (sum(data$entry < data$exit) != nrow(data)) + if (sum(x$entry < x$exit) != nrow(x)) stop("Exit time from a state must be > entry time") } - -### Computation of the risk set and dN - ttime <- c(data$entry, data$exit) - times <- sort(unique(ttime)) - data$from <- as.integer(as.character(data$from)) - data$to <- as.integer(as.character(data$to)) - temp <- .C(risk_set_etm, - as.integer(nrow(data)), - as.integer(length(times)), - as.integer(c(dim(tra), length(times))), - as.double(times), - as.integer(data$from), - as.integer(data$to), - as.double(data$entry), - as.double(data$exit), - nrisk=integer(dim(tra)[1] * length(times)), - ncens=integer(dim(tra)[1] * length(times)), - nev=integer(dim(tra)[1] * dim(tra)[2] * length(times)), - dna=double(dim(tra)[1] * dim(tra)[2] * length(times))) - - nrisk <- matrix(temp$nrisk, ncol=dim(tra)[1], nrow=length(times)) - ncens <- matrix(temp$ncens, ncol=dim(tra)[1], nrow=length(times)) - nev <- array(temp$nev, dim=c(dim(tra), length(times))) - dna <- array(temp$dna, dim=c(dim(tra), length(times))) - ii <- seq_len(dim(tra)[1]) - for (i in seq_along(times)) { - dna[cbind(ii, ii, i)] <- -(.rowSums(nev[, , i], dim(nev)[1], dim(nev)[1], FALSE))/nrisk[i, ] - ## dna[cbind(ii, ii, i)] <- -(rowSums(nev[, , i])/nrisk[i, ]) - } - dna[is.nan(dna)] <- 0 - -### computation of the Aalen-Johansen estimator - if (t=="last") t <- times[length(times)] + + x[, from := as.integer(as.character(from))] + x[, to := as.integer(as.character(to))] + + if (t=="last") t <- max(x$exit) if (!(0 <= s & s < t)) stop("'s' and 't' must be positive, and s < t") - if (t <= times[1] | s >= times[length(times)]) + if (t < x[, min(exit)] | s >= x[, max(exit)]) stop("'s' or 't' is an invalid time") - first <- length(times[times <= s]) + 1 - last <- length(times[times <= t]) - - if (first >= last) { - est <- list() - est$est <- array(diag(1, dim(tra)[1], dim(tra)[2]), c(dim(tra), 1)) - dimnames(est$est) <- list(state.names, state.names, t) - est$time <- NULL - var <- NULL - nrisk <- matrix(nrisk[last, ], 1, dim(tra)[1]) - nev <- array(0, dim(tra)) - - } else { - - aa <- nrisk[first:last, ] - if (modif) { - which.compute <- as.integer(aa >= c * n^alpha) + + ## remove the lines in which transition before s + x <- x[exit > s] + ## remove the entries after t + x <- x[entry < t] + + ## The Lai and Ying modification (if any) + if (modif) { + if (is.null(alpha)) { + if (length(c) == 1) { + c_modif <- c + } else { + if (length(c) != length(state.names)) { + stop("if specifying a unique c for each transient state, 'c' should be the same length as the 'state.names'") + } else { + c_modif <- c + } + } } else { - which.compute <- rep(1, length(aa)) + ## the original lay and ying proposal + c_modif <- c * n^alpha } - est <- prodint(dna, times, first, last, which.compute) - - if (covariance == TRUE) { - if (modif == FALSE) { - var <- var.aj(est$est, dna, nrisk, nev, times, first, last) + } else { + c_modif <- 0 + } + + res <- lapply(conditions, function(ll) + { + zzz <- .etm(entry = x[eval(ll), entry], + exit = x[eval(ll), exit], + from = x[eval(ll), from], + to = x[eval(ll), to], + nstate = dim(tra)[1], + s, + t, + covariance, + c_modif) + + nrisk <- zzz$n.risk + + est <- zzz$est + nev <- zzz$n.event + var_aj <- zzz$cov + + dimnames(est) <- list(state.names, state.names, zzz$time) + + if (!is.null(zzz$n.risk)) { + colnames(nrisk) <- state.names + nrisk <- nrisk[, !(colnames(nrisk) %in% + setdiff(unique(trans$to), unique(trans$from))), + drop = FALSE] + dimnames(est) <- list(state.names, state.names, zzz$time) + dimnames(nev) <- list(state.names, state.names, zzz$time) + + if (covariance) { pos <- sapply(1:length(state.names), function(i) { paste(state.names, state.names[i]) }) pos <- matrix(pos) - dimnames(var) <- list(pos, pos, est$time) - - } else { - - var <- var.ly(est$est, state.names, nrisk, nev, times, first, last, which.compute) + dimnames(var_aj) <- list(pos, pos, zzz$time) + var_aj[var_aj < 0] <- 0 + } else { + var_aj <- NULL } - } else { - var <- NULL + var_aj <- NULL } - - if (delta.na) { - delta.na <- dna[, , first:last] - } - else delta.na <- NULL - - nrisk <- nrisk[first:last, ] - nev <- nev[, , first:last] - dimnames(est$est) <- list(state.names, state.names, est$time) - dimnames(nev) <- list(state.names, state.names, est$time) - } - - colnames(nrisk) <- state.names - nrisk <- nrisk[, !(colnames(nrisk) %in% - setdiff(unique(trans$to), unique(trans$from))), - drop = FALSE] - - res <- list(est = est$est, cov = var, time = est$time, s =s, t = t, - trans = trans, state.names = state.names, - cens.name = cens.name, - n.risk = nrisk, n.event = nev, delta.na = delta.na, - ind.n.risk = ceiling(c * n^alpha)) - class(res) <- "etm" + + res <- list(est = est, + cov = var_aj, + time = zzz$time, + n.risk = nrisk, + n.event = nev, + delta.na = zzz$dna, + s = s, + t = t) + res + }) + + if (is_stratified) { + names(res) <- do.call('c', lapply(conditions, as.character)) + res$trans <- trans + res$tra <- tra + res$state.names <- state.names + res$data <- x + res$strata_variable <- strata + res$strata <- do.call('c', lapply(conditions, as.character)) + class(res) <- "etm" + } else { + res <- res[[1]] + res$trans <- trans + res$tra <- tra + res$state.names <- state.names + res$data <- x + class(res) <- "etm" + } + res } + + +### with Hist +## etm.formula <- function(formula, data, subset, na.action) { + +## call <- match.call() +## if (missing(data)) +## data <- environment(formula) +## if (!missing(subset)) +## data <- subset(data, subset = subset) + +## mod <- EventHistory.frame(formula, +## data, +## specials = c("strata", "factor"), +## stripSpecials = "strata", +## stripAlias = list(strata = c("Strata", "factor")), +## check.formula = TRUE) + +## mod +## } + diff -pruN 0.6-2.1-1/R/extract.R 1.0.4-2/R/extract.R --- 0.6-2.1-1/R/extract.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/extract.R 2018-01-28 21:27:17.000000000 +0000 @@ -7,18 +7,21 @@ trcov <- function(x, ...) { } trprob.etm <- function(x, tr.choice, timepoints, ...) { + if (!inherits(x, "etm")) stop("'x' must be a 'etm' object") if (!is.character(tr.choice)) stop("'tr.choice' must be a character vector") if (length(tr.choice) != 1) stop("The function only extracts 1 transition probability") + pos <- sapply(1:length(x$state.names), function(i) { paste(x$state.names, x$state.names[i]) }) pos <- matrix(pos) if (!(tr.choice %in% pos)) stop("'tr.choice' not in the possible transitions") + trans.sep <- strsplit(tr.choice, " ") if (length(trans.sep[[1]]) != 2) { tt <- charmatch(trans.sep[[1]], x$state.names, nomatch = 0) @@ -26,18 +29,48 @@ trprob.etm <- function(x, tr.choice, tim } trans.sep <- unlist(trans.sep) - if (missing(timepoints)) { - tmp <- x$est[trans.sep[1], trans.sep[2], ] - } - else { - ind <- findInterval(timepoints, x$time) - tmp <- numeric(length(timepoints)) - place <- which(ind != 0) - tmp[place] <- x$est[trans.sep[1], trans.sep[2], ind] + miss_timepoints <- missing(timepoints) + + ## Number of strata. Will be computed in this if condition + if (!is.null(x$strata_variable)) { + ns <- length(x$strata) + } else { + if (miss_timepoints) { + tmp <- x$est[trans.sep[1], trans.sep[2], ] + } else { + ind <- findInterval(timepoints, x$time) + tmp <- numeric(length(timepoints)) + place <- which(ind != 0) + noplace <- which(ind == 0) + tmp[place] <- x$est[trans.sep[1], trans.sep[2], ind] + if (trans.sep[1] == trans.sep[2]) + tmp[noplace] <- 1 + } + return(tmp) } - tmp + + ## Compute for the case with strata + res <- lapply(1:ns, function(i) { + if (miss_timepoints) { + tmp <- x[[i]]$est[trans.sep[1], trans.sep[2], ] + } else { + ind <- findInterval(timepoints, x[[i]]$time) + tmp <- numeric(length(timepoints)) + place <- which(ind != 0) + noplace <- which(ind == 0) + tmp[place] <- x[[i]]$est[trans.sep[1], trans.sep[2], ind] + if (trans.sep[1] == trans.sep[2]) + tmp[noplace] <- 1 + } + tmp + }) + + names(res) <- names(x)[seq_len(ns)] + + res + } - + trcov.etm <- function(x, tr.choice, timepoints, ...) { if (!inherits(x, "etm")) stop("'x' must be a 'etm' object") @@ -45,23 +78,105 @@ trcov.etm <- function(x, tr.choice, time stop("'tr.choice' must be a character vector") if (!(length(tr.choice) %in% c(1, 2))) stop("'tr.choice' must be of length 1 or 2") - pos <- sapply(1:length(x$state.names), function(i) { + pos <- sapply(1:length(x$state.names), function(i) { paste(x$state.names, x$state.names[i]) }) + pos <- matrix(pos) if (!all((tr.choice %in% pos))) stop("'tr.choice' not in the possible transitions") if (length(tr.choice) == 1) { tr.choice <- rep(tr.choice, 2) } - if (missing(timepoints)) { + + miss_timepoints <- missing(timepoints) + + if (!is.null(x$strata_variable)) { + ns <- length(x$strata) + if (is.null(x[[1]]$cov)) stop("The covariance matrix was not computed") + } else { + if (is.null(x$cov)) stop("The covariance matrix was not computed") + if (miss_timepoints) { tmp <- x$cov[tr.choice[1], tr.choice[2], ] + } + else { + ind <- findInterval(timepoints, x$time) + tmp <- numeric(length(timepoints)) + place <- which(ind != 0) + tmp[place] <- x$cov[tr.choice[1], tr.choice[2], ind] + } + return(tmp) + } + + res <- lapply(1:ns, function(i) { + if (miss_timepoints) { + tmp <- x[[i]]$cov[tr.choice[1], tr.choice[2], ] + } + else { + ind <- findInterval(timepoints, x[[i]]$time) + tmp <- numeric(length(timepoints)) + place <- which(ind != 0) + tmp[place] <- x[[i]]$cov[tr.choice[1], tr.choice[2], ind] + } + tmp + }) + + names(res) <- names(x)[seq_len(ns)] + + res + +} + + +############################## +### For the stratified etm ### +############################## + +"[.etm" <- function(x, ..., drop = FALSE) { + + if (missing(..1)) i <- NULL else i <- ..1 + + ## No subscript, do nothing + if (is.null(i)) return(x) + + ## No strata, do nothing + if (is.null(x$strata_variable)) return(x) + + if (is.character(i)) { + ind <- match(gsub(" ", "", i, fixed = TRUE), + gsub(" ", "", x$strata, fixed = TRUE)) + if (any(is.na(ind))) stop(paste("subscript(s)", + paste(i[is.na(ind)], sep = " "), + "not matched")) + } else { + ind <- i + if (max(ind) > length(x$strata)) + stop(paste0("There is only ", length(x$strata), " strata")) } - else { - ind <- findInterval(timepoints, x$time) - tmp <- numeric(length(timepoints)) - place <- which(ind != 0) - tmp[place] <- x$cov[tr.choice[1], tr.choice[2], ind] + + if (length(ind) == 1) { + + res <- x[[ind]] + res$trans <- x$trans + res$tra <- x$tra + res$state.names <- x$state.names + res$data <- x$data + res$strat_variable <- NULL + res$strata <- NULL + + } else { + + res <- unclass(x)[ind] + res$trans <- x$trans + res$tra <- x$tra + res$state.names <- x$state.names + res$data <- x$data + res$strat_variable <- NULL + res$strata <- NULL + } - tmp + + class(res) <- "etm" + res + } diff -pruN 0.6-2.1-1/R/ggtransfo.etm.R 1.0.4-2/R/ggtransfo.etm.R --- 0.6-2.1-1/R/ggtransfo.etm.R 2014-12-08 21:13:44.000000000 +0000 +++ 1.0.4-2/R/ggtransfo.etm.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -### Function to transform a etm object into something usable for ggplot ### -### Arthur Allignol 0) stop("Argument 'tr.choice' and possible transitions must match") - temp <- ci.transfo(x, tr.choice, level, ci.fun) - + if (is_stratified) { + + lstrat <- length(x$strata) + temp <- lapply(seq_len(lstrat), function(i) { + tmp <- ci.transfo(x[[i]], tr.choice, level, ci.fun) + tmp2 <- lapply(tmp, cbind, strata = x$strata[[i]]) + tmp2 + }) + temp <- do.call(c, temp) + } else { + temp <- ci.transfo(x, tr.choice, level, ci.fun) + } + lt <- length(temp) if (missing(lty)) { @@ -53,6 +73,6 @@ lines.etm <- function(x, tr.choice, col col = ci.col[i], lty = ci.lty[i], ...) } } - + invisible() } diff -pruN 0.6-2.1-1/R/misc.R 1.0.4-2/R/misc.R --- 0.6-2.1-1/R/misc.R 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/R/misc.R 2017-03-08 09:46:04.000000000 +0000 @@ -57,3 +57,42 @@ tra_surv <- function(state.names = c("0" tra } +### A little function that transform the data from time to entry exit +transfo_to_counting <- function(df) { + + if (!("data.table" %in% class(df))) + stop("The data should be of class 'data.table'") + + setorder(df, id, time) + df[, idd := as.integer(id)] + df[, masque := rbind(1, apply(as.matrix(idd), 2, diff))] + df[, entree := c(0, time[1:(length(time) - 1)]) * (masque == 0)] + df[, ':='(entry = entree, + exit = time, + entree = NULL, + time = NULL, + masque = NULL)] + + return(df) +} + +### Product integration +prodint <- function(dna, times, first, last, indi) { + I <- array(0, dim=dim(dna)[c(1, 2)]) + diag(I) <- 1 + if (first >= last) { + est <- array(I, dim=c(dim(dna)[c(1, 2)], 1)) + time <- NULL + } else { + est <- array(0, dim=c(dim(dna)[c(1, 2)], (last-first+1))) + est[, , 1] <- I + dna[, , first] * indi[1] + j <- 2 + for (i in (first + 1):last) { + est[, , j] <- est[, , j-1] %*% (I + dna[, , i] * indi[j]) + j <- j + 1 + } + time <- times[first:last] + } + list(est=est, time=time) +} + diff -pruN 0.6-2.1-1/R/plot.clos.etm.R 1.0.4-2/R/plot.clos.etm.R --- 0.6-2.1-1/R/plot.clos.etm.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/plot.clos.etm.R 2017-03-08 09:46:04.000000000 +0000 @@ -15,22 +15,22 @@ plot.clos.etm <- function(x, xlab = "Tim if (missing(ylim.w)) { ylim.w <- c(0, max(x$weights)) } - def.par <- par(no.readonly = TRUE) + def.par <- graphics::par(no.readonly = TRUE) on.exit(par(def.par)) - split.screen(figs=matrix(c(rep(0,2), rep(1,2), c(0, 0.6), c(0.7, 1)), ncol=4)) + graphics::split.screen(figs=matrix(c(rep(0,2), rep(1,2), c(0, 0.6), c(0.7, 1)), ncol=4)) screen(2) - op <- par(mar=c(2, 5, 2, 1)) - plot(c(0,x$w.time), c(0, x$weights), type = "s", axes = FALSE, lty = lty.w, xlim = xlim, - ylim = ylim.w , xlab = xlab , ylab = ylab.w, col=col.w, ...) - axis(side=2) - box() - par(op) - screen(1) - op <- par(mar=c(5, 5, 4, 1)) - plot(x$time, x$phi.case, type = "s", lty = lty.e[1], xlim = xlim, - ylim = ylim.e, xlab = xlab, ylab = ylab.e, col = col.e[1], ...) - lines(x$time, x$phi.control, type = "s", lty = lty.e[2], col = col.e[2], ...) - par(op) + op <- graphics::par(mar=c(2, 5, 2, 1)) + graphics::plot(c(0,x$w.time), c(0, x$weights), type = "s", axes = FALSE, lty = lty.w, xlim = xlim, + ylim = ylim.w , xlab = xlab , ylab = ylab.w, col=col.w, ...) + graphics::axis(side=2) + graphics::box() + graphics::par(op) + graphics::screen(1) + op <- graphics::par(mar=c(5, 5, 4, 1)) + graphics::plot(x$time, x$phi.case, type = "s", lty = lty.e[1], xlim = xlim, + ylim = ylim.e, xlab = xlab, ylab = ylab.e, col = col.e[1], ...) + graphics::lines(x$time, x$phi.control, type = "s", lty = lty.e[2], col = col.e[2], ...) + graphics::par(op) if (legend == TRUE) { if (missing(legend.pos)) legend.pos <- "bottomright" @@ -51,6 +51,6 @@ plot.clos.etm <- function(x, xlab = "Tim do.call("legend", c(list(xx, yy, curvlab, col = col.e, lty = lty.e, bty = legend.bty), args[!is.na(ii)])) } - close.screen(all.screens = TRUE) + graphics::close.screen(all.screens = TRUE) invisible() } diff -pruN 0.6-2.1-1/R/plot.etmCIF.R 1.0.4-2/R/plot.etmCIF.R --- 0.6-2.1-1/R/plot.etmCIF.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/plot.etmCIF.R 2017-03-08 09:46:04.000000000 +0000 @@ -78,10 +78,10 @@ plot.etmCIF <- function(x, which.cif, xl if (ci.type == "bars") { ind <- findInterval(pos.ci[i], summx[[i]][[tr.choice[j]]]$time) - segments(pos.ci[i], summx[[i]][[tr.choice[j]]]$lower[ind], - pos.ci[i], summx[[i]][[tr.choice[j]]]$upper[ind], - lwd = ci.lwd, col = ci.col[j + (i - 1) * n.what], - lty = ci.lty[j + (i - 1) * n.what],...) + graphics::segments(pos.ci[i], summx[[i]][[tr.choice[j]]]$lower[ind], + pos.ci[i], summx[[i]][[tr.choice[j]]]$upper[ind], + lwd = ci.lwd, col = ci.col[j + (i - 1) * n.what], + lty = ci.lty[j + (i - 1) * n.what],...) } } } diff -pruN 0.6-2.1-1/R/plot.etm.R 1.0.4-2/R/plot.etm.R --- 0.6-2.1-1/R/plot.etm.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/plot.etm.R 2018-01-28 21:22:51.000000000 +0000 @@ -2,10 +2,12 @@ plot.etm <- function(x, tr.choice, xlab col = 1, lty, xlim, ylim, conf.int = FALSE, level = 0.95, ci.fun = "linear", ci.col = col, ci.lty = 3, legend = TRUE, legend.pos, curvlab, legend.bty = "n", ...) { - + if (!inherits(x, "etm")) stop("'x' must be a 'etm' object") - + + is_stratified <- !is.null(x$strata) + ufrom <- unique(x$trans$from) uto <- unique(x$trans$to) absorb <- setdiff(uto, ufrom) @@ -14,7 +16,13 @@ plot.etm <- function(x, tr.choice, xlab pos <- c(paste(nam1[!(nam1 %in% as.character(absorb))], nam2[!(nam2 %in% as.character(absorb))]), paste(x$trans$from, x$trans$to)) - if (missing(tr.choice)) tr.choice <- pos + if (missing(tr.choice)) { + if (is_stratified) { + tr.choice <- pos[1] + } else { + tr.choice <- pos + } + } ref <- sapply(1:length(x$state.names), function(i) { paste(x$state.names, x$state.names[i]) @@ -23,7 +31,18 @@ plot.etm <- function(x, tr.choice, xlab if (sum(tr.choice %in% ref == FALSE) > 0) stop("Argument 'tr.choice' and possible transitions must match") - temp <- ci.transfo(x, tr.choice, level, ci.fun) + if (is_stratified) { + + lstrat <- length(x$strata) + temp <- lapply(seq_len(lstrat), function(i) { + tmp <- ci.transfo(x[[i]], tr.choice, level, ci.fun) + tmp2 <- lapply(tmp, cbind, strata = x$strata[[i]]) + tmp2 + }) + temp <- do.call(c, temp) + } else { + temp <- ci.transfo(x, tr.choice, level, ci.fun) + } lt <- length(temp) @@ -43,12 +62,12 @@ plot.etm <- function(x, tr.choice, xlab ylim <- c(0, 1) } - plot(xlim, ylim, xlab = xlab, ylab = ylab, - xlim = xlim, ylim = ylim, type = "n", ...) + graphics::plot(xlim, ylim, xlab = xlab, ylab = ylab, + xlim = xlim, ylim = ylim, type = "n", ...) for (i in seq_len(lt)) { - lines(temp[[i]]$time, temp[[i]]$P, type = "s", - col = col[i], lty = lty[i], ...) + graphics::lines(temp[[i]]$time, temp[[i]]$P, type = "s", + col = col[i], lty = lty[i], ...) } if (conf.int && !is.null(x$cov)) { @@ -57,18 +76,24 @@ plot.etm <- function(x, tr.choice, xlab if (length(ci.lty) < lt) ci.lty <- ci.lty * rep(1, lt) for (i in seq_len(lt)) { - lines(temp[[i]]$time, temp[[i]]$lower, type = "s", - col = ci.col[i], lty = ci.lty[i], ...) - lines(temp[[i]]$time, temp[[i]]$upper, type = "s", - col = ci.col[i], lty = ci.lty[i], ...) + graphics::lines(temp[[i]]$time, temp[[i]]$lower, type = "s", + col = ci.col[i], lty = ci.lty[i], ...) + graphics::lines(temp[[i]]$time, temp[[i]]$upper, type = "s", + col = ci.col[i], lty = ci.lty[i], ...) } } + ## Extend to deal with the strata if (legend) { if (missing(legend.pos)) legend.pos <- "topleft" - if (missing(curvlab)) - curvlab <- tr.choice + if (missing(curvlab)) { + if (is_stratified) { + curvlab <- as.vector(sapply(tr.choice, paste, x$strata)) + } else { + curvlab <- tr.choice + } + } if (is.list(legend.pos)) legend.pos <- unlist(legend.pos) if (length(legend.pos) == 1) { xx <- legend.pos @@ -84,6 +109,6 @@ plot.etm <- function(x, tr.choice, xlab do.call("legend", c(list(xx, yy, curvlab, col=col, lty=lty, bty = legend.bty), args[!is.na(ii)])) } - + invisible() } diff -pruN 0.6-2.1-1/R/print.etmCIF.R 1.0.4-2/R/print.etmCIF.R --- 0.6-2.1-1/R/print.etmCIF.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/print.etmCIF.R 2017-07-25 13:55:15.000000000 +0000 @@ -1,6 +1,6 @@ ### Print Method for cif.etm objects print.etmCIF <- function(x, ...) { - + if (!inherits(x, "etmCIF")) { stop("'x' must be of class 'etmCIF'") } @@ -11,12 +11,12 @@ print.etmCIF <- function(x, ...) { cat("Covariate: ", rownames(x$X), "\n") cat("\tlevels: ", x$X, "\n\n") } - + l.trans <- nrow(x[[1]]$trans) l.x <- length(x$X) zzz <- lapply(seq_len(l.x), function(i) { - temp <- summary(x[[i]]) + temp <- summary(x[[i]])[-1] mat <- matrix(0, ncol = 4, nrow = l.trans) for (j in seq_len(l.trans)) { n.temp <- nrow(temp[[j]]) @@ -34,6 +34,6 @@ print.etmCIF <- function(x, ...) { } print(mat) }) - + invisible() } diff -pruN 0.6-2.1-1/R/print.etm.R 1.0.4-2/R/print.etm.R --- 0.6-2.1-1/R/print.etm.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/print.etm.R 2017-03-08 09:46:04.000000000 +0000 @@ -1,29 +1,103 @@ -print.etm <- function(x, covariance = TRUE, whole = TRUE, ...) { +print.etm <- function(x, covariance = FALSE, whole = TRUE, ...) { + if (!inherits(x, "etm")) stop("'x' must be of class 'etm'") + absorb <- setdiff(levels(x$trans$to), levels(x$trans$from)) transient <- unique(x$state.names[!(x$state.names %in% absorb)]) + cat(paste("Multistate model with", length(transient), "transient state(s)\n", "and", length(absorb), "absorbing state(s)\n\n", sep = " ")) + cat("Possible transitions:\n") print(x$trans, row.names = FALSE) cat("\n") - cat(paste("Estimate of P(", x$s, ", ", x$t, ")\n", sep = "")) - print(x$est[, , dim(x$est)[3]]); cat("\n") - if (!is.null(x$cov) & covariance == TRUE) { - if (whole) { - cat(paste("Estimate of cov(P(", x$s, ", ", x$t, "))\n", sep = "")) - print(x$cov[, , dim(x$cov)[3]]) + + if (is.null(x$strata)) { + + cat(paste("Estimate of P(", x$s, ", ", x$t, ")\n", sep = "")) + print(x$est[, , dim(x$est)[3]]); cat("\n") + + if (!is.null(x$cov) & covariance == TRUE) { + if (whole) { + cat(paste("Estimate of cov(P(", x$s, ", ", x$t, "))\n", sep = "")) + print(x$cov[, , dim(x$cov)[3]]) + } + else { + cov <- x$cov[, , dim(x$cov)[3]][rowSums(x$cov[, , dim(x$cov)[3]]) != 0, ] + cova <- cov[, colSums(cov) != 0] + cat(paste("Estimate of cov(P(", x$s, ", ", x$t, "))\n", sep = "")) + print(cova) + } } - else { - cov <- x$cov[, , dim(x$cov)[3]][rowSums(x$cov[, , dim(x$cov)[3]]) != 0, ] - cova <- cov[, colSums(cov) != 0] - cat(paste("Estimate of cov(P(", x$s, ", ", x$t, "))\n", sep = "")) - print(cova) + + } else { + + for (i in seq_along(x$strata)) { + + cat("\t", x$strata[i], ":\n\n") + + cat(paste("Estimate of P(", x[i]$s, ", ", x[i]$t, ")\n", sep = "")) + print(x[i]$est[, , dim(x[i]$est)[3]]); cat("\n") + + if (!is.null(x$cov) & covariance == TRUE) { + if (whole) { + cat(paste("Estimate of cov(P(", x[i]$s, ", ", x[i]$t, "))\n", sep = "")) + print(x[i]$cov[, , dim(x[i]$cov)[3]]) + } + else { + cov <- x[i]$cov[, , dim(x[i]$cov)[3]][rowSums(x[i]$cov[, , dim(x[i]$cov)[3]]) != 0, ] + cova <- cov[, colSums(cov) != 0] + cat(paste("Estimate of cov(P(", x[i]$s, ", ", x[i]$t, "))\n", sep = "")) + print(cova) + } + } + } } + invisible() + } +### etmStratified +## print.etm.stratified <- function(x, covariance = FALSE, whole = TRUE, ...) { + +## if (!inherits(x, "etm.stratified")) +## stop("'x' must be of class 'etm.stratified'") + +## absorb <- setdiff(levels(x$trans$to), levels(x$trans$from)) +## transient <- unique(x$state.names[!(x$state.names %in% absorb)]) + +## cat(paste("Multistate model with", length(transient), "transient state(s)\n", +## "and", length(absorb), "absorbing state(s)\n\n", sep = " ")) +## cat("Possible transitions:\n") +## print(x$trans, row.names = FALSE) +## cat("\n") +## for (i in seq_along(x$strata)) { + +## cat(x$strata[i], ":\n\n") + +## cat(paste("Estimate of P(", x[i]$s, ", ", x[i]$t, ")\n", sep = "")) +## print(x[i]$est[, , dim(x[i]$est)[3]]); cat("\n") + +## if (!is.null(x$cov) & covariance == TRUE) { +## if (whole) { +## cat(paste("Estimate of cov(P(", x[i]$s, ", ", x[i]$t, "))\n", sep = "")) +## print(x[i]$cov[, , dim(x[i]$cov)[3]]) +## } +## else { +## cov <- x[i]$cov[, , dim(x[i]$cov)[3]][rowSums(x[i]$cov[, , dim(x[i]$cov)[3]]) != 0, ] +## cova <- cov[, colSums(cov) != 0] +## cat(paste("Estimate of cov(P(", x[i]$s, ", ", x[i]$t, "))\n", sep = "")) +## print(cova) +## } +## } + +## } + +## invisible() + +## } diff -pruN 0.6-2.1-1/R/print.summary.etm.R 1.0.4-2/R/print.summary.etm.R --- 0.6-2.1-1/R/print.summary.etm.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/print.summary.etm.R 2017-03-09 13:22:19.000000000 +0000 @@ -1,20 +1,36 @@ print.summary.etm <- function(x, ...) { + if (!inherits(x, "summary.etm")) stop("'x' must be of class 'summary.etm'") - if ("t" %in% names(x)) { - cat(paste("No events between", x$s, "and", x$t, "\n\n", sep = " ")) - print(x$P[, , 1]) + + ## Find out if we have strata + if (is.data.frame(x[[1]])) { + ns <- 1 + } else { + ns <- length(x) } - else { + + if (ns == 1) { + time <- x[[1]]$time qtime <- quantile(time, probs = c(0, 0.25, 0.5, 0.75, 0.9, 1)) ind <- findInterval(qtime, time) - + for (i in seq_along(x)) { cat(paste("Transition", names(x)[i], "\n", sep = " ")) print(x[[i]][ind, ], row.names = FALSE) cat("\n") } + + } else { + + nn <- names(x) + for (i in seq_len(ns)) { + cat(nn[i], "\n\n") + + print(x[[i]]) + } } + invisible() } diff -pruN 0.6-2.1-1/R/pseudo_clos.R 1.0.4-2/R/pseudo_clos.R --- 0.6-2.1-1/R/pseudo_clos.R 2014-12-08 21:11:58.000000000 +0000 +++ 1.0.4-2/R/pseudo_clos.R 2017-03-08 09:46:04.000000000 +0000 @@ -1,178 +1,122 @@ -### Function to compute the pseudo values -## Modelling will be done in another function to offer more -## flexibility -### Author: Arthur Allignol +##################################################################### +### Pseudo values for excess LoS +### Arthur Allignol +##################################################################### -closPseudo <- function(data, state.names, tra, cens.name, s = 0, - formula, aw = FALSE, ratio = FALSE, ncores = 1) { +closPseudo <- function(data, state.names, tra, cens.name, s = 0, + formula, na.action, + aw = FALSE, ratio = FALSE, ncores = 1, + trick_ties= FALSE) { + + stopifnot("data.frame" %in% class(data)) + data <- data.table(data) + ## take care of the formula argument call <- match.call() m <- match.call(expand.dots = FALSE) temp <- c("", "formula", "data", "id", "subset", "na.action") m <- m[match(temp, names(m), nomatch = 0)] Terms <- if (missing(data)) terms(formula) - else terms(formula, data = data) + else terms(formula, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) - ids <- unique(data$id) - n <- length(ids) - - ## theta. From there we'll see what kind of model it is + m <- data.table(cbind(id = data$id, m)) + + n <- length(unique(data[, id])) + +### get a minimal data set for computing the pseudo values + reg <- names(data) + names_msm <- intersect(c("id", "entry", "exit", "time", "from", "to"), reg) + dat_clos <- data[, names_msm, with = FALSE] + + ## theta. From there we will see what kind of model it is ## is no alternative weights, NULL ## No competing risks: not in the list - theta <- unlist(clos(etm(data = data, state.names = state.names, tra = tra, - cens.name = cens.name, s = 0, covariance = FALSE), - aw = aw, ratio = ratio)[c("e.phi", "e.phi.weights.1", - "e.phi.weights.other", - "e.phi2", "e.phi3")]) - + theta <- unlist(etm::clos(etm::etm(dat_clos, state.names = state.names, tra = tra, + cens.name = cens.name, s = 0, covariance = FALSE), + aw = aw, ratio = ratio)[c("e.phi", "e.phi.weights.1", + "e.phi.weights.other", + "e.phi2", "e.phi3")]) + competing <- "e.phi2" %in% names(theta) - + ## Compute pseudo values, and store results depending of competing ## and aw - ## TODO: ACTUALLY COMPUTE THE PSEUDO VALUES namen <- c("ps.e.phi", "ps.e.phi.weights.1", "ps.e.phi.weights.other", "ps.e.phi2", "ps.e.phi3") - + + if (trick_ties) { + + ## we want to find all patients that have the same "dynamic" + ## and get id's of some of them to compute PS + make_cat <- function(entry, exit, from, to) { + if (length(from) == 1) { + cat <- paste(entry, exit, from, to, sep = "_") + } else { + cat <- paste(entry[1], exit[1], from[1], to[1], + entry[2], exit[2], from[2], to[2], + sep = "_") + } + + list(categs = cat) + } + + cat_dyn <- dat_clos[, make_cat(entry, exit, from, to), by = "id"] + cat_dyn_red <- unique(data.table(cat_dyn, key = "categs")) + ids <- cat_dyn_red[, id] + + } else { + ids <- unique(data$id) + } + psMatrix <- parallel::mclapply(seq_along(ids), function(i) { - temp <- clos(etm(data = data[!(data$id %in% ids[i]), ], + temp <- clos(etm(dat_clos[!(id %in% ids[i])], state.names = state.names, tra = tra, cens.name = cens.name, s = 0, covariance = FALSE), aw = aw, ratio = ratio) - cbind(temp$e.phi, temp$e.phi.weights.1, temp$e.phi.weights.other, - temp$e.phi2, temp$e.phi3) + data.table(cbind(temp$e.phi, temp$e.phi.weights.1, temp$e.phi.weights.other, + temp$e.phi2, temp$e.phi3)) }, mc.cores = ncores) - ##} else { - ## psMatrix <- lapply(seq_along(ids), function(i) { - ## temp <- clos(etm(data = data[!(data$id %in% ids[i]), ], - ## state.names = state.names, tra = tra, - ## cens.name = cens.name, s = 0, covariance = FALSE), - ## aw = aw, ratio = ratio) - - ## cbind(temp$e.phi, temp$e.phi.weights.1, temp$e.phi.weights.other, - ## temp$e.phi2, temp$e.phi3) - ## }) - ## } - - psMatrix <- data.frame(do.call(rbind, psMatrix)) + + psMatrix <- rbindlist(psMatrix) psMatrix <- lapply(seq_along(psMatrix), function(i) { - n * theta[i] - (n - 1) * psMatrix[, i] + n * theta[i] - (n - 1) * psMatrix[, i, with = FALSE] }) psMatrix <- do.call(cbind, psMatrix) - colnames(psMatrix) <- namen[c(TRUE, aw, aw, competing, competing)] - ## the pseudo values n * ref - (n - 1) * temp - ## psMatrix <- matrix(apply(psMatrix, 1, function(x) n * theta - (n - 1) * x), - ## nrow = dim(psMatrix)[1], ncol = dim(psMatrix)[2]) - ## colnames(psMatrix) <- namen[c(TRUE, aw, aw, competing, competing)] + setnames(psMatrix, namen[c(TRUE, aw, aw, competing, competing)]) + + ## if trick, we need to merge intelligently + if (trick_ties) { + + bouh <- cbind(cat_dyn_red, psMatrix) + setkeyv(cat_dyn, "categs") + psMatrix <- merge(bouh, cat_dyn, by = "categs", all.y = TRUE) + psMatrix <- psMatrix[, c("id.y", namen[c(TRUE, aw, aw, competing, competing)]), + with = FALSE] + setnames(psMatrix, c("id", colnames(psMatrix)[-1])) + setkeyv(psMatrix, "id") + } else { + psMatrix <- data.frame(ids, psMatrix) + names(psMatrix) <- c("id", names(psMatrix)[-1]) + } - cov <- m[!duplicated(data$id), , drop = FALSE] - colnames(cov) <- attr(Terms, "term.labels") + cov <- unique(data.table(m, key = "id")) theta <- matrix(theta, nrow = 1) colnames(theta) <- c("e.phi", "e.phi.weights.1", "e.phi.weights.other", "e.phi2", "e.phi3")[c(TRUE, aw, aw, competing, competing)] - - zzz <- list(pseudoData = data.frame(id = ids, psMatrix, cov), + + pseudoData <- merge(psMatrix, cov) + + zzz <- list(pseudoData = pseudoData, theta = theta, aw = aw, call = call) class(zzz) <- "closPseudo" - - zzz -} - - -### A function to compute the pseudo obs on phi instead on change in -### LoS directly - -phiPseudo <- function(data, state.names, tra, cens.name, s = 0, - formula, timepoints, ncores = 1) { - - ## take care of the formula argument - call <- match.call() - m <- match.call(expand.dots = FALSE) - temp <- c("", "formula", "data", "id", "subset", "na.action") - m <- m[match(temp, names(m), nomatch = 0)] - Terms <- if (missing(data)) terms(formula) - else terms(formula, data = data) - m$formula <- Terms - m[[1]] <- as.name("model.frame") - m <- eval(m, parent.frame()) - - ids <- unique(data$id) - n <- length(ids) - nt <- length(timepoints) - - ref <- as.matrix(predictPhi(clos(etm(data = data, state.names = state.names, tra = tra, - cens.name = cens.name, s = 0, covariance = FALSE), - aw = FALSE), timepoints)[, c("phi", "phi.case", - "phi.control", "phiR")]) - - ref <- apply(ref, 2, rep, n) - psd <- matrix(0, nrow = n * nt, ncol = 6) - temp <- parallel::mclapply(seq_along(ids), function(i) { - as.matrix(predictPhi(clos(etm(data = data[!(data$id %in% ids[i]), ], - state.names = state.names, tra = tra, - cens.name = cens.name, s = 0, covariance = FALSE), - aw = FALSE), timepoints)[, c("phi", "phi.case", - "phi.control", "phiR")]) - }, mc.cores = ncores) - ## } else { - ## temp <- lapply(seq_along(ids), function(i) { - ## as.matrix(predictPhi(clos(etm(data = data[!(data$id %in% ids[i]), ], - ## state.names = state.names, tra = tra, - ## cens.name = cens.name, s = 0, covariance = FALSE), - ## aw = FALSE), timepoints)[, c("phi", "phi.case", - ## "phi.control", "phiR")]) - ## }) - ## } - - temp <- do.call(rbind, temp) - - for (i in seq_len(4)) { - psd[, i + 2] <- n * ref[, i] - (n - 1) * temp[, i] - } - psd[, 1] <- as.vector(mapply(rep, ids, nt)) - psd[, 2] <- rep(timepoints, n) - psd <- as.data.frame(psd) - names(psd) <- c("id", "time", "ps.phi", "ps.phi.case", - "ps.phi.control", "ps.phiR") - - cov <- as.matrix(m[!duplicated(data$id), , drop = FALSE]) - cov <- matrix(mapply(rep, cov, nt), dim(psd)[1], dim(cov)[2]) - cov <- as.data.frame(cov) - colnames(cov) <- attr(Terms, "term.labels") - - zzz <- list(pseudoData = data.frame(psd, cov), - phi = data.frame(id = psd[, 1], ref, time = timepoints), - ps = data.frame(id = psd[, 1], temp, time = timepoints), - call = call) - class(zzz) <- "phiPseudo" - zzz } - -predictPhi <- function(object, timepoints) { - if (!inherits(object, "clos.etm")) stop("gtfo") - - if (missing(timepoints)) stop("I want timepoints!!!") - - ## phi <- object$phi.case - object$phi.control - - ind <- findInterval(timepoints, object$time) - tmp.case <- tmp.control <- numeric(length(timepoints)) - place <- which(ind != 0) - tmp.case[place] <- object$phi.case[ind] - tmp.control[place] <- object$phi.control[ind] - - data.frame(phi.case = tmp.case, phi.control = tmp.control, - phi = tmp.case - tmp.control, - phiR = tmp.case / tmp.control, time = timepoints) -} - - diff -pruN 0.6-2.1-1/R/summary.etmCIF.R 1.0.4-2/R/summary.etmCIF.R --- 0.6-2.1-1/R/summary.etmCIF.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/summary.etmCIF.R 2018-01-29 21:39:29.000000000 +0000 @@ -10,7 +10,7 @@ summary.etmCIF <- function(object, ci.fu l.trans <- nrow(object[[1]]$trans) temp <- lapply(object[seq_len(l.X)], function(ll) { - aa <- summary(ll, ci.fun = ci.fun, level = level, ...)[seq_len(l.trans)] + aa <- summary(ll, ci.fun = ci.fun, level = level, ...)[seq_len(l.trans) + 1] names(aa) <- paste("CIF ", sapply(strsplit(sub("\\s", "|", names(aa)[1:l.trans]), "\\|"), "[", 2), sep = "") aa @@ -39,8 +39,8 @@ print.summary.etmCIF <- function(x, ...) cat("\n") } } - + invisible() } - + diff -pruN 0.6-2.1-1/R/summary.etm.R 1.0.4-2/R/summary.etm.R --- 0.6-2.1-1/R/summary.etm.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/summary.etm.R 2018-01-13 22:29:53.000000000 +0000 @@ -1,22 +1,72 @@ -summary.etm <- function(object, all = FALSE, ci.fun = "linear", level = 0.95, ...) { +find_times <- function(d, timepoints) { + + ind <- findInterval(timepoints, d$time) + ind0 <- sum(ind == 0) + + dd <- d[ind, ] + + if (ind0 > 0) { + tmp <- d[1, , drop = FALSE] + tmp$P <- round(tmp$P) + tmp$var <- 0 + tmp$lower <- tmp$upper <- tmp$P + tmp$n.event <- 0 + + for (i in seq_len(ind0)) dd <- rbind(tmp, dd) + } + + dd$time <- timepoints + dd$n.event <- cumsum(dd$n.event) + + dd +} + + + +summary.etm <- function(object, tr.choice, ci.fun = "linear", level = 0.95, times, ...) { + if (!inherits(object, "etm")) stop("'object' must be of class 'etm'") - if (is.null(object$time)) { - res <- list(P = object$est, s = object$s, t = object$t) - class(res) <- "summary.etm" - return(res) - } + if (level <= 0 | level > 1) { stop ("'level' must be between 0 and 1") } + ref <- c("linear", "log", "cloglog", "log-log") if (sum(ci.fun %in% ref == FALSE) != 0) { stop("'ci.fun' is not correct. See help page") } - if (all) { - ind <- object$est != 0 - indi <- apply(ind, c(1, 2), function(temp){all(temp == FALSE)}) - tmp <- which(indi == FALSE, arr.ind = TRUE) + + ## Number of strata. Will be computed in this if condition + ns <- 1 + if (!is.null(object$strata_variable)) { + ns <- length(object$strata) + time <- unique(sapply(1:ns, function(i) { + object[[i]]$time + })) + } else { + time <- object$time + } + + ## If no event time between s and t, don't need a summary + if (is.null(time)) stop("no event time") + + ## Derive the transition names we need + if (missing(tr.choice)) { + if (!is.null(object$strata_variable)) { + + indi <- lapply(1:ns, function(i) { + !apply(object[[i]]$est != 0, c(1, 2), function(temp){all(temp == FALSE)}) + }) + indi <- do.call("+", indi) > 0 + + } else { + + ind <- object$est != 0 + indi <- !apply(ind, c(1, 2), function(temp){all(temp == FALSE)}) + } + + tmp <- which(indi, arr.ind = TRUE) tmp <- tmp[order(tmp[, 1]), ] namen <- list(rownames(indi), colnames(indi)) trs <- lapply(seq_len(NROW(tmp)), function(i) { @@ -26,17 +76,38 @@ summary.etm <- function(object, all = FA absorb <- setdiff(levels(object$tran$to), levels(object$trans$from)) for (i in seq_along(absorb)) trs <- trs[-grep(paste("^", absorb[i], sep =""), trs, perl = TRUE)] + + } else { + + ref <- sapply(1:length(object$state.names), function(i) { + paste(object$state.names, object$state.names[i]) + }) + ref <- matrix(ref) + if (sum(tr.choice %in% ref == FALSE) > 0) + stop("Argument 'tr.choice' and possible transitions must match") + trs <- tr.choice } - else { - dtrs <- diag(outer(object$state.names, object$state.names, paste)) - absorb <- setdiff(levels(object$tran$to), levels(object$trans$from)) - for (i in seq_along(absorb)) - dtrs <- dtrs[-grep(paste("^", absorb[i], sep =""), dtrs, perl = TRUE)] - tmp <- paste(object$trans[, 1], object$trans[, 2]) - trs <- c(tmp, dtrs) + + not_missing <- !missing(times) + if (ns > 1) { + + res <- lapply(seq_len(ns), function(i) { + tmp <- ci.transfo(object[[i]], trs, level, ci.fun) + if (not_missing) tmp <- lapply(tmp, find_times, timepoints = times) + class(tmp) <- "summary.etm" + tmp + }) + names(res) <- object$strata + class(res) <- "summary.etm" + + } else { + + res <- ci.transfo(object, trs, level, ci.fun) + if (not_missing) res <- lapply(res, find_times, timepoints = times) + class(res) <- "summary.etm" } - res <- ci.transfo(object, trs, level, ci.fun) - class(res) <- "summary.etm" + res } - + + diff -pruN 0.6-2.1-1/R/transfoData.R 1.0.4-2/R/transfoData.R --- 0.6-2.1-1/R/transfoData.R 2014-12-08 21:13:44.000000000 +0000 +++ 1.0.4-2/R/transfoData.R 2017-03-08 09:46:04.000000000 +0000 @@ -74,6 +74,7 @@ etmprep <- function(time, status, data, ## let's try to start the real work newdata <- lapply(seq_len(n), function(i) { + ind <- which(status[i, ] != 0) li <- length(ind) if (li == 0) { diff -pruN 0.6-2.1-1/R/xyplot.etm.R 1.0.4-2/R/xyplot.etm.R --- 0.6-2.1-1/R/xyplot.etm.R 2012-05-12 11:25:23.000000000 +0000 +++ 1.0.4-2/R/xyplot.etm.R 2018-01-29 20:49:58.000000000 +0000 @@ -1,15 +1,17 @@ xyplot.etm <- function(x, data = NULL, tr.choice, col = c(1, 1, 1), lty = c(1, 3, 3), xlab="Time", ylab = "Transition probability", conf.int = TRUE, ci.fun = "linear", level = 0.95, ...) { - + if (!inherits(x, "etm")) stop("Argument 'x' must be of class 'etm'") - + + is_stratified <- !is.null(x$strata) + ref <- sapply(1:length(x$state.names), function(i) { paste(x$state.names, x$state.names[i]) }) ref <- matrix(ref) - + if (missing(tr.choice)) { ufrom <- unique(x$trans$from) uto <- unique(x$trans$to) @@ -21,26 +23,48 @@ xyplot.etm <- function(x, data = NULL, t paste(x$trans$from, x$trans$to)) tr.choice <- pos } - + if (sum(tr.choice %in% ref == FALSE) > 0) stop("Argument 'tr.choice' and possible transitions must match") - - temp <- ci.transfo(x, tr.choice, level, ci.fun) - + + if (is_stratified) { + + lstrat <- length(x$strata) + temp <- lapply(seq_len(lstrat), function(i) { + tmp <- ci.transfo(x[[i]], tr.choice, level, ci.fun) + tmp2 <- lapply(tmp, cbind, strata = x$strata[[i]]) + tmp2 + }) + temp <- do.call(c, temp) + } else { + temp <- ci.transfo(x, tr.choice, level, ci.fun) + } + for (i in seq_along(temp)) { temp[[i]]$cov <- names(temp)[i] } temp <- do.call(rbind, temp) temp$cov <- factor(temp$cov, levels = tr.choice) - - if (conf.int) { - aa <- xyplot(temp$P + temp$lower + temp$upper ~ temp$time | temp$cov, - type = "s", col = col, lty = lty, xlab = xlab, ylab = ylab, ...) - } - else { - aa <- xyplot(temp$P ~ temp$time | temp$cov, type = "s", - col = col, lty = lty, xlab = xlab, ylab = ylab, ...) + + if (is_stratified) { + if (conf.int) { + aa <- lattice::xyplot(temp$P + temp$lower + temp$upper ~ temp$time | temp$cov + temp$strata, + type = "s", col = col, lty = lty, xlab = xlab, ylab = ylab, ...) + } + else { + aa <- lattice::xyplot(temp$P ~ temp$time | temp$cov + temp$strata, type = "s", + col = col, lty = lty, xlab = xlab, ylab = ylab, ...) + } + } else { + if (conf.int) { + aa <- lattice::xyplot(temp$P + temp$lower + temp$upper ~ temp$time | temp$cov, + type = "s", col = col, lty = lty, xlab = xlab, ylab = ylab, ...) + } + else { + aa <- lattice::xyplot(temp$P ~ temp$time | temp$cov, type = "s", + col = col, lty = lty, xlab = xlab, ylab = ylab, ...) + } } - + aa } diff -pruN 0.6-2.1-1/R/zzz.R 1.0.4-2/R/zzz.R --- 0.6-2.1-1/R/zzz.R 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/R/zzz.R 2017-03-08 09:46:04.000000000 +0000 @@ -0,0 +1,20 @@ +##################################################################### +### Some stuffs that have to be somewhere +### Arthur Allignol +##################################################################### + +utils::globalVariables(c("entry", + "exit", + "from", + "to", + "id", + "idd", + "masque", + "entree", + "Haz", + "time", + "V1", + "dhaz"), + package = "etm") + + diff -pruN 0.6-2.1-1/README.md 1.0.4-2/README.md --- 0.6-2.1-1/README.md 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/README.md 2017-03-08 09:46:04.000000000 +0000 @@ -0,0 +1,4 @@ +# etm + +Non-parametric estimation of the matrix of transition probabilities for any time-inhomogeneous multistate model with finite state space. + diff -pruN 0.6-2.1-1/src/cov_aj.cc 1.0.4-2/src/cov_aj.cc --- 0.6-2.1-1/src/cov_aj.cc 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/src/cov_aj.cc 2018-07-11 19:24:14.000000000 +0000 @@ -0,0 +1,62 @@ +#include +// #include + +using namespace arma; + +mat cov_dna(const mat & dna, const vec & nrisk, int d, int D); + +RcppExport SEXP cov_aj(SEXP __time, + SEXP __est, + SEXP __nrisk, + SEXP __nevent, + SEXP __dna) + +{ + + Rcpp::NumericVector _time(__time), _est(__est), _nevent(__nevent), _dna(__dna); + Rcpp::IntegerVector dims = _est.attr("dim"); + Rcpp::NumericMatrix _nrisk(__nrisk); + + const int lt = _time.size(); + const int nstate = dims(0); + const int D = nstate * nstate; // to appease Solaris compiler + + cube est(_est.begin(), nstate, nstate, lt, false); + cube nevent(_nevent.begin(), nstate, nstate, lt, false); + cube dna(_dna.begin(), nstate, nstate, lt, false); + mat nrisk(_nrisk.begin(), lt, nstate, false); + vec time(_time.begin(), _time.size(), false); + + cube cov_etm(D, D, lt); + cov_etm.zeros(); + + mat I(nstate, nstate, fill::eye); + mat II(D, D, fill::eye); + mat cov_deltaNA(D, D, fill::zeros); + + + // first iteration + cov_deltaNA = cov_dna(nevent.slice(0), + nrisk.row(0).t(), + nstate, + D); + + cov_etm.slice(0) = II * cov_deltaNA * II; + + for (int t = 1; t < lt; ++t) { + + mat temp_dna(dna.slice(t).begin(), nstate, nstate, false); + mat temp_est(est.slice(t - 1).begin(), nstate, nstate, false); + + cov_deltaNA = cov_dna(nevent.slice(t), + nrisk.row(t).t(), + nstate, + D); + + cov_etm.slice(t) = kron((I + temp_dna).t(), I) * cov_etm.slice(t - 1) * kron((I+temp_dna),I) + + kron(I, temp_est) * cov_deltaNA * kron(I, temp_est.t()); + + } + + return(Rcpp::wrap(cov_etm)); +} diff -pruN 0.6-2.1-1/src/cov_dna.c 1.0.4-2/src/cov_dna.c --- 0.6-2.1-1/src/cov_dna.c 2018-06-11 10:05:37.000000000 +0000 +++ 1.0.4-2/src/cov_dna.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -#include -#include -#include - -void cov_dna(double *nrisk, double *nev, int *dd, double *cov) { - - const int d = *dd; - const int D = pow(d, 2); - double temp_cov[D][D]; - double t_cov[D*D]; - double sum_nev[d]; - int a, b, i, j, k, l, e, f; - double nr = 0; - double temp[d][d]; - - - /* Initialisation */ - for (a = 0; a < d; ++a) { - sum_nev[a] = 0; - for (b = 0; b < d; ++b) { - temp[a][b] = 0.0; - } - } - for (a = 0; a < D; ++a) { - for (b = 0; b < D; ++b) { - temp_cov[a][b] = 0.0; - t_cov[a + D*b] = 0.0; - } - } - - - for (a = 0; a < d; ++a) { - for (b = 0; b < d; ++b) { - sum_nev[a] += nev[a + d * b]; - } - } - /******************/ - - /* loops on the blocks */ - for (i = 0; i < d; ++i) { - for (j = 0; j < d; ++j) { - - /* loops in the blocks */ - for (k = 0; k < d; ++k) { - for (l = 0; l < d; ++l) { - if (nrisk[k] != 0) { - nr = pow(nrisk[k], 3); - if (k == l) { - if (k == i) { - if (l == j) { - temp[k][l] = ((nrisk[k] - sum_nev[k]) * sum_nev[k]) / nr; - } - else { - temp[k][l] = -(((nrisk[k] - sum_nev[k]) * nev[k + j * d]) / nr); - } - } - else { - if (i != k && j != k) { - if (i == j) { - temp[k][l] = ((nrisk[k] - nev[k + i*d]) * nev[k + i*d])/ nr; - } - else { - temp[k][l] = (-nev[k + i*d] * nev[k + j*d]) / nr; - } - } - } - } - } - - temp_cov[i * d + k][j * d + l] = temp[k][l]; - for (e = 0; e < d; ++e) { - for (f = 0; f < d; ++f) { - temp[e][f] = 0.0; - } - } - } - } - } - } - - for (i = 0; i < D; ++i) { - for (j = 0; j < D; ++j) { - t_cov[i + j*D] = temp_cov[i][j]; - } - } - - for (i = 0; i < D; ++i) { - for (j = 0; j < D; ++j) { - if (t_cov[j * D + i] != 0.0) { - cov[j * D + i] = t_cov[j * D + i]; - cov[i * D + j] = t_cov[j * D + i]; - t_cov[j * D + i] = cov[j * D + i]; - } - } - } -} diff -pruN 0.6-2.1-1/src/gen_msm.cpp 1.0.4-2/src/gen_msm.cpp --- 0.6-2.1-1/src/gen_msm.cpp 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/src/gen_msm.cpp 2018-07-11 19:24:14.000000000 +0000 @@ -0,0 +1,159 @@ +// #define ARMA_NO_DEBUG + +// pbl in the new stuff for "1" event: Probably +// does something weird when last data point with ties + +#include +// #include + +using namespace arma; + +cube prodint(const cube & dna, int nstate, int ltimes); +cube deltaNA(const cube & nev, const mat & nrisk, int nstate, int ltimes); +cube deltaNA_LY(const cube & nev, const mat & nrisk, const mat & which_compute, int nstate, int ltimes); + + +RcppExport SEXP gen_msm(SEXP _times, + SEXP _entry, + SEXP _exit, + SEXP _from, + SEXP _to, + SEXP _nstate, + SEXP _const_modif) + +{ + + Rcpp::NumericVector __entry(_entry), __exit(_exit), times(_times); + Rcpp::IntegerVector __from(_from), __to(_to); + Rcpp::IntegerMatrix __const_modif(_const_modif); + + // ProfilerStart("/tmp/gen_msm.prof"); + + vec Tentry(__entry.begin(), __entry.size(), false); + vec Texit(__exit.begin(), __exit.size(), false); + ivec Tfrom(__from.begin(), __from.size(), false); + ivec Tto(__to.begin(), __to.size(), false); + imat const_modif(__const_modif.begin(), __const_modif.nrow(), __const_modif.ncol(), false); + + // do some sorting + std::sort(times.begin(), times.end()); + uvec ind_entry = sort_index(Tentry); + uvec ind_exit = sort_index(Texit); + + vec entry = Tentry.elem(ind_entry); + ivec from_entry = Tfrom.elem(ind_entry); + + vec exit = Texit.elem(ind_exit); + ivec to = Tto.elem(ind_exit); + ivec from_exit = Tfrom.elem(ind_exit); + + const int lt = times.size(); + const int n = entry.size(); + const int nstate = Rcpp::as(_nstate); + + // define the matrices we need + mat nrisk(lt, nstate, fill::zeros); + + cube nev(nstate, nstate, lt); nev.zeros(); + cube dna(nstate, nstate, lt); dna.zeros(); + + + // the entries + int l = 0; + for (int j = 0; j < n; ++j) { + if (entry[j] < times[l]) { + nrisk(l, from_entry[j] - 1) += 1; + } else { + while (l < lt && entry[j] >= times[l] && entry[j] <= max(times)) { + ++l; + } + nrisk(l, from_entry[j] - 1) += 1; + } + } + + // the events + int t = 0; + + // only one event time. And different code paths if 1 data point + // or more + if (lt == 1) { + if (to[0] != 0) nev(from_exit[0] - 1, to[0] - 1, 0) += 1; + if (n > 1) { + for (int i = 1; i 1) { + nrisk(1, from_exit[0] - 1) -= 1; + } + ii = 1; + } else { + if (to[ii] != 0) nev(from_exit[ii] - 1, to[ii] - 1, 0) += 1; + nrisk(1, from_exit[ii] - 1) -= 1; + ++ii; + } + + for (int i = ii; i times[t]) break; + if (to[i] != 0) nev(from_exit[i] - 1, to[i] - 1, t) += 1; + } + } + } + } + mat y = cumsum(nrisk); + + irowvec cc = const_modif.row(0); + if (any(cc)) { + umat tmp = (y >= const_modif); + mat which_compute = conv_to::from(tmp); + // Nelson-Aalen (the increments) Lai and Ying + dna = deltaNA_LY(nev, y, which_compute, nstate, lt); + } + else { + // Nelson-Aalen (the increments) original + dna = deltaNA(nev, y, nstate, lt); + } + + cube est = prodint(dna, nstate, lt); + // ProfilerStop(); + + return Rcpp::List::create(Rcpp::Named("n.risk") = y, + Rcpp::Named("n.event") = nev, + Rcpp::Named("dna") = dna, + Rcpp::Named("est") = est, + Rcpp::Named("time") = times); + +} + + diff -pruN 0.6-2.1-1/src/init.c 1.0.4-2/src/init.c --- 0.6-2.1-1/src/init.c 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/src/init.c 2018-07-11 19:24:14.000000000 +0000 @@ -0,0 +1,28 @@ +#include +#include +#include // for NULL +#include + +/* FIXME: + Check these declarations against the C/Fortran source code. +*/ + +/* .Call calls */ +extern SEXP cov_aj(SEXP, SEXP, SEXP, SEXP, SEXP); +extern SEXP gen_msm(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); +extern SEXP los_cp(SEXP, SEXP, SEXP); +extern SEXP los_nocp(SEXP, SEXP, SEXP); + +static const R_CallMethodDef CallEntries[] = { + {"cov_aj", (DL_FUNC) &cov_aj, 5}, + {"gen_msm", (DL_FUNC) &gen_msm, 7}, + {"los_cp", (DL_FUNC) &los_cp, 3}, + {"los_nocp", (DL_FUNC) &los_nocp, 3}, + {NULL, NULL, 0} +}; + +void R_init_etm(DllInfo *dll) +{ + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} diff -pruN 0.6-2.1-1/src/los_etm.cc 1.0.4-2/src/los_etm.cc --- 0.6-2.1-1/src/los_etm.cc 2018-06-11 10:05:37.000000000 +0000 +++ 1.0.4-2/src/los_etm.cc 1970-01-01 00:00:00.000000000 +0000 @@ -1,195 +0,0 @@ -#include "matrix.h" - - -extern "C" { - - void los_cp (double* times, // transition times - double* ma, // transition matrices - int* len, // number of transitions - int* rows, // row number of transition matrice - int* cols, // colum nnumber of transition matrice - double* los1, // LOS given state 1 - double* los0, // LOS given state 0 - double* phi2case, - double* phi2control, - double* phi3case, - double* phi3control, - double* tau - ) { - - Vector Times(times,*len); - - Array Ma(ma,*rows,*cols,*len ); - - Vector Los1(los1, *len); - Los1[*len - 1] = *tau; - - Vector Los0(los0,*len); - Los0[*len - 1] = *tau; - - Vector Phi2case(phi2case,*len); - - Vector Phi2control(phi2control,*len); - - Vector Phi3case(phi3case,*len); - - Vector Phi3control(phi3control,*len); - - - Matrix Diag(*rows, *cols); - Diag.identity(); - - Array A; - A.push_back(Diag); - - Array A2; - A2.push_back(Diag); - - Vector T; - T.push_back(*tau); - - Vector T2; - - for(int i = (Times.size() - 2); i >= 0; --i) { - itVector vpos = T.begin(); - T.insert(vpos, Times[i+1]); - - itVector vpos2 = T2.begin(); - T2.insert(vpos2, Times[i+1]); - - Vector Diff = T.diff(); - - A = Ma[i+1]*A; - - Vector a11; - Vector a00; - Vector a01; - - for(int j = 0; j < A.size(); ++j) { - a11.push_back( A[j][1][1] ); - a00.push_back( A[j][0][0] ); - a01.push_back( A[j][0][1] ); - } - - Los1[i] = Times[i+1] + scalar(Diff, a11); - - Los0[i] = Times[i+1] + scalar(Diff, (a00 + a01)); - - if( i == (Times.size() - 2)) { - Phi2case[i] = Times[(Times.size()-1)] * A[(A.size()-1)][1][2]; - - Phi3case[i] = Times[(Times.size()-1)] * A[(A.size()-1)][1][3]; - } - else { - Vector Diff2 = T2.diff(); - - //cout << Diff2 << endl; - - A2 = Ma[i+1]*A2; - - Vector a12; - Vector a13; - - for(int l = 0; l < A2.size(); ++l) { - a12.push_back( A2[l][1][2] ); - a13.push_back( A2[l][1][3] ); - } - - Phi2case[i] = (Times[(Times.size()-1)] * A[(A.size()-1)][1][2]) - scalar(Diff2, a12); - - Phi3case[i] = (Times[(Times.size()-1)] * A[(A.size()-1)][1][3]) - scalar(Diff2, a13); - - - // stack identity matrix on top for the next loop - itArray apos2 = A2.begin(); - A2.insert(apos2, Diag); - } - - Phi2control[i] = A[(A.size()-1)][1][2] * Los0[i]; - - Phi3control[i] = A[(A.size()-1)][1][3] * Los0[i]; - - // stack identity matrix on top for the next loop - itArray apos = A.begin(); - A.insert(apos, Diag); - } - - Los1.as_double(los1); - - Los0.as_double(los0); - - Phi2case.as_double(phi2case); - - Phi2control.as_double(phi2control); - - Phi3case.as_double(phi3case); - - Phi3control.as_double(phi3control); - } -} - - -/* To be called when there's no competing risks */ -extern "C" { - - void los_nocp(double *times, - double *ma, - int *len, - int *rows, - int *cols, - double *los1, - double *los0, - double *tau) { - - - Vector Times(times,*len); - - Array Ma(ma,*rows,*cols,*len ); - - Vector Los1(los1, *len); - Los1[*len] = *tau; - - Vector Los0(los0,*len); - Los0[*len] = *tau; - - Matrix Diag(*rows, *cols); - Diag.identity(); - - Array A; - A.push_back(Diag); - - Vector T; - T.push_back(*tau); - - for(int i = (Times.size() - 2); i >= 0; --i) { - itVector vpos = T.begin(); - T.insert(vpos, Times[i+1]); - - Vector Diff = T.diff(); - - A = Ma[i+1]*A; - - Vector a11; - Vector a00; - Vector a01; - - for(int j = 0; j < A.size(); ++j) { - a11.push_back( A[j][1][1] ); - a00.push_back( A[j][0][0] ); - a01.push_back( A[j][0][1] ); - } - - Los1[i] = Times[i+1] + scalar(Diff, a11); - - Los0[i] = Times[i+1] + scalar(Diff, (a00 + a01)); - - // stack identity matrix on top for the next loop - itArray apos = A.begin(); - A.insert(apos, Diag); - } - - Los1.as_double(los1); - - Los0.as_double(los0); - } -} diff -pruN 0.6-2.1-1/src/los_etm.cpp 1.0.4-2/src/los_etm.cpp --- 0.6-2.1-1/src/los_etm.cpp 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/src/los_etm.cpp 2018-07-11 19:24:14.000000000 +0000 @@ -0,0 +1,154 @@ +// diff start at .begin() + 1 + +#include +// #include + +using namespace arma; + +vec my_diff(const vec bouh); + +/* + Length of stay without competing outcomes +*/ +RcppExport SEXP los_nocp(SEXP __times, + SEXP __tr_mat, + SEXP __tau) { + + Rcpp::NumericVector _times(__times), _tr_mat(__tr_mat); + Rcpp::IntegerVector Dims = _tr_mat.attr("dim"); + const double tau = Rcpp::as(__tau); + const int lt = _times.size(); + const int nstate = Dims[0]; + cube tr_mat(_tr_mat.begin(), nstate, nstate, lt); + vec times(_times.begin(), _times.size(), false); + + vec T(times); + T.resize(lt+1); T[lt] = tau; + + // new stuffs we'll need + mat::fixed<3, 3> I; + I.eye(); + + cube aj(nstate, nstate, lt); + + for (int i = 0; i < lt; ++i) { + tr_mat.slice(i) = tr_mat.slice(i) + I; + aj.slice(i).eye(); + } + + vec los0(lt), los1(lt), a00(lt), a11(lt), a01(lt); + a00.zeros(); + a01.zeros(); + a11.zeros(); + + los0.fill(tau); + los1.fill(tau); + + for (int t = (times.size() - 2); t >= 0; --t) { + + vec dd = my_diff(T(span(t+1, lt))); + + for (int j = t; j < lt; ++j) { + aj.slice(j) = aj.slice(j) * tr_mat.slice(t+1); + a00(j) = aj(0, 0, j); + a01(j) = aj(0, 1, j); + a11(j) = aj(1, 1, j); + } + + colvec a = a00(span(t, lt - 2)) + a01(span(t, lt - 2)); + colvec b = a11(span(t, lt - 2)); + + los0[t] = T[t+1] + as_scalar(dd.t() * a); + los1[t] = T[t+1] + as_scalar(dd.t() * b); + } + + return Rcpp::List::create(Rcpp::Named("los0") = los0, + Rcpp::Named("los1") = los1); + +} + + + +/* + Length of stay with competing outcomes +*/ +RcppExport SEXP los_cp(SEXP __times, + SEXP __tr_mat, + SEXP __tau) { + + Rcpp::NumericVector _times(__times), _tr_mat(__tr_mat); + Rcpp::IntegerVector Dims = _tr_mat.attr("dim"); + const double tau = Rcpp::as(__tau); + const int lt = _times.size(); + const int nstate = Dims[0]; + cube tr_mat(_tr_mat.begin(), nstate, nstate, lt); + vec times(_times.begin(), _times.size(), false); + + vec T(times); + T.resize(lt+1); T[lt] = tau; + + // new stuffs we'll need + mat::fixed<4, 4> I; + I.eye(); + + cube aj(nstate, nstate, lt); + + for (int i = 0; i < lt; ++i) { + tr_mat.slice(i) = tr_mat.slice(i) + I; + aj.slice(i).eye(); + } + + vec los0(lt), los1(lt), a00(lt), a11(lt), a01(lt), a12(lt), a13(lt), + phi2case(lt), phi2control(lt), + phi3case(lt), phi3control(lt); + + a00.zeros(); + a01.zeros(); + a11.zeros(); + phi2case.zeros(); + phi2control.zeros(); + phi3case.zeros(); + phi3control.zeros(); + + los0.fill(tau); + los1.fill(tau); + + for (int t = (times.size() - 2); t >= 0; --t) { + + vec dd = my_diff(T(span(t+1, lt))); + + for (int j = t; j < lt; ++j) { + aj.slice(j) = tr_mat.slice(t+1) * aj.slice(j); + a00(j) = aj(0, 0, j); + a01(j) = aj(0, 1, j); + a11(j) = aj(1, 1, j); + a12(j) = aj(1, 2, j); + a13(j) = aj(1, 3, j); + } + + colvec a = a00(span(t, lt - 2)) + a01(span(t, lt - 2)); + colvec b = a11(span(t, lt - 2)); + colvec c = a12(span(t, lt - 2)); + colvec d = a13(span(t, lt - 2)); + + los0[t] = T[t+1] + as_scalar(dd.t() * a); + los1[t] = T[t+1] + as_scalar(dd.t() * b); + + phi2case[t] = T[lt - 1] * aj(1, 2, lt - 1) - as_scalar(dd.t() * c); + phi3case[t] = T[lt - 1] * aj(1, 3, lt - 1) - as_scalar(dd.t() * d); + + phi2control[t] = aj(1, 2, lt - 1) * los0[t]; + phi3control[t] = aj(1, 3, lt - 1) * los0[t]; + } + + return Rcpp::List::create(Rcpp::Named("los0") = los0, + Rcpp::Named("los1") = los1, + Rcpp::Named("phi2control") = phi2control, + Rcpp::Named("phi3control") = phi3control, + Rcpp::Named("phi2case") = phi2case, + Rcpp::Named("phi3case") = phi3case); + +} + + + diff -pruN 0.6-2.1-1/src/Makevars 1.0.4-2/src/Makevars --- 0.6-2.1-1/src/Makevars 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/src/Makevars 2018-07-11 19:24:14.000000000 +0000 @@ -0,0 +1,2 @@ +## PKG_LIBS = $(LAPACK_LIBS) -lprofiler $(BLAS_LIBS) $(FLIBS) +PKG_LIBS = $(LAPACK_LIBS) -g $(BLAS_LIBS) $(FLIBS) diff -pruN 0.6-2.1-1/src/Makevars.win 1.0.4-2/src/Makevars.win --- 0.6-2.1-1/src/Makevars.win 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/src/Makevars.win 2018-07-11 19:24:14.000000000 +0000 @@ -0,0 +1,2 @@ + +PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) diff -pruN 0.6-2.1-1/src/matrix.cc 1.0.4-2/src/matrix.cc --- 0.6-2.1-1/src/matrix.cc 2018-06-11 10:05:37.000000000 +0000 +++ 1.0.4-2/src/matrix.cc 1970-01-01 00:00:00.000000000 +0000 @@ -1,490 +0,0 @@ -#include "matrix.h" - - -/* - Vector class definitions -*/ -Vector::Vector():dVector(){ -} - -Vector::Vector(const int n):dVector(n){ -} - -Vector::Vector(double* v, const int n):dVector(){ - for(int i=0;i 0 ) s << "("; - -// for(int i=0;isize() != v.size()) { - // cout << "VECTOR Error: You're trying to add vectors of different sizes\n"; - // cout << v << endl;; - // cout << *this << endl; - - return Vector(); - } - - Vector sum(this->size()); - for(i=0;isize();i++) sum[i] = this->at(i)+v[i]; - return sum; -} - -Vector Vector::operator -(const Vector& v) { - int i; - - if( this->size() != v.size()) { - // cout << "VECTOR Error: You're trying to subtract vectors of different sizes\n"; - // cout << v << endl;; - // cout << *this << endl; - - return Vector(); - } - - Vector sum(this->size()); - for(i=0;isize();i++) sum[i] = this->at(i)-v[i]; - return sum; - -} - -Vector Vector::operator*(const Vector& v) { - int i; - - if( this->size() != v.size()) { - // cout << "VECTOR Error: You're trying to multiply vectors of different sizes\n"; - // cout << v << endl;; - // cout << *this << endl; - - return Vector(); - } - - Vector p(this->size()); - for(i=0;isize();i++) p[i] = this->at(i)*v[i]; - return p; -} - -double scalar(const Vector& v1, const Vector& v2) { - int i; - - double p = 0.0; - - if( v1.size() != v2.size()) { - // cout << "VECTOR Error: You're trying to multiply vectors of different sizes\n"; - // cout << v1 << endl;; - // cout << v2 << endl; - - return p; - } - - for(i=0;iat(0); - for(int i=1;isize();i++) if(this->at(i) > max) max=this->at(i); - return max; -} - -double Vector::min(void)const { - double min=this->at(0); - for(int i=1;isize();i++) if(this->at(i) < min) min=this->at(i); - return min; -} - -double Vector::mean()const { - double sum=0; - for(int i=0;isize();i++) sum += this->at(i); - return sum/(this->size()); -} - -void Vector::zero(void) { - for(int i=0;isize();i++) this->at(i)=0.0; - - return; -} - -double Vector::norm(void) const -{ - double s=0.0; - for(int i=0;isize();i++) s+= this->at(i)*this->at(i); - return sqrt(s); -} - -Vector Vector::diff() const -{ - int len = this->size(); - - if( len > 1 ) { - Vector v(len-1); - - for(int i=0; i < (len - 1); i++){ - v[i] = this->at(i+1) - this->at(i); - } - - return v; - } - - return Vector(); -} - -void Vector::as_double(double* a) -{ - for( int i=0; isize(); i++ ) { - a[i] = this->at(i); - } -} - -/* - Matrix class definitions -*/ -Matrix::Matrix():dMatrix(){ -} - -Matrix::Matrix(const int n):dMatrix(n){ -} - -Matrix::Matrix(const int r,const int c) -{ - Vector v(c); - - for(int i=0;isize() == 0 || m.size() == 0 ) return Matrix(); - int rows = this->size(); - int cols = (this->at(0)).size(); - int m_rows = m.size(); - int m_cols = (m.at(0)).size(); - - if(cols != m_rows) { - // cout << "MATRIX Error: Matrix Matrix::operator*(const Matrix& m):" << endl; - // cout << "matrices are the wrong size: " << cols << ", " << m_rows << endl; - - return Matrix(); - } - - Matrix ans(rows,m_cols); - - for(int i=0;iat(i)).at(k)*m[k][j]; - } - } - } - - return ans; -} - -Vector Matrix::operator*(const Vector& v) -{ - if(this->size() == 0 || v.size() == 0 ) return Vector(); - int rows = this->size(); - int cols = (this->at(0)).size(); - - - if(cols != v.size()) { - // cout << "MATRIX Error: multiplying matrix times Vector with wrong sizes\n"; - return Vector(); - } - - Vector ans(rows); - - for(int i=0;iat(i)).at(j)*v[j]; - } - - return ans; -} - -Matrix operator*(const double x, const Matrix& m) -{ - if( m.size() == 0 ) return Matrix(); - - int m_rows = m.size(); - int m_cols = (m.at(0)).size(); - - - Matrix a(m_rows,m_cols); - - for(int i=0; isize() == 0 || m.size() == 0 ) return Matrix(); - int rows = this->size(); - int cols = (this->at(0)).size(); - int m_rows = m.size(); - int m_cols = (m.at(0)).size(); - - - if(rows!= m_rows || cols != m_cols) { - // cout << "MATRIX Error: you're trying to add matrices of different sizes\n"; - return Matrix(); - } - - Matrix ans(m_rows, m_cols); - - for(int i=0;iat(i)).at(j) + m[i][j]; - } - } - - return ans; -} - -Matrix Matrix::operator-(const Matrix& m) -{ - if(this->size() == 0 || m.size() == 0 ) return Matrix(); - int rows = this->size(); - int cols = (this->at(0)).size(); - int m_rows = m.size(); - int m_cols = (m.at(0)).size(); - - - if(rows!= m_rows || cols != m_cols) { - // cout << "MATRIX Error: you're trying to add matrices of different sizes\n"; - return Matrix(); - } - - Matrix ans(m_rows, m_cols); - - for(int i=0;iat(i)).at(j) - m[i][j]; - } - } - - return ans; -} - -void Matrix::zero(void) -{ - if(this->size() == 0 ) return; - - int rows = this->size(); - int cols = (this->at(0)).size(); - - for(int i=0;iat(i)).at(j)=0.0; - } - - } - - return; - -} - -void Matrix::identity(void) -{ - if(this->size() == 0 ) return; - - int rows = this->size(); - int cols = (this->at(0)).size(); - - - if(rows!=cols) { - // cout << "MATRIX Error: Matrix::identity(): Matrix not square\n"; - } - - - zero(); - - for(int i=0;iat(i)).at(i)=1.0; - - return; -} - -void Matrix::as_double(double* a) -{ - int rows = this->size(); - - for( int i=0; iat(i)).size(); - - for( int j=0; jat(i)).at(j); - - } - } -} - - - -/* - Array class definitions -*/ -Array::Array():dArray(){ -} - -Array::Array(const int len):dArray(len){ -} - -Array::Array(const int rows, const int cols, const int len) -{ - Matrix m(rows, cols); - - for(int i=0;isize(); - - for( int k=0; kat(k)).size(); - - for( int i=0; iat(k)).at(i)).size(); - - for( int j=0; jat(k)).at(i)).at(j); - } - } - } -} - -Array operator*(const Matrix& m, const Array& a) -{ - int len = a.size(); - - Array aj; - - for( int k=0; k */ -#include - -#include - - -using namespace std; - - -class Vector; -class Matrix; - - -typedef vector< double, allocator > dVector; // vector of doubles (double vectorx) -typedef dVector::iterator itVector; - -typedef vector dMatrix; // vector of double vectors (double Matrix) -typedef dMatrix::iterator itMatrix; - -typedef vector dArray; // vector of double matrices (Array of double matrices) -typedef dArray::iterator itArray; - -class Vector : public dVector -{ -public: - Vector(); - - Vector(const int n); - - Vector(double* v, const int n); - -// friend ostream& operator <<(ostream& s, const Vector& v); - - Vector operator +(const Vector& v); - - Vector operator -(const Vector& v); - - friend Vector operator*(double x, const Vector& v); - - friend Vector operator*(const Vector& v, double x); - - Vector operator*(const Vector& v); - - friend double scalar(const Vector& v1, const Vector& v2); - - double max()const; - - double min()const; - - double mean()const; - - void zero(void); - - double norm(void)const; - - Vector diff() const; - - void as_double(double* a); - -}; - -class Matrix: public dMatrix -{ - -public: - - //constructor - Matrix(); - - Matrix(const int n); - - Matrix(const int r,const int c); - - Matrix(double* m, const int r,const int c); - -/* friend ostream& operator<<(ostream& s, const Matrix& m); */ - - Matrix operator*(const Matrix& m); - - Vector operator*(const Vector& v); - - friend Matrix operator*(const double, const Matrix& m); - - friend Matrix operator*(const Matrix& m, const double); - - Matrix operator+(const Matrix& m); - - Matrix operator-(const Matrix& m); - - void zero(void); - - void identity(void); - - void as_double(double* a); - -}; - - -class Array : public dArray -{ - - public: - Array(); - - Array(const int l); - - Array(const int r,const int c, const int l); - - Array(double*a, const int r, const int c, const int l); - - friend Array operator*(const Matrix& m, const Array& a); - - friend Array operator*(const Array& a, const Matrix& m); - - /* friend ostream& operator<<(ostream& s,Array a); */ - - void as_double(double* a); - -}; - -#endif diff -pruN 0.6-2.1-1/src/risk_set_etm.c 1.0.4-2/src/risk_set_etm.c --- 0.6-2.1-1/src/risk_set_etm.c 2018-06-11 10:05:37.000000000 +0000 +++ 1.0.4-2/src/risk_set_etm.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -#include - -void risk_set_etm(int *n, int *lt, int *dim_nev, double *times, - int *from, int *to, double *entry, double *exit, - int *nrisk, int *ncens, int *nev, double *dna) { - - const int ltimes = *lt; - const int dim_trans = dim_nev[1]; - const int nb = *n; - int i, j, t; - - /* Computation of the risk set and transition matrix */ - - for (j=0; j < nb; ++j) { - for (i=0; i < ltimes; ++i) { - if (entry[j] < times[i] && exit[j] >= times[i]) { - nrisk[i + *lt * (from[j] - 1)] += 1; - } - if (exit[j] == times[i] && to[j] != 0) { - nev[dim_nev[1] * dim_nev[1]*i + from[j] - 1 + dim_nev[1] * (to[j] - 1)] += 1; - break; - } - } - } - - for (i = 0; i < dim_trans; ++i) { - nrisk[i * (*lt)] = nrisk[i * (*lt) + 1]; - } - - /* Nelson-Aalen increments */ - for (t = 0; t < ltimes; ++t) { - for (j = 0; j < dim_trans; ++j) { - for (i = 0; i < dim_trans; ++i) { - if (nrisk[i * (*lt) + t] != 0) { - dna[dim_nev[1] * dim_nev[1] * t + j * dim_nev[1] + i] = - (double) nev[dim_nev[1] * dim_nev[1] * t + j * dim_nev[1]+i] / (double) nrisk[i*(*lt)+t]; - } - } - } - } -} - diff -pruN 0.6-2.1-1/src/utils.cpp 1.0.4-2/src/utils.cpp --- 0.6-2.1-1/src/utils.cpp 1970-01-01 00:00:00.000000000 +0000 +++ 1.0.4-2/src/utils.cpp 2018-07-11 19:24:14.000000000 +0000 @@ -0,0 +1,159 @@ +#include + +using namespace arma; + +vec my_diff(const vec bouh) { + + int lbouh = bouh.size(); + vec res(lbouh - 1); res.zeros(); + + for (int i = 0; i < (lbouh - 1); ++i) { + res[i] = bouh[i+1] - bouh[i]; + } + + return res; +} + +cube prodint(const cube & dna, int nstate, int ltimes) { + + cube aj(dna.begin(), nstate, nstate, ltimes); + mat I = eye(nstate, nstate); + + aj.slice(0) = aj.slice(0) + I; + + for (int i = 1; i < ltimes; ++i) { + aj.slice(i) = aj.slice(i-1) * (I + aj.slice(i)); + } + + return aj; +} + + +cube deltaNA(const cube & nev, const mat & nrisk, int nstate, int ltimes) { + + cube dna(nstate, nstate, ltimes); + dna.zeros(); + + for (int t=0; t < ltimes; ++t) { + for (int i=0; i < nstate; ++i) { + if (nrisk.at(t, i) != 0) { + for (int j=0; j< nstate; ++j) { + dna.at(i, j, t) = nev.at(i, j, t) / nrisk.at(t, i); + } + } + } + + mat tmp(dna.slice(t).begin(), nstate, nstate, false); + vec d = sum(tmp, 1); + tmp.diag() = -d; + + } + + return dna; + +} + + +/* +lai and ying modification of the Nelson Aalen estimator. +we have an extra argument: a matrix similar to nrisk, with 0s and 1s +that says where we should compute +*/ +cube deltaNA_LY(const cube & nev, const mat & nrisk, const mat & which_compute, + int nstate, int ltimes) { + + cube dna(nstate, nstate, ltimes); + dna.zeros(); + + for (int t=0; t < ltimes; ++t) { + for (int i=0; i < nstate; ++i) { + if (nrisk.at(t, i) != 0) { + for (int j=0; j< nstate; ++j) { + dna.at(i, j, t) = which_compute.at(t, i) * nev.at(i, j, t) / nrisk.at(t, i); + } + } + } + + mat tmp(dna.slice(t).begin(), nstate, nstate, false); + vec d = sum(tmp, 1); + tmp.diag() = -d; + + } + + return dna; + +} + + +mat cov_dna(const mat & nev, const vec & nrisk, int d, int D) { + + mat the_cov(D, D); + the_cov.zeros(); + + uvec from(D); from.zeros(); + uvec to(D); to.zeros(); + + // construct vectors that store the k and l; m, n for each + // indice of the final covariance matrix + for (int i = 0; i < d; ++i) { + for (int j = 0; j < d; ++j) { + from[j + i * d] = j; + to[j + i * d] = i; + } + } + + vec sum_nev = sum(nev, 1); + vec pow_nrisk = pow(nrisk, -3); + + for (int j = 0; j < D; ++j) { + for (int i = 0; i < D; ++i) { + + if (nrisk[from[i]] != 0) { + + int cond = 1 * (from[i] == to[i] && from[i] == from[j] && from[j] == to[j]) + + 2 * (from[i] == to[i] && from[i] == from[j] && from[i] != to[j]) + + 4 * (from[i] == from[j] && from[i] != to[i] && from[i] != to[j] && to[i] == to[j]) + + 8 * (from[i] == from[j] && from[i] != to[i] && from[i] != to[j] && to[i] != to[j]) + + // add a condition for the symmetric of cond 2 + 16 * (from[j] == to[j] && from[i] == from[j] && from[i] != to[i]); + + switch(cond) { + case 1: + the_cov(i, j) = (nrisk[from[i]] - sum_nev[from[i]]) * + sum_nev[from[i]] * pow_nrisk[from[i]]; + break; + case 2: + the_cov(i, j) = -(nrisk[from[i]] - sum_nev[from[i]]) * + nev(from[i], to[j]) * pow_nrisk[from[i]]; + break; + case 4: + the_cov(i, j) = (nrisk[from[i]] - nev(from[i], to[i])) * + nev(from[i], to[j]) * pow_nrisk[from[i]]; + break; + case 8: + the_cov(i, j) = -nev(from[i], to[i]) * + nev(from[i], to[j]) * pow_nrisk[from[i]]; + break; + case 16: + the_cov(i, j) = -(nrisk[from[i]] - sum_nev[from[i]]) * + nev(from[i], to[i]) * pow_nrisk[from[i]]; + break; + default: + the_cov(i, j) = 0; + } + + } + } + } + + // Alternative algorithm, just fill the lower triamgular part of the matrix. Then + // "symmetrize the matrix + // the_cov = the_cov + the_cov.t(); + // the_cov.diag() /= 2; + +// Rcpp::Rcout << "cov_dna is" << std::endl << the_cov << std::endl; +// Rcpp::Rcout << "cov_dna[2,5] is" << std::endl << the_cov(1, 4) << std::endl; + + return the_cov; +} + diff -pruN 0.6-2.1-1/tests/test.etmCIF.R 1.0.4-2/tests/test.etmCIF.R --- 0.6-2.1-1/tests/test.etmCIF.R 2012-05-12 11:25:22.000000000 +0000 +++ 1.0.4-2/tests/test.etmCIF.R 2018-06-27 20:18:23.000000000 +0000 @@ -1,8 +1,14 @@ ### test file for etmCIF. ### Really simple tests and comparison with etm +old <- options(digits = 5) + require(etm) +if (!require(survival, quietly = TRUE)) + stop("The following tests require the 'survival' package") + + data(abortion) from <- rep(0, nrow(abortion)) @@ -16,14 +22,13 @@ data <- data.frame(id, from, to, entry, tra <- matrix(FALSE, 4, 4) tra[1, 2:4] <- TRUE -cif.control <- etm(data[data$group == 0, ], c("0", "1", "2", "3"), +cif.control <- etm(data[data$group == 0, ], c("0", "1", "2", "3"), tra, NULL, 0) -cif.exposed <- etm(data[data$group == 1, ], c("0", "1", "2", "3"), +cif.exposed <- etm(data[data$group == 1, ], c("0", "1", "2", "3"), tra, NULL, 0) ## Computation of the CIFs with etmCIF - netm <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, etype = cause, failcode = 3) @@ -65,11 +70,11 @@ all.equal(unname(trprob(cif.exposed, "0 scif.control <- summary(cif.control, ci.fun = "cloglog") scif.exposed <- summary(cif.exposed, ci.fun = "cloglog") -all.equal(scif.control[[3]]$lower, snetm[[1]][[3]]$lower) -all.equal(scif.control[[3]]$upper, snetm[[1]][[3]]$upper) +all.equal(scif.control[[4]]$lower, snetm[[1]][[3]]$lower) +all.equal(scif.control[[4]]$upper, snetm[[1]][[3]]$upper) -all.equal(scif.exposed[[3]]$lower, snetm[[2]][[3]]$lower) -all.equal(scif.exposed[[3]]$upper, snetm[[2]][[3]]$upper) +all.equal(scif.exposed[[4]]$lower, snetm[[2]][[3]]$lower) +all.equal(scif.exposed[[4]]$upper, snetm[[2]][[3]]$upper) ### test with factors in the input @@ -140,3 +145,5 @@ test.c summary(test) summary(test.c) + +options(old) diff -pruN 0.6-2.1-1/tests/test.etmCIF.Rout.save 1.0.4-2/tests/test.etmCIF.Rout.save --- 0.6-2.1-1/tests/test.etmCIF.Rout.save 2013-09-19 19:56:11.000000000 +0000 +++ 1.0.4-2/tests/test.etmCIF.Rout.save 2018-06-27 20:18:45.000000000 +0000 @@ -1,8 +1,7 @@ -R version 2.14.1 (2011-12-22) -Copyright (C) 2011 The R Foundation for Statistical Computing -ISBN 3-900051-07-0 -Platform: x86_64-pc-linux-gnu (64-bit) +R version 3.5.0 (2018-04-23) -- "Joy in Playing" +Copyright (C) 2018 The R Foundation for Statistical Computing +Platform: x86_64-apple-darwin17.5.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. @@ -21,11 +20,14 @@ Type 'q()' to quit R. > ### test file for etmCIF. > ### Really simple tests and comparison with etm > +> old <- options(digits = 5) +> > require(etm) Loading required package: etm -Loading required package: lattice -Loading required package: survival -Loading required package: splines +> +> if (!require(survival, quietly = TRUE)) ++ stop("The following tests require the 'survival' package") +> > > data(abortion) > @@ -40,14 +42,13 @@ Loading required package: splines > tra <- matrix(FALSE, 4, 4) > tra[1, 2:4] <- TRUE > -> cif.control <- etm(data[data$group == 0, ], c("0", "1", "2", "3"), +> cif.control <- etm(data[data$group == 0, ], c("0", "1", "2", "3"), + tra, NULL, 0) -> cif.exposed <- etm(data[data$group == 1, ], c("0", "1", "2", "3"), +> cif.exposed <- etm(data[data$group == 1, ], c("0", "1", "2", "3"), + tra, NULL, 0) > > > ## Computation of the CIFs with etmCIF -> > netm <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, + etype = cause, failcode = 3) > @@ -92,16 +93,16 @@ Covariate: group group = 0 - time P se(P) n.event -CIF 1 43 0.04015931 0.009257784 20 -CIF 2 43 0.79905931 0.022186468 924 -CIF 3 43 0.16078139 0.021326113 69 + time P se(P) n.event +CIF 1 43 0.040159 0.0092578 20 +CIF 2 43 0.799059 0.0221865 924 +CIF 3 43 0.160781 0.0213261 69 group = 1 - time P se(P) n.event -CIF 1 42 0.2851118 0.04249308 38 -CIF 2 42 0.3525651 0.04213898 92 -CIF 3 42 0.3623231 0.04947340 43 + time P se(P) n.event +CIF 1 42 0.28511 0.042493 38 +CIF 2 42 0.35257 0.042139 92 +CIF 3 42 0.36232 0.049473 43 > > ## test on the summary > snetm <- summary(netm) @@ -111,61 +112,61 @@ CIF 3 42 0.3623231 0.04947340 43 group=0 CIF 1 - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.00000000 0.00000000 18 0 - 0.03895488 13 8.444048e-05 0.02448808 0.06169378 645 1 - 0.04015931 23 8.570657e-05 0.02551262 0.06293875 819 0 - 0.04015931 33 8.570657e-05 0.02551262 0.06293875 885 0 - 0.04015931 39 8.570657e-05 0.02551262 0.06293875 716 0 - 0.04015931 43 8.570657e-05 0.02551262 0.06293875 6 0 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 117 0 + 0.038955 13 8.4440e-05 0.024488 0.061694 645 1 + 0.040159 26 8.5707e-05 0.025513 0.062939 846 0 + 0.040159 36 8.5707e-05 0.025513 0.062939 876 0 + 0.040159 40 8.5707e-05 0.025513 0.062939 554 0 + 0.040159 43 8.5707e-05 0.025513 0.062939 6 0 CIF 2 - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.000000000 0.00000000 18 0 - 0.00000000 13 0.000000e+00 0.000000000 0.00000000 645 0 - 0.00000000 23 0.000000e+00 0.000000000 0.00000000 819 0 - 0.01354288 33 1.216141e-05 0.008169604 0.02241009 885 6 - 0.32201590 39 2.469805e-04 0.292313907 0.35391574 716 165 - 0.79905931 43 4.922394e-04 0.753968839 0.84061317 6 6 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 117 0 + 0.000000 13 0.0000e+00 0.000000 0.000000 645 0 + 0.000000 26 0.0000e+00 0.000000 0.000000 846 0 + 0.053197 36 4.6195e-05 0.041379 0.068268 876 25 + 0.563121 40 3.8801e-04 0.524924 0.602021 554 280 + 0.799059 43 4.9224e-04 0.753969 0.840613 6 6 CIF 3 - P time var lower upper n.risk n.event - 0.0000000 4 0.0000000000 0.0000000 0.0000000 18 0 - 0.1504675 13 0.0004551293 0.1135970 0.1979013 645 1 - 0.1570366 23 0.0004553237 0.1199469 0.2041947 819 0 - 0.1599039 33 0.0004549788 0.1227389 0.2069247 885 0 - 0.1607814 39 0.0004548031 0.1235965 0.2077571 716 0 - 0.1607814 43 0.0004548031 0.1235965 0.2077571 6 0 + P time var lower upper n.risk n.event + 0.034188 6 0.00028222 0.01297 0.088523 117 4 + 0.150468 13 0.00045513 0.11360 0.197901 645 1 + 0.159904 26 0.00045498 0.12274 0.206925 846 1 + 0.160781 36 0.00045480 0.12360 0.207757 876 1 + 0.160781 40 0.00045480 0.12360 0.207757 554 0 + 0.160781 43 0.00045480 0.12360 0.207757 6 0 group=1 CIF 1 - P time var lower upper n.risk n.event - 0.0000000 4 0.000000000 0.0000000 0.0000000 8 0 - 0.2604775 12 0.001785362 0.1879526 0.3542503 94 5 - 0.2811533 21 0.001802770 0.2074197 0.3742279 93 1 - 0.2851118 32 0.001805662 0.2111650 0.3780568 90 0 - 0.2851118 38 0.001805662 0.2111650 0.3780568 71 0 - 0.2851118 42 0.001805662 0.2111650 0.3780568 6 0 + P time var lower upper n.risk n.event + 0.00000 6 0.0000000 0.00000 0.00000 35 0 + 0.26048 13 0.0017854 0.18795 0.35425 90 0 + 0.28115 21 0.0018028 0.20742 0.37423 93 1 + 0.28511 34 0.0018057 0.21116 0.37806 89 0 + 0.28511 39 0.0018057 0.21116 0.37806 59 0 + 0.28511 42 0.0018057 0.21116 0.37806 6 0 CIF 2 - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.000000000 0.00000000 8 0 - 0.00000000 12 0.000000e+00 0.000000000 0.00000000 94 0 - 0.00000000 21 0.000000e+00 0.000000000 0.00000000 93 0 - 0.01541036 32 6.016217e-05 0.005730041 0.04110307 90 1 - 0.13034947 38 5.576254e-04 0.090999609 0.18489993 71 12 - 0.35256510 42 1.775693e-03 0.276882073 0.44177471 6 6 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 35 0 + 0.000000 13 0.0000e+00 0.000000 0.000000 90 0 + 0.000000 21 0.0000e+00 0.000000 0.000000 93 0 + 0.023073 34 9.0514e-05 0.010252 0.051504 89 2 + 0.180156 39 8.0126e-04 0.131765 0.243663 59 13 + 0.352565 42 1.7757e-03 0.276882 0.441775 6 6 CIF 3 - P time var lower upper n.risk n.event - 0.0000000 4 0.000000000 0.0000000 0.0000000 8 0 - 0.3143493 12 0.002571501 0.2266494 0.4254211 94 1 - 0.3507019 21 0.002482739 0.2627692 0.4576195 93 0 - 0.3584918 32 0.002459261 0.2706266 0.4644770 90 0 - 0.3584918 38 0.002459261 0.2706266 0.4644770 71 0 - 0.3623231 42 0.002447617 0.2744987 0.4678544 6 0 + P time var lower upper n.risk n.event + 0.057143 6 0.0015394 0.014605 0.20968 35 2 + 0.333246 13 0.0025280 0.245337 0.44216 90 4 + 0.350702 21 0.0024827 0.262769 0.45762 93 0 + 0.358492 34 0.0024593 0.270627 0.46448 89 0 + 0.358492 39 0.0024593 0.270627 0.46448 59 0 + 0.362323 42 0.0024476 0.274499 0.46785 6 0 > > all.equal(unname(trprob(cif.control, "0 3")), snetm[[1]][[3]]$P) @@ -185,14 +186,14 @@ CIF 3 > scif.control <- summary(cif.control, ci.fun = "cloglog") > scif.exposed <- summary(cif.exposed, ci.fun = "cloglog") > -> all.equal(scif.control[[3]]$lower, snetm[[1]][[3]]$lower) +> all.equal(scif.control[[4]]$lower, snetm[[1]][[3]]$lower) [1] TRUE -> all.equal(scif.control[[3]]$upper, snetm[[1]][[3]]$upper) +> all.equal(scif.control[[4]]$upper, snetm[[1]][[3]]$upper) [1] TRUE > -> all.equal(scif.exposed[[3]]$lower, snetm[[2]][[3]]$lower) +> all.equal(scif.exposed[[4]]$lower, snetm[[2]][[3]]$lower) [1] TRUE -> all.equal(scif.exposed[[3]]$upper, snetm[[2]][[3]]$upper) +> all.equal(scif.exposed[[4]]$upper, snetm[[2]][[3]]$upper) [1] TRUE > > @@ -220,77 +221,77 @@ Covariate: group group = 0 - time P se(P) n.event -CIF ETOP 43 0.04015931 0.009257784 20 -CIF life birth 43 0.79905931 0.022186468 924 -CIF spontaneous abortion 43 0.16078139 0.021326113 69 + time P se(P) n.event +CIF ETOP 43 0.040159 0.0092578 20 +CIF life birth 43 0.799059 0.0221865 924 +CIF spontaneous abortion 43 0.160781 0.0213261 69 group = 1 - time P se(P) n.event -CIF ETOP 42 0.2851118 0.04249308 38 -CIF life birth 42 0.3525651 0.04213898 92 -CIF spontaneous abortion 42 0.3623231 0.04947340 43 + time P se(P) n.event +CIF ETOP 42 0.28511 0.042493 38 +CIF life birth 42 0.35257 0.042139 92 +CIF spontaneous abortion 42 0.36232 0.049473 43 > > summary(netm.factor) group=0 CIF ETOP - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.00000000 0.00000000 18 0 - 0.03895488 13 8.444048e-05 0.02448808 0.06169378 645 1 - 0.04015931 23 8.570657e-05 0.02551262 0.06293875 819 0 - 0.04015931 33 8.570657e-05 0.02551262 0.06293875 885 0 - 0.04015931 39 8.570657e-05 0.02551262 0.06293875 716 0 - 0.04015931 43 8.570657e-05 0.02551262 0.06293875 6 0 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 117 0 + 0.038955 13 8.4440e-05 0.024488 0.061694 645 1 + 0.040159 26 8.5707e-05 0.025513 0.062939 846 0 + 0.040159 36 8.5707e-05 0.025513 0.062939 876 0 + 0.040159 40 8.5707e-05 0.025513 0.062939 554 0 + 0.040159 43 8.5707e-05 0.025513 0.062939 6 0 CIF life birth - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.000000000 0.00000000 18 0 - 0.00000000 13 0.000000e+00 0.000000000 0.00000000 645 0 - 0.00000000 23 0.000000e+00 0.000000000 0.00000000 819 0 - 0.01354288 33 1.216141e-05 0.008169604 0.02241009 885 6 - 0.32201590 39 2.469805e-04 0.292313907 0.35391574 716 165 - 0.79905931 43 4.922394e-04 0.753968839 0.84061317 6 6 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 117 0 + 0.000000 13 0.0000e+00 0.000000 0.000000 645 0 + 0.000000 26 0.0000e+00 0.000000 0.000000 846 0 + 0.053197 36 4.6195e-05 0.041379 0.068268 876 25 + 0.563121 40 3.8801e-04 0.524924 0.602021 554 280 + 0.799059 43 4.9224e-04 0.753969 0.840613 6 6 CIF spontaneous abortion - P time var lower upper n.risk n.event - 0.0000000 4 0.0000000000 0.0000000 0.0000000 18 0 - 0.1504675 13 0.0004551293 0.1135970 0.1979013 645 1 - 0.1570366 23 0.0004553237 0.1199469 0.2041947 819 0 - 0.1599039 33 0.0004549788 0.1227389 0.2069247 885 0 - 0.1607814 39 0.0004548031 0.1235965 0.2077571 716 0 - 0.1607814 43 0.0004548031 0.1235965 0.2077571 6 0 + P time var lower upper n.risk n.event + 0.034188 6 0.00028222 0.01297 0.088523 117 4 + 0.150468 13 0.00045513 0.11360 0.197901 645 1 + 0.159904 26 0.00045498 0.12274 0.206925 846 1 + 0.160781 36 0.00045480 0.12360 0.207757 876 1 + 0.160781 40 0.00045480 0.12360 0.207757 554 0 + 0.160781 43 0.00045480 0.12360 0.207757 6 0 group=1 CIF ETOP - P time var lower upper n.risk n.event - 0.0000000 4 0.000000000 0.0000000 0.0000000 8 0 - 0.2604775 12 0.001785362 0.1879526 0.3542503 94 5 - 0.2811533 21 0.001802770 0.2074197 0.3742279 93 1 - 0.2851118 32 0.001805662 0.2111650 0.3780568 90 0 - 0.2851118 38 0.001805662 0.2111650 0.3780568 71 0 - 0.2851118 42 0.001805662 0.2111650 0.3780568 6 0 + P time var lower upper n.risk n.event + 0.00000 6 0.0000000 0.00000 0.00000 35 0 + 0.26048 13 0.0017854 0.18795 0.35425 90 0 + 0.28115 21 0.0018028 0.20742 0.37423 93 1 + 0.28511 34 0.0018057 0.21116 0.37806 89 0 + 0.28511 39 0.0018057 0.21116 0.37806 59 0 + 0.28511 42 0.0018057 0.21116 0.37806 6 0 CIF life birth - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.000000000 0.00000000 8 0 - 0.00000000 12 0.000000e+00 0.000000000 0.00000000 94 0 - 0.00000000 21 0.000000e+00 0.000000000 0.00000000 93 0 - 0.01541036 32 6.016217e-05 0.005730041 0.04110307 90 1 - 0.13034947 38 5.576254e-04 0.090999609 0.18489993 71 12 - 0.35256510 42 1.775693e-03 0.276882073 0.44177471 6 6 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 35 0 + 0.000000 13 0.0000e+00 0.000000 0.000000 90 0 + 0.000000 21 0.0000e+00 0.000000 0.000000 93 0 + 0.023073 34 9.0514e-05 0.010252 0.051504 89 2 + 0.180156 39 8.0126e-04 0.131765 0.243663 59 13 + 0.352565 42 1.7757e-03 0.276882 0.441775 6 6 CIF spontaneous abortion - P time var lower upper n.risk n.event - 0.0000000 4 0.000000000 0.0000000 0.0000000 8 0 - 0.3143493 12 0.002571501 0.2266494 0.4254211 94 1 - 0.3507019 21 0.002482739 0.2627692 0.4576195 93 0 - 0.3584918 32 0.002459261 0.2706266 0.4644770 90 0 - 0.3584918 38 0.002459261 0.2706266 0.4644770 71 0 - 0.3623231 42 0.002447617 0.2744987 0.4678544 6 0 + P time var lower upper n.risk n.event + 0.057143 6 0.0015394 0.014605 0.20968 35 2 + 0.333246 13 0.0025280 0.245337 0.44216 90 4 + 0.350702 21 0.0024827 0.262769 0.45762 93 0 + 0.358492 34 0.0024593 0.270627 0.46448 89 0 + 0.358492 39 0.0024593 0.270627 0.46448 59 0 + 0.362323 42 0.0024476 0.274499 0.46785 6 0 > > ### test with group as a character vector @@ -314,77 +315,77 @@ Covariate: ttt ttt = control - time P se(P) n.event -CIF ETOP 43 0.04015931 0.009257784 20 -CIF life birth 43 0.79905931 0.022186468 924 -CIF spontaneous abortion 43 0.16078139 0.021326113 69 + time P se(P) n.event +CIF ETOP 43 0.040159 0.0092578 20 +CIF life birth 43 0.799059 0.0221865 924 +CIF spontaneous abortion 43 0.160781 0.0213261 69 ttt = exposed - time P se(P) n.event -CIF ETOP 42 0.2851118 0.04249308 38 -CIF life birth 42 0.3525651 0.04213898 92 -CIF spontaneous abortion 42 0.3623231 0.04947340 43 + time P se(P) n.event +CIF ETOP 42 0.28511 0.042493 38 +CIF life birth 42 0.35257 0.042139 92 +CIF spontaneous abortion 42 0.36232 0.049473 43 > > summary(netm.ttt) ttt=control CIF ETOP - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.00000000 0.00000000 18 0 - 0.03895488 13 8.444048e-05 0.02448808 0.06169378 645 1 - 0.04015931 23 8.570657e-05 0.02551262 0.06293875 819 0 - 0.04015931 33 8.570657e-05 0.02551262 0.06293875 885 0 - 0.04015931 39 8.570657e-05 0.02551262 0.06293875 716 0 - 0.04015931 43 8.570657e-05 0.02551262 0.06293875 6 0 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 117 0 + 0.038955 13 8.4440e-05 0.024488 0.061694 645 1 + 0.040159 26 8.5707e-05 0.025513 0.062939 846 0 + 0.040159 36 8.5707e-05 0.025513 0.062939 876 0 + 0.040159 40 8.5707e-05 0.025513 0.062939 554 0 + 0.040159 43 8.5707e-05 0.025513 0.062939 6 0 CIF life birth - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.000000000 0.00000000 18 0 - 0.00000000 13 0.000000e+00 0.000000000 0.00000000 645 0 - 0.00000000 23 0.000000e+00 0.000000000 0.00000000 819 0 - 0.01354288 33 1.216141e-05 0.008169604 0.02241009 885 6 - 0.32201590 39 2.469805e-04 0.292313907 0.35391574 716 165 - 0.79905931 43 4.922394e-04 0.753968839 0.84061317 6 6 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 117 0 + 0.000000 13 0.0000e+00 0.000000 0.000000 645 0 + 0.000000 26 0.0000e+00 0.000000 0.000000 846 0 + 0.053197 36 4.6195e-05 0.041379 0.068268 876 25 + 0.563121 40 3.8801e-04 0.524924 0.602021 554 280 + 0.799059 43 4.9224e-04 0.753969 0.840613 6 6 CIF spontaneous abortion - P time var lower upper n.risk n.event - 0.0000000 4 0.0000000000 0.0000000 0.0000000 18 0 - 0.1504675 13 0.0004551293 0.1135970 0.1979013 645 1 - 0.1570366 23 0.0004553237 0.1199469 0.2041947 819 0 - 0.1599039 33 0.0004549788 0.1227389 0.2069247 885 0 - 0.1607814 39 0.0004548031 0.1235965 0.2077571 716 0 - 0.1607814 43 0.0004548031 0.1235965 0.2077571 6 0 + P time var lower upper n.risk n.event + 0.034188 6 0.00028222 0.01297 0.088523 117 4 + 0.150468 13 0.00045513 0.11360 0.197901 645 1 + 0.159904 26 0.00045498 0.12274 0.206925 846 1 + 0.160781 36 0.00045480 0.12360 0.207757 876 1 + 0.160781 40 0.00045480 0.12360 0.207757 554 0 + 0.160781 43 0.00045480 0.12360 0.207757 6 0 ttt=exposed CIF ETOP - P time var lower upper n.risk n.event - 0.0000000 4 0.000000000 0.0000000 0.0000000 8 0 - 0.2604775 12 0.001785362 0.1879526 0.3542503 94 5 - 0.2811533 21 0.001802770 0.2074197 0.3742279 93 1 - 0.2851118 32 0.001805662 0.2111650 0.3780568 90 0 - 0.2851118 38 0.001805662 0.2111650 0.3780568 71 0 - 0.2851118 42 0.001805662 0.2111650 0.3780568 6 0 + P time var lower upper n.risk n.event + 0.00000 6 0.0000000 0.00000 0.00000 35 0 + 0.26048 13 0.0017854 0.18795 0.35425 90 0 + 0.28115 21 0.0018028 0.20742 0.37423 93 1 + 0.28511 34 0.0018057 0.21116 0.37806 89 0 + 0.28511 39 0.0018057 0.21116 0.37806 59 0 + 0.28511 42 0.0018057 0.21116 0.37806 6 0 CIF life birth - P time var lower upper n.risk n.event - 0.00000000 4 0.000000e+00 0.000000000 0.00000000 8 0 - 0.00000000 12 0.000000e+00 0.000000000 0.00000000 94 0 - 0.00000000 21 0.000000e+00 0.000000000 0.00000000 93 0 - 0.01541036 32 6.016217e-05 0.005730041 0.04110307 90 1 - 0.13034947 38 5.576254e-04 0.090999609 0.18489993 71 12 - 0.35256510 42 1.775693e-03 0.276882073 0.44177471 6 6 + P time var lower upper n.risk n.event + 0.000000 6 0.0000e+00 0.000000 0.000000 35 0 + 0.000000 13 0.0000e+00 0.000000 0.000000 90 0 + 0.000000 21 0.0000e+00 0.000000 0.000000 93 0 + 0.023073 34 9.0514e-05 0.010252 0.051504 89 2 + 0.180156 39 8.0126e-04 0.131765 0.243663 59 13 + 0.352565 42 1.7757e-03 0.276882 0.441775 6 6 CIF spontaneous abortion - P time var lower upper n.risk n.event - 0.0000000 4 0.000000000 0.0000000 0.0000000 8 0 - 0.3143493 12 0.002571501 0.2266494 0.4254211 94 1 - 0.3507019 21 0.002482739 0.2627692 0.4576195 93 0 - 0.3584918 32 0.002459261 0.2706266 0.4644770 90 0 - 0.3584918 38 0.002459261 0.2706266 0.4644770 71 0 - 0.3623231 42 0.002447617 0.2744987 0.4678544 6 0 + P time var lower upper n.risk n.event + 0.057143 6 0.0015394 0.014605 0.20968 35 2 + 0.333246 13 0.0025280 0.245337 0.44216 90 4 + 0.350702 21 0.0024827 0.262769 0.45762 93 0 + 0.358492 34 0.0024593 0.270627 0.46448 89 0 + 0.358492 39 0.0024593 0.270627 0.46448 59 0 + 0.362323 42 0.0024476 0.274499 0.46785 6 0 > > @@ -427,9 +428,9 @@ CIF spontaneous abortion > test Call: etmCIF(formula = Surv(time, to != 0) ~ 1, data = dat.s, etype = to) - time P se(P) n.event -CIF 1 4.929943 0.80910809 0.07968014 45 -CIF 2 4.929943 0.09661788 0.03290520 8 + time P se(P) n.event +CIF 1 4.9088 0.809108 0.079680 45 +CIF 2 4.9088 0.096618 0.032905 8 > > test.c Call: etmCIF(formula = Surv(time, to != 0) ~ cov, data = dat.s, etype = to) @@ -439,78 +440,83 @@ Covariate: cov cov = 0 - time P se(P) n.event -CIF 1 2.920944 0.7024648 0.10579670 19 -CIF 2 2.920944 0.1114404 0.05338408 4 + time P se(P) n.event +CIF 1 2.1708 0.70246 0.105797 19 +CIF 2 2.1708 0.11144 0.053384 4 cov = 1 - time P se(P) n.event -CIF 1 4.929943 0.80787111 0.09405073 26 -CIF 2 4.929943 0.08436022 0.04076920 4 + time P se(P) n.event +CIF 1 4.9088 0.80787 0.094051 26 +CIF 2 4.9088 0.08436 0.040769 4 > > summary(test) CIF 1 - P time var lower upper n.risk n.event - 0.0100000 0.009209855 0.000099000 0.001414712 0.0688628 100 1 - 0.1142996 0.360023778 0.001054230 0.064945430 0.1969931 76 0 - 0.2479372 0.784047742 0.002149357 0.170109947 0.3530034 51 0 - 0.4405912 1.555114392 0.003517175 0.333817035 0.5642480 26 1 - 0.5734230 2.268295292 0.004274160 0.450541377 0.7024323 11 0 - 0.8091081 4.929943217 0.006348924 0.635954424 0.9337329 1 0 + P time var lower upper n.risk n.event + 0.01000 0.0092099 0.0000990 0.0014147 0.068863 100 1 + 0.11430 0.2663096 0.0010542 0.0649454 0.196993 81 1 + 0.23451 0.7303091 0.0020436 0.1591107 0.337736 54 1 + 0.40425 1.4299939 0.0032996 0.3020445 0.525741 29 1 + 0.54593 2.0647206 0.0040836 0.4269008 0.673605 16 1 + 0.80911 4.9087561 0.0063489 0.6359544 0.933733 2 1 CIF 2 - P time var lower upper n.risk n.event - 0.00000000 0.009209855 0.0000000000 0.00000000 0.0000000 100 0 - 0.04246723 0.360023778 0.0004318927 0.01615074 0.1092171 76 0 - 0.06702937 0.784047742 0.0007036620 0.03059797 0.1435033 51 0 - 0.09661788 1.555114392 0.0010827519 0.04908158 0.1854738 26 0 - 0.09661788 2.268295292 0.0010827519 0.04908158 0.1854738 11 0 - 0.09661788 4.929943217 0.0010827519 0.04908158 0.1854738 1 0 + P time var lower upper n.risk n.event + 0.000000 0.0092099 0.00000000 0.000000 0.000000 100 0 + 0.031657 0.2663096 0.00032353 0.010320 0.094942 81 0 + 0.067029 0.7303091 0.00070366 0.030598 0.143503 54 0 + 0.096618 1.4299939 0.00108275 0.049082 0.185474 29 0 + 0.096618 2.0647206 0.00108275 0.049082 0.185474 16 0 + 0.096618 4.9087561 0.00108275 0.049082 0.185474 2 0 > summary(test.c) cov=0 CIF 1 - P time var lower upper n.risk n.event - 0.02222222 0.009209855 0.0004828532 0.00316047 0.1474667 45 1 - 0.09222222 0.406113230 0.0019360322 0.03559707 0.2276215 34 0 - 0.22668442 0.784047742 0.0045095420 0.12417599 0.3925031 23 0 - 0.42066416 1.478827203 0.0082446289 0.26725155 0.6164448 12 1 - 0.60941744 1.939093010 0.0095747480 0.42743893 0.7950394 6 1 - 0.70246483 2.920943647 0.0111929419 0.49448899 0.8839905 1 0 + P time var lower upper n.risk n.event + 0.022222 0.0092099 0.00048285 0.0031605 0.14747 45 1 + 0.092222 0.2982439 0.00193603 0.0355971 0.22762 36 0 + 0.226684 0.7021938 0.00450954 0.1241760 0.39250 24 1 + 0.378128 1.4299939 0.00760870 0.2337884 0.57145 13 1 + 0.505736 1.6148774 0.00895330 0.3388425 0.69885 10 1 + 0.702465 2.1708375 0.01119294 0.4944890 0.88399 3 1 CIF 2 - P time var lower upper n.risk n.event - 0.00000000 0.009209855 0.000000000 0.00000000 0.0000000 45 0 - 0.04844136 0.406113230 0.001116811 0.01233703 0.1801316 34 0 - 0.07641078 0.784047742 0.001810437 0.02520184 0.2192780 23 0 - 0.11144039 1.478827203 0.002849860 0.04267633 0.2739153 12 0 - 0.11144039 1.939093010 0.002849860 0.04267633 0.2739153 6 0 - 0.11144039 2.920943647 0.002849860 0.04267633 0.2739153 1 0 + P time var lower upper n.risk n.event + 0.000000 0.0092099 0.0000000 0.000000 0.00000 45 0 + 0.048441 0.2982439 0.0011168 0.012337 0.18013 36 1 + 0.076411 0.7021938 0.0018104 0.025202 0.21928 24 0 + 0.111440 1.4299939 0.0028499 0.042676 0.27392 13 0 + 0.111440 1.6148774 0.0028499 0.042676 0.27392 10 0 + 0.111440 2.1708375 0.0028499 0.042676 0.27392 3 0 cov=1 CIF 1 - P time var lower upper n.risk n.event - 0.01818182 0.06669232 0.000324568 0.002581315 0.1221376 55 1 - 0.13171422 0.36002378 0.002156700 0.065024199 0.2567179 42 0 - 0.26514875 0.80139542 0.004072829 0.162479119 0.4145201 28 0 - 0.46217162 1.55511439 0.006255707 0.322729736 0.6273534 15 1 - 0.59233377 2.48978047 0.007759845 0.428622952 0.7627259 7 0 - 0.80787111 4.92994322 0.008845539 0.602318537 0.9477134 1 0 + P time var lower upper n.risk n.event + 0.018182 0.066692 0.00032457 0.0025813 0.12214 55 1 + 0.112392 0.263808 0.00187215 0.0520925 0.23333 45 1 + 0.241023 0.730309 0.00374499 0.1440057 0.38685 31 1 + 0.401201 1.066913 0.00570788 0.2714008 0.56421 19 1 + 0.592334 2.366275 0.00775985 0.4286230 0.76273 8 1 + 0.807871 4.908756 0.00884554 0.6023185 0.94771 2 1 CIF 2 - P time var lower upper n.risk n.event - 0.00000000 0.06669232 0.0000000000 0.000000000 0.0000000 55 0 - 0.03743357 0.36002378 0.0006745784 0.009493953 0.1415172 42 0 - 0.05934134 0.80139542 0.0011129497 0.019446521 0.1735097 28 0 - 0.08436022 1.55511439 0.0016621276 0.032211300 0.2111908 15 0 - 0.08436022 2.48978047 0.0016621276 0.032211300 0.2111908 7 0 - 0.08436022 4.92994322 0.0016621276 0.032211300 0.2111908 1 0 + P time var lower upper n.risk n.event + 0.000000 0.066692 0.00000000 0.000000 0.00000 55 0 + 0.037434 0.263808 0.00067458 0.009494 0.14152 45 0 + 0.059341 0.730309 0.00111295 0.019447 0.17351 31 0 + 0.084360 1.066913 0.00166213 0.032211 0.21119 19 0 + 0.084360 2.366275 0.00166213 0.032211 0.21119 8 0 + 0.084360 4.908756 0.00166213 0.032211 0.21119 2 0 > +> options(old) +> +> proc.time() + user system elapsed + 1.242 0.103 1.214 diff -pruN 0.6-2.1-1/tests/tests.etm.R 1.0.4-2/tests/tests.etm.R --- 0.6-2.1-1/tests/tests.etm.R 2014-12-08 21:37:16.000000000 +0000 +++ 1.0.4-2/tests/tests.etm.R 2018-07-04 19:57:14.000000000 +0000 @@ -1,5 +1,8 @@ require(etm) +## Print with a bit less precision to avoid lots of notes in the comparison +old <- options(digits = 4) + ### Simple test time <- id <- 1:10 @@ -18,6 +21,31 @@ etm1$cov["0 0", "0 0", ] all.equal(etm1$cov["0 0", "0 0",], trcov(etm1, "0 0")) +### A simple test from AHR's author, where the first time is censored +if (!require(survival)) { + stop("This test requires the survival package") +} + +data <- data.frame(id=1:10, time=1:10, from=0, to=1, status=TRUE) + +tra <- matrix(FALSE, nrow=2, ncol=2) +tra[1, 2] <- TRUE + +data$to[1] <- "cens" +data$status[1] <- FALSE + +fit.km <- survfit(Surv(time, status) ~ 1, data=data) +fit.etm <- etm(data, c("0","1"), tra, "cens", s=0, t="last", covariance=FALSE) + +all.equal(fit.km$surv[data$status], fit.etm$est[1,1,], check.attributes = FALSE) + +data$to[2] <- "cens" +data$status[2] <- FALSE + +fit.km <- survfit(Surv(time, status) ~ 1, data=data) +fit.etm <- etm(data, c("0","1"), tra, "cens", s=0, t="last", covariance=FALSE) + +all.equal(fit.km$surv[data$status], fit.etm$est[1,1,], check.attributes = FALSE) ### a bit more complicated @@ -80,8 +108,8 @@ prob.sir <- etm(sir.cont, c("0", "1", "2 prob.sir summ.sir <- summary(prob.sir) -all.equal(summ.sir[[1]]$P, as.vector(trprob(prob.sir, "0 1"))) -summ.sir[[2]] +all.equal(summ.sir[['0 1']]$P, as.vector(trprob(prob.sir, "0 1"))) +summ.sir[[3]] ## gonna play a bit with the state names dd <- sir.cont @@ -218,3 +246,56 @@ ref$from <- factor(as.character(ref$from ref$to <- factor(as.character(ref$to), levels = c("0", "1", "2", "cens")) all.equal(ref, newdat) + + +###################################### +### Test the stratified calls +###################################### + +if (!require(kmi, quietly = TRUE)) + stop("The following tests require the 'kmi' package") + +library(etm) + +data(icu.pneu) +my.icu.pneu <- icu.pneu + +my.icu.pneu <- my.icu.pneu[order(my.icu.pneu$id, my.icu.pneu$start), ] +masque <- diff(my.icu.pneu$id) + +my.icu.pneu$from <- 0 +my.icu.pneu$from[c(1, masque) == 0] <- 1 + +my.icu.pneu$to2 <- my.icu.pneu$event +my.icu.pneu$to2[my.icu.pneu$status == 0] <- "cens" +my.icu.pneu$to2[c(masque, 1) == 0] <- 1 + + +my.icu.pneu$to <- ifelse(my.icu.pneu$to2 %in% c(2, 3), 2, + my.icu.pneu$to2) + +my.icu.pneu <- my.icu.pneu[, c("id", "start", "stop", "from", "to", + "to2", "age", "sex")] +names(my.icu.pneu)[c(2, 3)] <- c("entry", "exit") + +bouh_strat <- etm(my.icu.pneu, c("0", "1", "2"), tra_ill(), "cens", 0, strata = "sex") + +bouh_female <- etm(my.icu.pneu[my.icu.pneu$sex == "F", ], + c("0", "1", "2"), tra_ill(), "cens", 0) + +all(bouh_strat[[1]]$est == bouh_female$est) + +## Test the summary +the_summary <- summary(bouh_strat) +the_summary + +## Test trprob +all(trprob(bouh_strat, "0 1")[[1]] == trprob(bouh_female, "0 1")) +all(trprob(bouh_strat, "0 1", c(0, 5, 10, 15))[[1]] == trprob(bouh_female, "0 1", c(0, 5, 10, 15))) + +## Test trcov +all(trcov(bouh_strat, "0 1")[[1]] == trcov(bouh_female, "0 1")) +all(trcov(bouh_strat, c("0 1", "0 2"))[[1]] == trcov(bouh_female, c("0 1", "0 2"))) +all(trcov(bouh_strat, "0 1", c(0, 5, 10, 15))[[1]] == trcov(bouh_female, "0 1", c(0, 5, 10, 15))) + +options(old) diff -pruN 0.6-2.1-1/tests/tests.etm.Rout.save 1.0.4-2/tests/tests.etm.Rout.save --- 0.6-2.1-1/tests/tests.etm.Rout.save 2014-12-08 22:32:10.000000000 +0000 +++ 1.0.4-2/tests/tests.etm.Rout.save 2018-07-04 20:11:16.000000000 +0000 @@ -1,7 +1,7 @@ -R version 3.1.2 (2014-10-31) -- "Pumpkin Helmet" -Copyright (C) 2014 The R Foundation for Statistical Computing -Platform: x86_64-suse-linux-gnu (64-bit) +R version 3.5.1 (2018-07-02) -- "Feather Spray" +Copyright (C) 2018 The R Foundation for Statistical Computing +Platform: x86_64-apple-darwin17.6.0 (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. @@ -19,8 +19,9 @@ Type 'q()' to quit R. > require(etm) Loading required package: etm -Loading required package: survival -Loading required package: splines +> +> ## Print with a bit less precision to avoid lots of notes in the comparison +> old <- options(digits = 4) > > ### Simple test > @@ -44,6 +45,34 @@ Loading required package: splines > all.equal(etm1$cov["0 0", "0 0",], trcov(etm1, "0 0")) [1] TRUE > +> ### A simple test from AHR's author, where the first time is censored +> if (!require(survival)) { ++ stop("This test requires the survival package") ++ } +Loading required package: survival +> +> data <- data.frame(id=1:10, time=1:10, from=0, to=1, status=TRUE) +> +> tra <- matrix(FALSE, nrow=2, ncol=2) +> tra[1, 2] <- TRUE +> +> data$to[1] <- "cens" +> data$status[1] <- FALSE +> +> fit.km <- survfit(Surv(time, status) ~ 1, data=data) +> fit.etm <- etm(data, c("0","1"), tra, "cens", s=0, t="last", covariance=FALSE) +> +> all.equal(fit.km$surv[data$status], fit.etm$est[1,1,], check.attributes = FALSE) +[1] TRUE +> +> data$to[2] <- "cens" +> data$status[2] <- FALSE +> +> fit.km <- survfit(Surv(time, status) ~ 1, data=data) +> fit.etm <- etm(data, c("0","1"), tra, "cens", s=0, t="last", covariance=FALSE) +> +> all.equal(fit.km$surv[data$status], fit.etm$est[1,1,], check.attributes = FALSE) +[1] TRUE > > ### a bit more complicated > @@ -126,118 +155,103 @@ Estimate of P(1, 183) 1 0 0 1 2 0 0 1 -Estimate of cov(P(1, 183)) - 0 0 1 0 2 0 0 1 1 1 2 1 0 2 1 2 2 2 -0 0 0 0 0 0 0 0 0.000000e+00 0.000000e+00 0 -1 0 0 0 0 0 0 0 0.000000e+00 0.000000e+00 0 -2 0 0 0 0 0 0 0 0.000000e+00 0.000000e+00 0 -0 1 0 0 0 0 0 0 0.000000e+00 0.000000e+00 0 -1 1 0 0 0 0 0 0 0.000000e+00 0.000000e+00 0 -2 1 0 0 0 0 0 0 0.000000e+00 0.000000e+00 0 -0 2 0 0 0 0 0 0 -2.864030e-20 -1.126554e-19 0 -1 2 0 0 0 0 0 0 -4.785736e-20 2.710505e-19 0 -2 2 0 0 0 0 0 0 0.000000e+00 0.000000e+00 0 > > summ.sir <- summary(prob.sir) -Warning messages: -1: In sqrt(var) : NaNs produced -2: In sqrt(var) : NaNs produced -> all.equal(summ.sir[[1]]$P, as.vector(trprob(prob.sir, "0 1"))) -[1] TRUE -> summ.sir[[2]] - P time var lower upper n.risk n.event -1.5 0.0000000 1.5 0.000000e+00 0.00000000 0.0000000 394 0 -2 0.1186869 2.0 2.641422e-04 0.08683265 0.1505411 396 47 -2.5 0.1186869 2.5 2.641422e-04 0.08683265 0.1505411 364 0 -3 0.2453993 3.0 4.465256e-04 0.20398301 0.2868156 365 54 -3.5 0.2453993 3.5 4.465256e-04 0.20398301 0.2868156 328 0 -4 0.3806244 4.0 5.416492e-04 0.33500942 0.4262393 331 62 -4.5 0.3806244 4.5 5.416492e-04 0.33500942 0.4262393 280 0 -5 0.4792121 5.0 5.480328e-04 0.43332915 0.5250951 283 48 -5.5 0.4792121 5.5 5.480328e-04 0.43332915 0.5250951 248 0 -6 0.5692649 6.0 5.141238e-04 0.52482414 0.6137058 249 47 -7 0.6349924 7.0 4.665144e-04 0.59265929 0.6773256 212 36 -8 0.6794916 8.0 4.202391e-04 0.63931284 0.7196703 195 27 -8.5 0.6794916 8.5 4.202391e-04 0.63931284 0.7196703 172 0 -9 0.7324895 9.0 3.579860e-04 0.69540594 0.7695730 173 34 -10 0.7646506 10.0 3.140867e-04 0.72991512 0.7993860 148 21 -10.5 0.7646506 10.5 3.140867e-04 0.72991512 0.7993860 135 0 -11 0.7894789 11.0 2.789769e-04 0.75674237 0.8222154 136 18 -12 0.8137852 12.0 2.419720e-04 0.78329710 0.8442733 129 18 -12.5 0.8137852 12.5 2.419720e-04 0.78329710 0.8442733 117 0 -13 0.8293991 13.0 2.181963e-04 0.80044760 0.8583507 118 13 -14 0.8451773 14.0 1.938437e-04 0.81788913 0.8724654 115 14 -15 0.8624687 15.0 1.670243e-04 0.83713851 0.8877988 106 15 -16 0.8722513 16.0 1.522153e-04 0.84807011 0.8964324 93 9 -17 0.8851601 17.0 1.329865e-04 0.86255784 0.9077624 86 12 -17.5 0.8851601 17.5 1.329865e-04 0.86255784 0.9077624 77 0 -18 0.8960254 18.0 1.167891e-04 0.87484428 0.9172066 76 9 -19 0.9028854 19.0 1.069942e-04 0.88261196 0.9231589 71 7 -20 0.9125267 20.0 9.367135e-05 0.89355740 0.9314960 64 10 -21 0.9161439 21.0 8.878103e-05 0.89767636 0.9346114 57 4 -22 0.9225643 22.0 7.995614e-05 0.90503865 0.9400899 55 6 -23 0.9260521 23.0 7.536948e-05 0.90903660 0.9430677 51 4 -23.5 0.9260521 23.5 7.536948e-05 0.90903660 0.9430677 49 0 -24 0.9353639 24.0 6.292082e-05 0.91981690 0.9509108 50 9 -25 0.9385430 25.0 5.877878e-05 0.92351645 0.9535695 42 3 -26 0.9429383 26.0 5.325890e-05 0.92863472 0.9572418 39 5 -27 0.9476771 27.0 4.748795e-05 0.93417068 0.9611835 35 6 -27.5 0.9476771 27.5 4.748795e-05 0.93417068 0.9611835 29 0 -28 0.9531288 28.0 4.092631e-05 0.94059022 0.9656674 30 5 -29 0.9567220 29.0 3.667615e-05 0.94485230 0.9685917 31 4 -30 0.9591876 30.0 3.383912e-05 0.94778617 0.9705889 28 3 -30.5 0.9591876 30.5 3.383912e-05 0.94778617 0.9705889 29 0 -31 0.9642349 31.0 2.820676e-05 0.95382549 0.9746442 30 6 -32 0.9648667 32.0 2.752066e-05 0.95458472 0.9751487 25 1 -33 0.9669455 33.0 2.533123e-05 0.95708094 0.9768100 24 2 -34 0.9685356 34.0 2.367984e-05 0.95899806 0.9780732 26 2 -35 0.9696628 35.0 2.251767e-05 0.96036219 0.9789633 28 2 -36 0.9702263 36.0 2.194423e-05 0.96104495 0.9794077 26 1 -37 0.9717546 37.0 2.043249e-05 0.96289513 0.9806141 26 2 -38 0.9739393 38.0 1.831026e-05 0.96555250 0.9823261 25 4 -38.5 0.9739393 38.5 1.831026e-05 0.96555250 0.9823261 21 0 -39 0.9759610 39.0 1.643312e-05 0.96801570 0.9839062 23 3 -40 0.9769163 40.0 1.557773e-05 0.96918064 0.9846521 19 1 -41 0.9774305 41.0 1.511599e-05 0.96981026 0.9850507 22 1 -42 0.9778509 42.0 1.475784e-05 0.97032155 0.9853803 22 0 -43 0.9798010 43.0 1.307925e-05 0.97271272 0.9868892 22 3 -44 0.9803023 44.0 1.265491e-05 0.97333000 0.9872746 21 1 -45 0.9816513 45.0 1.156647e-05 0.97498560 0.9883171 19 1 -46 0.9821527 46.0 1.115820e-05 0.97560565 0.9886997 17 1 -47 0.9831389 47.0 1.037038e-05 0.97682722 0.9894506 18 2 -48 0.9836281 48.0 9.986572e-06 0.97743435 0.9898219 17 1 -49 0.9840553 49.0 9.669176e-06 0.97796078 0.9901499 17 0 -50 0.9845409 50.0 9.296786e-06 0.97856487 0.9905170 17 1 -50.5 0.9845409 50.5 9.296786e-06 0.97856487 0.9905170 16 0 -51 0.9859918 51.0 8.213748e-06 0.98037462 0.9916090 17 3 -52 0.9869591 52.0 7.512700e-06 0.98158694 0.9923312 14 2 -53 0.9878950 53.0 6.874544e-06 0.98275613 0.9930339 12 1 -54 0.9888571 54.0 6.213830e-06 0.98397136 0.9937428 12 2 -55 0.9903001 55.0 5.253896e-06 0.98580762 0.9947926 10 3 -56 0.9912678 56.0 4.666932e-06 0.98703372 0.9955020 6 1 -57 0.9917489 57.0 4.363513e-06 0.98765469 0.9958430 5 1 -58 0.9922299 58.0 4.064246e-06 0.98827860 0.9961812 4 1 -59 0.9927109 59.0 3.769130e-06 0.98890578 0.9965160 3 1 -60 0.9931938 60.0 3.488235e-06 0.98953323 0.9968544 3 1 -62 0.9936805 62.0 3.229764e-06 0.99015816 0.9972029 2 0 -63 0.9941634 63.0 2.955869e-06 0.99079373 0.9975331 2 1 -68 0.9941634 68.0 2.955869e-06 0.99079373 0.9975331 1 0 -70 0.9946482 70.0 2.693997e-06 0.99143126 0.9978652 2 1 -78 0.9951349 78.0 2.442281e-06 0.99207193 0.9981979 1 0 -80 0.9951349 80.0 2.442281e-06 0.99207193 0.9981979 1 0 -85 0.9965950 85.0 1.695084e-06 0.99404323 0.9991468 2 0 -89 0.9965950 89.0 1.695084e-06 0.99404323 0.9991468 2 0 -90 0.9965950 90.0 1.695084e-06 0.99404323 0.9991468 1 0 -95 0.9970816 95.0 1.448382e-06 0.99472276 0.9994403 2 0 -100 0.9975681 100.0 1.203159e-06 0.99541824 0.9997180 3 0 -101 0.9980544 101.0 9.591818e-07 0.99613482 0.9999739 3 1 -108 0.9985406 108.0 7.169274e-07 0.99688111 1.0000000 2 1 -113 0.9990272 113.0 4.763877e-07 0.99767440 1.0000000 1 0 -116 0.9990272 116.0 4.763877e-07 0.99767440 1.0000000 1 0 -124 0.9990272 124.0 4.763877e-07 0.99767440 1.0000000 2 0 -130 0.9990272 130.0 4.763877e-07 0.99767440 1.0000000 1 0 -164 0.9990272 164.0 4.763877e-07 0.99767440 1.0000000 0 0 -183 1.0000000 183.0 -2.864030e-20 NaN NaN 1 1 +> all.equal(summ.sir[['0 1']]$P, as.vector(trprob(prob.sir, "0 1"))) +[1] TRUE +> summ.sir[[3]] + P time var lower upper n.risk n.event +1.5 0.0000 1.5 0.000e+00 0.00000 0.0000 394 0 +2 0.1187 2.0 2.641e-04 0.08683 0.1505 396 47 +2.5 0.1187 2.5 2.641e-04 0.08683 0.1505 364 0 +3 0.2454 3.0 4.465e-04 0.20398 0.2868 365 54 +3.5 0.2454 3.5 4.465e-04 0.20398 0.2868 328 0 +4 0.3806 4.0 5.416e-04 0.33501 0.4262 331 62 +4.5 0.3806 4.5 5.416e-04 0.33501 0.4262 280 0 +5 0.4792 5.0 5.480e-04 0.43333 0.5251 283 48 +5.5 0.4792 5.5 5.480e-04 0.43333 0.5251 248 0 +6 0.5693 6.0 5.141e-04 0.52482 0.6137 249 47 +7 0.6350 7.0 4.665e-04 0.59266 0.6773 212 36 +8 0.6795 8.0 4.202e-04 0.63931 0.7197 195 27 +8.5 0.6795 8.5 4.202e-04 0.63931 0.7197 172 0 +9 0.7325 9.0 3.580e-04 0.69541 0.7696 173 34 +10 0.7647 10.0 3.141e-04 0.72992 0.7994 148 21 +10.5 0.7647 10.5 3.141e-04 0.72992 0.7994 135 0 +11 0.7895 11.0 2.790e-04 0.75674 0.8222 136 18 +12 0.8138 12.0 2.420e-04 0.78330 0.8443 129 18 +12.5 0.8138 12.5 2.420e-04 0.78330 0.8443 117 0 +13 0.8294 13.0 2.182e-04 0.80045 0.8584 118 13 +14 0.8452 14.0 1.938e-04 0.81789 0.8725 115 14 +15 0.8625 15.0 1.670e-04 0.83714 0.8878 106 15 +16 0.8723 16.0 1.522e-04 0.84807 0.8964 93 9 +17 0.8852 17.0 1.330e-04 0.86256 0.9078 86 12 +17.5 0.8852 17.5 1.330e-04 0.86256 0.9078 77 0 +18 0.8960 18.0 1.168e-04 0.87484 0.9172 76 9 +19 0.9029 19.0 1.070e-04 0.88261 0.9232 71 7 +20 0.9125 20.0 9.367e-05 0.89356 0.9315 64 10 +21 0.9161 21.0 8.878e-05 0.89768 0.9346 57 4 +22 0.9226 22.0 7.996e-05 0.90504 0.9401 55 6 +23 0.9261 23.0 7.537e-05 0.90904 0.9431 51 4 +23.5 0.9261 23.5 7.537e-05 0.90904 0.9431 49 0 +24 0.9354 24.0 6.292e-05 0.91982 0.9509 50 9 +25 0.9385 25.0 5.878e-05 0.92352 0.9536 42 3 +26 0.9429 26.0 5.326e-05 0.92863 0.9572 39 5 +27 0.9477 27.0 4.749e-05 0.93417 0.9612 35 6 +27.5 0.9477 27.5 4.749e-05 0.93417 0.9612 29 0 +28 0.9531 28.0 4.093e-05 0.94059 0.9657 30 5 +29 0.9567 29.0 3.668e-05 0.94485 0.9686 31 4 +30 0.9592 30.0 3.384e-05 0.94779 0.9706 28 3 +30.5 0.9592 30.5 3.384e-05 0.94779 0.9706 29 0 +31 0.9642 31.0 2.821e-05 0.95383 0.9746 30 6 +32 0.9649 32.0 2.752e-05 0.95458 0.9751 25 1 +33 0.9669 33.0 2.533e-05 0.95708 0.9768 24 2 +34 0.9685 34.0 2.368e-05 0.95900 0.9781 26 2 +35 0.9697 35.0 2.252e-05 0.96036 0.9790 28 2 +36 0.9702 36.0 2.194e-05 0.96104 0.9794 26 1 +37 0.9718 37.0 2.043e-05 0.96290 0.9806 26 2 +38 0.9739 38.0 1.831e-05 0.96555 0.9823 25 4 +38.5 0.9739 38.5 1.831e-05 0.96555 0.9823 21 0 +39 0.9760 39.0 1.643e-05 0.96802 0.9839 23 3 +40 0.9769 40.0 1.558e-05 0.96918 0.9847 19 1 +41 0.9774 41.0 1.512e-05 0.96981 0.9851 22 1 +42 0.9779 42.0 1.476e-05 0.97032 0.9854 22 0 +43 0.9798 43.0 1.308e-05 0.97271 0.9869 22 3 +44 0.9803 44.0 1.265e-05 0.97333 0.9873 21 1 +45 0.9817 45.0 1.157e-05 0.97499 0.9883 19 1 +46 0.9822 46.0 1.116e-05 0.97561 0.9887 17 1 +47 0.9831 47.0 1.037e-05 0.97683 0.9895 18 2 +48 0.9836 48.0 9.987e-06 0.97743 0.9898 17 1 +49 0.9841 49.0 9.669e-06 0.97796 0.9901 17 0 +50 0.9845 50.0 9.297e-06 0.97856 0.9905 17 1 +50.5 0.9845 50.5 9.297e-06 0.97856 0.9905 16 0 +51 0.9860 51.0 8.214e-06 0.98037 0.9916 17 3 +52 0.9870 52.0 7.513e-06 0.98159 0.9923 14 2 +53 0.9879 53.0 6.875e-06 0.98276 0.9930 12 1 +54 0.9889 54.0 6.214e-06 0.98397 0.9937 12 2 +55 0.9903 55.0 5.254e-06 0.98581 0.9948 10 3 +56 0.9913 56.0 4.667e-06 0.98703 0.9955 6 1 +57 0.9917 57.0 4.364e-06 0.98765 0.9958 5 1 +58 0.9922 58.0 4.064e-06 0.98828 0.9962 4 1 +59 0.9927 59.0 3.769e-06 0.98891 0.9965 3 1 +60 0.9932 60.0 3.488e-06 0.98953 0.9969 3 1 +62 0.9937 62.0 3.230e-06 0.99016 0.9972 2 0 +63 0.9942 63.0 2.956e-06 0.99079 0.9975 2 1 +68 0.9942 68.0 2.956e-06 0.99079 0.9975 1 0 +70 0.9946 70.0 2.694e-06 0.99143 0.9979 2 1 +78 0.9951 78.0 2.442e-06 0.99207 0.9982 1 0 +80 0.9951 80.0 2.442e-06 0.99207 0.9982 1 0 +85 0.9966 85.0 1.695e-06 0.99404 0.9991 2 0 +89 0.9966 89.0 1.695e-06 0.99404 0.9991 2 0 +90 0.9966 90.0 1.695e-06 0.99404 0.9991 1 0 +95 0.9971 95.0 1.448e-06 0.99472 0.9994 2 0 +100 0.9976 100.0 1.203e-06 0.99542 0.9997 3 0 +101 0.9981 101.0 9.592e-07 0.99613 1.0000 3 1 +108 0.9985 108.0 7.169e-07 0.99688 1.0000 2 1 +113 0.9990 113.0 4.764e-07 0.99767 1.0000 1 0 +116 0.9990 116.0 4.764e-07 0.99767 1.0000 1 0 +124 0.9990 124.0 4.764e-07 0.99767 1.0000 2 0 +164 0.9990 164.0 4.764e-07 0.99767 1.0000 0 0 +183 1.0000 183.0 1.337e-19 1.00000 1.0000 1 1 > > ## gonna play a bit with the state names > dd <- sir.cont @@ -268,9 +282,6 @@ Warning messages: [1] TRUE > > aa <- summary(test) -Warning messages: -1: In sqrt(var) : NaNs produced -2: In sqrt(var) : NaNs produced > all.equal(summ.sir[[6]], aa[[6]]) [1] TRUE > all.equal(summ.sir[[4]], aa[[4]]) @@ -302,140 +313,93 @@ Warning messages: [1] TRUE > > trprob(cif.control, "0 1") - 4 5 6 7 8 9 -0.000000000 0.000000000 0.000000000 0.007400858 0.014880870 0.026509184 - 10 11 12 13 14 15 -0.033207696 0.037694266 0.037694266 0.038954884 0.040159308 0.040159308 - 16 17 18 19 20 21 -0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 - 22 23 24 25 26 27 -0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 - 28 29 30 31 32 33 -0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 - 34 35 36 37 38 39 -0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 0.040159308 - 40 41 42 43 -0.040159308 0.040159308 0.040159308 0.040159308 + 6 7 8 9 10 11 12 13 +0.000000 0.007401 0.014881 0.026509 0.033208 0.037694 0.037694 0.038955 + 14 17 19 21 24 25 26 30 +0.040159 0.040159 0.040159 0.040159 0.040159 0.040159 0.040159 0.040159 + 31 32 33 34 35 36 37 38 +0.040159 0.040159 0.040159 0.040159 0.040159 0.040159 0.040159 0.040159 + 39 40 41 42 43 +0.040159 0.040159 0.040159 0.040159 0.040159 > trprob(cif.control, "0 2") - 4 5 6 7 8 9 -0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 - 10 11 12 13 14 15 -0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 - 16 17 18 19 20 21 -0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 - 22 23 24 25 26 27 -0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 0.000000000 - 28 29 30 31 32 33 -0.000000000 0.000000000 0.003656854 0.006371445 0.008175002 0.013542879 - 34 35 36 37 38 39 -0.023317266 0.031259966 0.053197090 0.084528525 0.179162614 0.322015902 - 40 41 42 43 -0.563120872 0.742227421 0.793892771 0.799059306 + 6 7 8 9 10 11 12 13 +0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 + 14 17 19 21 24 25 26 30 +0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.003657 + 31 32 33 34 35 36 37 38 +0.006371 0.008175 0.013543 0.023317 0.031260 0.053197 0.084529 0.179163 + 39 40 41 42 43 +0.322016 0.563121 0.742227 0.793893 0.799059 > trprob(cif.control, "0 0") - 4 5 6 7 8 9 -1.000000000 1.000000000 0.965811966 0.932508105 0.887628036 0.862433353 - 10 11 12 13 14 15 -0.838988563 0.822537807 0.813098849 0.810577612 0.806964339 0.806964339 - 16 17 18 19 20 21 -0.806964339 0.805873846 0.805873846 0.803810149 0.803810149 0.802804129 - 22 23 24 25 26 27 -0.802804129 0.802804129 0.801836895 0.800883462 0.799936791 0.799936791 - 28 29 30 31 32 33 -0.799936791 0.799936791 0.796279938 0.793565347 0.791761789 0.786393913 - 34 35 36 37 38 39 -0.776619525 0.768676825 0.745862216 0.714530781 0.619896693 0.477043404 - 40 41 42 43 -0.235938435 0.056831886 0.005166535 0.000000000 + 6 7 8 9 10 11 12 13 +0.965812 0.932508 0.887628 0.862433 0.838989 0.822538 0.813099 0.810578 + 14 17 19 21 24 25 26 30 +0.806964 0.805874 0.803810 0.802804 0.801837 0.800883 0.799937 0.796280 + 31 32 33 34 35 36 37 38 +0.793565 0.791762 0.786394 0.776620 0.768677 0.745862 0.714531 0.619897 + 39 40 41 42 43 +0.477043 0.235938 0.056832 0.005167 0.000000 > > trcov(cif.control, "0 1") - 4 5 6 7 8 9 -0.000000e+00 0.000000e+00 0.000000e+00 2.719306e-05 4.532753e-05 6.665019e-05 - 10 11 12 13 14 15 -7.698480e-05 8.304209e-05 8.304209e-05 8.444048e-05 8.570657e-05 8.570657e-05 - 16 17 18 19 20 21 -8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 - 22 23 24 25 26 27 -8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 - 28 29 30 31 32 33 -8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 - 34 35 36 37 38 39 -8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 - 40 41 42 43 -8.570657e-05 8.570657e-05 8.570657e-05 8.570657e-05 + 6 7 8 9 10 11 12 13 +0.000e+00 2.719e-05 4.533e-05 6.665e-05 7.698e-05 8.304e-05 8.304e-05 8.444e-05 + 14 17 19 21 24 25 26 30 +8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 + 31 32 33 34 35 36 37 38 +8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 + 39 40 41 42 43 +8.571e-05 8.571e-05 8.571e-05 8.571e-05 8.571e-05 > trcov(cif.control, "0 2") - 4 5 6 7 8 9 -0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 - 10 11 12 13 14 15 -0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 - 16 17 18 19 20 21 -0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 - 22 23 24 25 26 27 -0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 - 28 29 30 31 32 33 -0.000000e+00 0.000000e+00 3.338155e-06 5.784419e-06 7.401205e-06 1.216141e-05 - 34 35 36 37 38 39 -2.071916e-05 2.757764e-05 4.619460e-05 7.202415e-05 1.460900e-04 2.469805e-04 - 40 41 42 43 -3.880102e-04 4.701879e-04 4.903148e-04 4.922394e-04 + 6 7 8 9 10 11 12 13 +0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 + 14 17 19 21 24 25 26 30 +0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 3.338e-06 + 31 32 33 34 35 36 37 38 +5.784e-06 7.401e-06 1.216e-05 2.072e-05 2.758e-05 4.619e-05 7.202e-05 1.461e-04 + 39 40 41 42 43 +2.470e-04 3.880e-04 4.702e-04 4.903e-04 4.922e-04 > trcov(cif.control, "0 0") - 4 5 6 7 8 9 -0.000000e+00 0.000000e+00 2.822155e-04 3.820769e-04 4.527000e-04 4.748082e-04 - 10 11 12 13 14 15 -4.875383e-04 4.927267e-04 4.940647e-04 4.941740e-04 4.941106e-04 4.941106e-04 - 16 17 18 19 20 21 -4.941106e-04 4.939636e-04 4.939636e-04 4.935609e-04 4.935609e-04 4.933371e-04 - 22 23 24 25 26 27 -4.933371e-04 4.933371e-04 4.930834e-04 4.928195e-04 4.925502e-04 4.925502e-04 - 28 29 30 31 32 33 -4.925502e-04 4.925502e-04 4.913851e-04 4.904884e-04 4.898842e-04 4.880340e-04 - 34 35 36 37 38 39 -4.845548e-04 4.816321e-04 4.728916e-04 4.601194e-04 4.175917e-04 3.424805e-04 - 40 41 42 43 -1.864578e-04 4.796800e-05 4.440837e-06 0.000000e+00 + 6 7 8 9 10 11 12 13 +2.822e-04 3.821e-04 4.527e-04 4.748e-04 4.875e-04 4.927e-04 4.941e-04 4.942e-04 + 14 17 19 21 24 25 26 30 +4.941e-04 4.940e-04 4.936e-04 4.933e-04 4.931e-04 4.928e-04 4.926e-04 4.914e-04 + 31 32 33 34 35 36 37 38 +4.905e-04 4.899e-04 4.880e-04 4.846e-04 4.816e-04 4.729e-04 4.601e-04 4.176e-04 + 39 40 41 42 43 +3.425e-04 1.865e-04 4.797e-05 4.441e-06 0.000e+00 > > aa <- summary(cif.control) > aa$"0 1" - P time var lower upper n.risk n.event -4 0.000000000 4 0.000000e+00 0.00000000 0.00000000 18 0 -5 0.000000000 5 0.000000e+00 0.00000000 0.00000000 18 0 -6 0.000000000 6 0.000000e+00 0.00000000 0.00000000 117 0 -7 0.007400858 7 2.719306e-05 0.00000000 0.01762148 261 2 -8 0.014880870 8 4.532753e-05 0.00168527 0.02807647 374 3 -9 0.026509184 9 6.665019e-05 0.01050812 0.04251025 458 6 -10 0.033207696 10 7.698480e-05 0.01601078 0.05040461 515 4 -11 0.037694266 11 8.304209e-05 0.01983362 0.05555491 561 3 -12 0.037694266 12 8.304209e-05 0.01983362 0.05555491 610 0 -13 0.038954884 13 8.444048e-05 0.02094448 0.05696529 645 1 -14 0.040159308 14 8.570657e-05 0.02201438 0.05830423 673 1 -15 0.040159308 15 8.570657e-05 0.02201438 0.05830423 696 0 -16 0.040159308 16 8.570657e-05 0.02201438 0.05830423 714 0 -17 0.040159308 17 8.570657e-05 0.02201438 0.05830423 740 0 -18 0.040159308 18 8.570657e-05 0.02201438 0.05830423 759 0 -19 0.040159308 19 8.570657e-05 0.02201438 0.05830423 781 0 -20 0.040159308 20 8.570657e-05 0.02201438 0.05830423 786 0 -21 0.040159308 21 8.570657e-05 0.02201438 0.05830423 799 0 -22 0.040159308 22 8.570657e-05 0.02201438 0.05830423 810 0 -23 0.040159308 23 8.570657e-05 0.02201438 0.05830423 819 0 -24 0.040159308 24 8.570657e-05 0.02201438 0.05830423 830 0 -25 0.040159308 25 8.570657e-05 0.02201438 0.05830423 841 0 -26 0.040159308 26 8.570657e-05 0.02201438 0.05830423 846 0 -27 0.040159308 27 8.570657e-05 0.02201438 0.05830423 853 0 -28 0.040159308 28 8.570657e-05 0.02201438 0.05830423 860 0 -29 0.040159308 29 8.570657e-05 0.02201438 0.05830423 870 0 -30 0.040159308 30 8.570657e-05 0.02201438 0.05830423 875 0 -31 0.040159308 31 8.570657e-05 0.02201438 0.05830423 880 0 -32 0.040159308 32 8.570657e-05 0.02201438 0.05830423 880 0 -33 0.040159308 33 8.570657e-05 0.02201438 0.05830423 885 0 -34 0.040159308 34 8.570657e-05 0.02201438 0.05830423 885 0 -35 0.040159308 35 8.570657e-05 0.02201438 0.05830423 880 0 -36 0.040159308 36 8.570657e-05 0.02201438 0.05830423 876 0 -37 0.040159308 37 8.570657e-05 0.02201438 0.05830423 857 0 -38 0.040159308 38 8.570657e-05 0.02201438 0.05830423 823 0 -39 0.040159308 39 8.570657e-05 0.02201438 0.05830423 716 0 -40 0.040159308 40 8.570657e-05 0.02201438 0.05830423 554 0 -41 0.040159308 41 8.570657e-05 0.02201438 0.05830423 274 0 -42 0.040159308 42 8.570657e-05 0.02201438 0.05830423 66 0 -43 0.040159308 43 8.570657e-05 0.02201438 0.05830423 6 0 + P time var lower upper n.risk n.event +6 0.000000 6 0.000e+00 0.000000 0.00000 117 0 +7 0.007401 7 2.719e-05 0.000000 0.01762 261 2 +8 0.014881 8 4.533e-05 0.001685 0.02808 374 3 +9 0.026509 9 6.665e-05 0.010508 0.04251 458 6 +10 0.033208 10 7.698e-05 0.016011 0.05040 515 4 +11 0.037694 11 8.304e-05 0.019834 0.05555 561 3 +12 0.037694 12 8.304e-05 0.019834 0.05555 610 0 +13 0.038955 13 8.444e-05 0.020944 0.05697 645 1 +14 0.040159 14 8.571e-05 0.022014 0.05830 673 1 +17 0.040159 17 8.571e-05 0.022014 0.05830 740 0 +19 0.040159 19 8.571e-05 0.022014 0.05830 781 0 +21 0.040159 21 8.571e-05 0.022014 0.05830 799 0 +24 0.040159 24 8.571e-05 0.022014 0.05830 830 0 +25 0.040159 25 8.571e-05 0.022014 0.05830 841 0 +26 0.040159 26 8.571e-05 0.022014 0.05830 846 0 +30 0.040159 30 8.571e-05 0.022014 0.05830 875 0 +31 0.040159 31 8.571e-05 0.022014 0.05830 880 0 +32 0.040159 32 8.571e-05 0.022014 0.05830 880 0 +33 0.040159 33 8.571e-05 0.022014 0.05830 885 0 +34 0.040159 34 8.571e-05 0.022014 0.05830 885 0 +35 0.040159 35 8.571e-05 0.022014 0.05830 880 0 +36 0.040159 36 8.571e-05 0.022014 0.05830 876 0 +37 0.040159 37 8.571e-05 0.022014 0.05830 857 0 +38 0.040159 38 8.571e-05 0.022014 0.05830 823 0 +39 0.040159 39 8.571e-05 0.022014 0.05830 716 0 +40 0.040159 40 8.571e-05 0.022014 0.05830 554 0 +41 0.040159 41 8.571e-05 0.022014 0.05830 274 0 +42 0.040159 42 8.571e-05 0.022014 0.05830 66 0 +43 0.040159 43 8.571e-05 0.022014 0.05830 6 0 > all.equal(aa$"0 1"$P, as.vector(trprob(cif.control, "0 1"))) [1] TRUE > @@ -465,110 +429,75 @@ Possible transitions: 1 3 Estimate of P(0, 82) - 0 1 2 3 -0 0 0 0.7473545 0.2526455 -1 0 0 0.7072985 0.2927015 -2 0 0 1.0000000 0.0000000 -3 0 0 0.0000000 1.0000000 - -Estimate of cov(P(0, 82)) - 0 0 1 0 2 0 3 0 0 1 1 1 2 1 3 1 0 2 1 2 2 2 3 2 -0 0 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -1 0 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -2 0 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -3 0 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -0 1 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -1 1 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -2 1 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -3 1 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -0 2 0 0 0 0 0 0 0 0 0.0002497563 0.0002738457 0 0 -1 2 0 0 0 0 0 0 0 0 0.0002738457 0.0019836077 0 0 -2 2 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -3 2 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -0 3 0 0 0 0 0 0 0 0 -0.0002497563 -0.0002738457 0 0 -1 3 0 0 0 0 0 0 0 0 -0.0002738457 -0.0019836077 0 0 -2 3 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 -3 3 0 0 0 0 0 0 0 0 0.0000000000 0.0000000000 0 0 - 0 3 1 3 2 3 3 3 -0 0 0.0000000000 0.0000000000 0 0 -1 0 0.0000000000 0.0000000000 0 0 -2 0 0.0000000000 0.0000000000 0 0 -3 0 0.0000000000 0.0000000000 0 0 -0 1 0.0000000000 0.0000000000 0 0 -1 1 0.0000000000 0.0000000000 0 0 -2 1 0.0000000000 0.0000000000 0 0 -3 1 0.0000000000 0.0000000000 0 0 -0 2 -0.0002497563 -0.0002738457 0 0 -1 2 -0.0002738457 -0.0019836077 0 0 -2 2 0.0000000000 0.0000000000 0 0 -3 2 0.0000000000 0.0000000000 0 0 -0 3 0.0002497563 0.0002738457 0 0 -1 3 0.0002738457 0.0019836077 0 0 -2 3 0.0000000000 0.0000000000 0 0 -3 3 0.0000000000 0.0000000000 0 0 + 0 1 2 3 +0 0 0 0.7474 0.2526 +1 0 0 0.7073 0.2927 +2 0 0 1.0000 0.0000 +3 0 0 0.0000 1.0000 + > summary(tr.prob) +Transition 0 0 + P time var lower upper n.risk n.event + 0.882275 3 1.374e-04 0.8593018 0.905248 756 0 + 0.112434 15 1.320e-04 0.0899155 0.134952 90 0 + 0.031746 27 4.066e-05 0.0192484 0.044244 26 0 + 0.006614 41 8.690e-06 0.0008359 0.012392 5 0 + 0.002646 61 3.490e-06 0.0000000 0.006307 3 0 + 0.000000 82 0.000e+00 0.0000000 0.000000 1 0 + Transition 0 1 - P time var lower upper n.risk n.event - 0.017195767 3 2.235459e-05 0.0079289311 0.02646260 756 13 - 0.063492063 15 7.865188e-05 0.0461099474 0.08087418 90 0 - 0.030423280 27 3.901813e-05 0.0181804650 0.04266610 26 1 - 0.015873016 41 2.066278e-05 0.0069637383 0.02478229 5 0 - 0.005291005 61 6.961654e-06 0.0001196507 0.01046236 3 0 - 0.000000000 82 0.000000e+00 0.0000000000 0.00000000 1 0 + P time var lower upper n.risk n.event + 0.017196 3 2.235e-05 0.0079289 0.02646 756 13 + 0.063492 15 7.865e-05 0.0461099 0.08087 90 0 + 0.030423 27 3.902e-05 0.0181805 0.04267 26 1 + 0.015873 41 2.066e-05 0.0069637 0.02478 5 0 + 0.005291 61 6.962e-06 0.0001197 0.01046 3 0 + 0.000000 82 0.000e+00 0.0000000 0.00000 1 0 Transition 0 2 - P time var lower upper n.risk n.event - 0.08465608 3 0.0001024992 0.06481303 0.1044991 756 64 - 0.62301587 15 0.0003106708 0.58846983 0.6575619 90 4 - 0.69841270 27 0.0002786143 0.66569748 0.7311279 26 1 - 0.72751323 41 0.0002622192 0.69577517 0.7592513 5 0 - 0.74074074 61 0.0002540263 0.70950244 0.7719790 3 1 - 0.74735450 82 0.0002497563 0.71637985 0.7783291 1 1 + P time var lower upper n.risk n.event + 0.08466 3 0.0001025 0.06481 0.1045 756 64 + 0.62302 15 0.0003107 0.58847 0.6576 90 4 + 0.69841 27 0.0002786 0.66570 0.7311 26 1 + 0.72751 41 0.0002622 0.69578 0.7593 5 0 + 0.74074 61 0.0002540 0.70950 0.7720 3 1 + 0.74735 82 0.0002498 0.71638 0.7783 1 1 Transition 0 3 - P time var lower upper n.risk n.event - 0.01587302 3 2.066278e-05 0.006963738 0.02478229 756 12 - 0.20105820 15 2.124786e-04 0.172488502 0.22962790 90 1 - 0.23941799 27 2.408691e-04 0.208999432 0.26983655 26 0 - 0.25000000 41 2.480159e-04 0.219133469 0.28086653 5 0 - 0.25132275 61 2.488884e-04 0.220401973 0.28224353 3 0 - 0.25264550 82 2.497563e-04 0.221670860 0.28362015 1 0 + P time var lower upper n.risk n.event + 0.01587 3 2.066e-05 0.006964 0.02478 756 12 + 0.20106 15 2.125e-04 0.172489 0.22963 90 1 + 0.23942 27 2.409e-04 0.208999 0.26984 26 0 + 0.25000 41 2.480e-04 0.219133 0.28087 5 0 + 0.25132 61 2.489e-04 0.220402 0.28224 3 0 + 0.25265 82 2.498e-04 0.221671 0.28362 1 0 + +Transition 1 1 + P time var lower upper n.risk n.event + 1.00000 3 0.000e+00 1.00000 1.00000 0 0 + 0.38661 15 2.358e-03 0.29143 0.48179 51 0 + 0.12119 27 7.842e-04 0.06630 0.17607 23 0 + 0.04593 41 2.405e-04 0.01554 0.07633 14 0 + 0.01531 61 6.579e-05 0.00000 0.03121 4 0 + 0.00000 82 0.000e+00 0.00000 0.00000 0 0 Transition 1 2 - P time var lower upper n.risk n.event - 0.0000000 3 0.000000000 0.0000000 0.0000000 0 0 - 0.4106972 15 0.002589866 0.3109532 0.5104412 51 2 - 0.6081627 27 0.002253890 0.5151131 0.7012123 23 1 - 0.6651925 41 0.002064292 0.5761426 0.7542425 14 2 - 0.6919872 61 0.002000374 0.6043268 0.7796477 4 0 - 0.7072985 82 0.001983608 0.6200062 0.7945908 0 0 + P time var lower upper n.risk n.event + 0.0000 3 0.000000 0.0000 0.0000 0 0 + 0.4107 15 0.002590 0.3110 0.5104 51 2 + 0.6082 27 0.002254 0.5151 0.7012 23 1 + 0.6652 41 0.002064 0.5761 0.7542 14 2 + 0.6920 61 0.002000 0.6043 0.7796 4 0 + 0.7073 82 0.001984 0.6200 0.7946 0 0 Transition 1 3 - P time var lower upper n.risk n.event - 0.0000000 3 0.000000000 0.0000000 0.0000000 0 0 - 0.2026916 15 0.001784251 0.1199019 0.2854812 51 1 - 0.2706490 27 0.001967639 0.1837087 0.3575892 23 0 - 0.2888737 41 0.001981661 0.2016242 0.3761232 14 0 - 0.2927015 61 0.001983608 0.2054092 0.3799938 4 0 - 0.2927015 82 0.001983608 0.2054092 0.3799938 0 0 - -Transition 0 0 - P time var lower upper n.risk n.event - 0.882275132 3 1.373885e-04 0.859301836 0.905248429 756 0 - 0.112433862 15 1.320006e-04 0.089915535 0.134952189 90 0 - 0.031746032 27 4.065902e-05 0.019248434 0.044243630 26 0 - 0.006613757 41 8.690496e-06 0.000835852 0.012391661 5 0 - 0.002645503 61 3.490085e-06 0.000000000 0.006307062 3 0 - 0.000000000 82 0.000000e+00 0.000000000 0.000000000 1 0 - -Transition 1 1 - P time var lower upper n.risk n.event - 1.00000000 3 0.000000e+00 1.00000000 1.00000000 0 0 - 0.38661119 15 2.358121e-03 0.29143438 0.48178801 51 0 - 0.12118830 27 7.841875e-04 0.06630275 0.17607386 23 0 - 0.04593378 41 2.404897e-04 0.01553918 0.07632837 14 0 - 0.01531126 61 6.579352e-05 0.00000000 0.03120916 4 0 - 0.00000000 82 0.000000e+00 0.00000000 0.00000000 0 0 + P time var lower upper n.risk n.event + 0.0000 3 0.000000 0.0000 0.0000 0 0 + 0.2027 15 0.001784 0.1199 0.2855 51 1 + 0.2706 27 0.001968 0.1837 0.3576 23 0 + 0.2889 41 0.001982 0.2016 0.3761 14 0 + 0.2927 61 0.001984 0.2054 0.3800 4 0 + 0.2927 82 0.001984 0.2054 0.3800 0 0 > > cLOS <- etm::clos(tr.prob, aw = TRUE) @@ -598,7 +527,7 @@ Expected change in LOS with weight.other [1,] TRUE > > mean(t_pseudo$pseudoData$ps.e.phi) -[1] 1.968323 +[1] 1.968 > > ### tests on etmprep > @@ -654,6 +583,159 @@ Expected change in LOS with weight.other > all.equal(ref, newdat) [1] TRUE > +> +> ###################################### +> ### Test the stratified calls +> ###################################### +> +> if (!require(kmi, quietly = TRUE)) ++ stop("The following tests require the 'kmi' package") +> +> library(etm) +> +> data(icu.pneu) +> my.icu.pneu <- icu.pneu +> +> my.icu.pneu <- my.icu.pneu[order(my.icu.pneu$id, my.icu.pneu$start), ] +> masque <- diff(my.icu.pneu$id) +> +> my.icu.pneu$from <- 0 +> my.icu.pneu$from[c(1, masque) == 0] <- 1 +> +> my.icu.pneu$to2 <- my.icu.pneu$event +> my.icu.pneu$to2[my.icu.pneu$status == 0] <- "cens" +> my.icu.pneu$to2[c(masque, 1) == 0] <- 1 +> +> +> my.icu.pneu$to <- ifelse(my.icu.pneu$to2 %in% c(2, 3), 2, ++ my.icu.pneu$to2) +> +> my.icu.pneu <- my.icu.pneu[, c("id", "start", "stop", "from", "to", ++ "to2", "age", "sex")] +> names(my.icu.pneu)[c(2, 3)] <- c("entry", "exit") +> +> bouh_strat <- etm(my.icu.pneu, c("0", "1", "2"), tra_ill(), "cens", 0, strata = "sex") +> +> bouh_female <- etm(my.icu.pneu[my.icu.pneu$sex == "F", ], ++ c("0", "1", "2"), tra_ill(), "cens", 0) +> +> all(bouh_strat[[1]]$est == bouh_female$est) +[1] TRUE +> +> ## Test the summary +> the_summary <- summary(bouh_strat) +> the_summary +sex == "F" + +Transition 0 0 + P time var lower upper n.risk n.event + 0.99819 1 3.276e-06 0.994641 1.00000 552 0 + 0.25589 14 3.465e-04 0.219404 0.29237 154 0 + 0.08389 29 1.406e-04 0.060653 0.10714 50 0 + 0.02876 43 5.264e-05 0.014543 0.04298 16 0 + 0.01255 57 2.458e-05 0.002833 0.02227 7 0 + 0.00000 86 0.000e+00 0.000000 0.00000 0 0 + +Transition 0 1 + P time var lower upper n.risk n.event + 0.000000 1 0.000e+00 0.00000 0.00000 552 0 + 0.052655 14 9.058e-05 0.03400 0.07131 154 1 + 0.028005 29 5.032e-05 0.01410 0.04191 50 0 + 0.014936 43 2.733e-05 0.00469 0.02518 16 0 + 0.005601 57 1.038e-05 0.00000 0.01192 7 0 + 0.000000 86 0.000e+00 0.00000 0.00000 0 0 + +Transition 0 2 + P time var lower upper n.risk n.event + 0.001812 1 3.276e-06 0.0000 0.005359 552 1 + 0.691459 14 3.880e-04 0.6529 0.730064 154 13 + 0.888101 29 1.823e-04 0.8616 0.914567 50 5 + 0.956300 43 7.840e-05 0.9389 0.973655 16 1 + 0.981848 57 3.471e-05 0.9703 0.993394 7 1 + 1.000000 86 0.000e+00 1.0000 1.000000 0 0 + +Transition 1 1 + P time var lower upper n.risk n.event + 1.00000 1 0.000000 1.00000 1.0000 0 0 + 0.89474 14 0.004957 0.75674 1.0000 27 0 + 0.35627 29 0.006364 0.19992 0.5126 17 0 + 0.19001 43 0.003916 0.06736 0.3127 8 0 + 0.07125 57 0.001608 0.00000 0.1499 3 0 + 0.00000 86 0.000000 0.00000 0.0000 1 0 + +Transition 1 2 + P time var lower upper n.risk n.event + 0.0000 1 0.000e+00 0.0000 0.0000 0 0 + 0.1053 14 4.957e-03 0.0000 0.2433 27 0 + 0.6437 29 6.364e-03 0.4874 0.8001 17 2 + 0.8100 43 3.916e-03 0.6873 0.9326 8 0 + 0.9287 57 1.608e-03 0.8501 1.0000 3 0 + 1.0000 86 4.770e-18 1.0000 1.0000 1 1 + +sex == "M" + +Transition 0 0 + P time var lower upper n.risk n.event + 0.976347 2 3.035e-05 0.965550 0.98714 761 0 + 0.186247 19 2.012e-04 0.158445 0.21405 151 0 + 0.071497 35 9.063e-05 0.052838 0.09016 54 0 + 0.018589 54 2.580e-05 0.008634 0.02854 15 0 + 0.007746 77 1.148e-05 0.001105 0.01439 5 0 + 0.000000 460 0.000e+00 0.000000 0.00000 1 0 + +Transition 0 1 + P time var lower upper n.risk n.event + 0.000000 2 0.000e+00 0.00000 0.000000 761 0 + 0.052695 19 6.577e-05 0.03680 0.068590 151 0 + 0.025063 35 3.371e-05 0.01368 0.036444 54 0 + 0.013247 54 1.866e-05 0.00478 0.021713 15 0 + 0.003312 77 5.279e-06 0.00000 0.007815 5 0 + 0.000000 460 0.000e+00 0.00000 0.000000 1 0 + +Transition 0 2 + P time var lower upper n.risk n.event + 0.02365 2 3.035e-05 0.01286 0.03445 761 18 + 0.76106 19 2.410e-04 0.73063 0.79149 151 12 + 0.90344 35 1.193e-04 0.88204 0.92484 54 4 + 0.96816 54 4.374e-05 0.95520 0.98113 15 2 + 0.98894 77 1.668e-05 0.98094 0.99695 5 0 + 1.00000 460 1.016e-20 1.00000 1.00000 1 1 + +Transition 1 1 + P time var lower upper n.risk n.event + 1.0000 2 0.000000 1.00000 1.00000 0 0 + 0.5620 19 0.005905 0.41137 0.71259 43 0 + 0.2024 35 0.002450 0.10542 0.29945 18 0 + 0.1012 54 0.001182 0.03384 0.16859 9 0 + 0.0253 77 0.000314 0.00000 0.06003 3 0 + 0.0000 460 0.000000 0.00000 0.00000 0 0 + +Transition 1 2 + P time var lower upper n.risk n.event + 0.0000 2 0.000e+00 0.0000 0.0000 0 0 + 0.4380 19 5.905e-03 0.2874 0.5886 43 3 + 0.7976 35 2.450e-03 0.7005 0.8946 18 1 + 0.8988 54 1.182e-03 0.8314 0.9662 9 0 + 0.9747 77 3.140e-04 0.9400 1.0000 3 1 + 1.0000 460 3.686e-18 1.0000 1.0000 0 0 + +> +> ## Test trprob +> all(trprob(bouh_strat, "0 1")[[1]] == trprob(bouh_female, "0 1")) +[1] TRUE +> all(trprob(bouh_strat, "0 1", c(0, 5, 10, 15))[[1]] == trprob(bouh_female, "0 1", c(0, 5, 10, 15))) +[1] TRUE +> +> ## Test trcov +> all(trcov(bouh_strat, "0 1")[[1]] == trcov(bouh_female, "0 1")) +[1] TRUE +> all(trcov(bouh_strat, c("0 1", "0 2"))[[1]] == trcov(bouh_female, c("0 1", "0 2"))) +[1] TRUE +> all(trcov(bouh_strat, "0 1", c(0, 5, 10, 15))[[1]] == trcov(bouh_female, "0 1", c(0, 5, 10, 15))) +[1] TRUE +> +> options(old) +> > proc.time() user system elapsed - 9.036 0.031 9.055 + 10.864 0.180 10.930 diff -pruN 0.6-2.1-1/vignettes/etmCIF_tutorial.Rnw 1.0.4-2/vignettes/etmCIF_tutorial.Rnw --- 0.6-2.1-1/vignettes/etmCIF_tutorial.Rnw 2014-01-08 14:14:22.000000000 +0000 +++ 1.0.4-2/vignettes/etmCIF_tutorial.Rnw 2018-01-30 21:45:39.000000000 +0000 @@ -23,7 +23,7 @@ \section{Introduction} -This paper documents the use of the {\tt etmCIF} function to compute +This paper documents the use of the {\tt etmCIF} function to compute the cumulative incidence function (CIF) in pregnancy data. \section{Data Example} @@ -32,9 +32,10 @@ The data set {\tt abortion}, included in used to illustrate the computation of the CIFs. We first load the {\bf etm} package and the data set. <<>>= -require(etm) +library(etm) +library(survival) data(abortion) -@ +@ Briefly, the data set contains information on \Sexpr{nrow(abortion)} pregnant women collected prospectively by the Teratology Information @@ -43,13 +44,13 @@ Service of Berlin, Germany \citep{meiste to coumarin derivatives, a class of orally active anticoagulant, and \Sexpr{with(abortion, table(group)[1])} women served as controls. Coumarin derivatives are suspected to increase the number of -spontaneous abortions. Competing events are elective abortion (ETOP) and +spontaneous abortions. Competing events are elective abortion (ETOP) and life birth. Below is an excerpt of the data set <<>>= head(abortion) -@ +@ {\tt id} is the individual number, {\tt entry} is the gestational age at which the women entered the study, {\tt exit} is the gestational @@ -75,46 +76,46 @@ to facilitate the computation of the CIF means that any value different from 0 in {\tt cause} will be considered as an event -- which is the case in our example, as we don't have censoring. - + \item {\tt data}: A data set in which to interpret the terms of the formula. In our case, it will be {\tt abortion}. - + \item {\tt etype}: Competing risks event indicator. When the status indicator is 1 (or TRUE) in the formula, {\tt etype} describes the type of event, otherwise, for censored observation, the value of {\tt etype} is ignored. - + \item {\tt failcode}: Indicates the failure type of interest. Default is one. This option is only interesting for some features of the - plot function. + plot function. \end{itemize} \subsection{Estimation and display of the CIFs} We know compute the CIFs <<>>= -cif.abortion <- etmCIF(Surv(entry, exit, cause != 0) ~ group, +cif.abortion <- etmCIF(Surv(entry, exit, cause != 0) ~ group, abortion, etype = cause, failcode = 3) cif.abortion -@ +@ Above is the display provided by the {\tt print} function. It gives, at the last event time, the probabilities ({\tt P}) standard errors ({\tt se(P)}), and the total number of events ({\tt n.event}) for the -three possible pregnancy outcomes and for both groups. +three possible pregnancy outcomes and for both groups. More information is provided by the {\tt summary} function. <<>>= s.cif.ab <- summary(cif.abortion) -@ +@ The function returns a list of data.frames that contain probabilities, variances, pointwise confidence intervals, number at risk and number -of events for each event times. the {\tt print} function displays this +of events for each event times. the {\tt print} function displays this information for some selected event times. <<>>= s.cif.ab -@ +@ \subsection{Plotting the CIFs} @@ -127,7 +128,7 @@ CIFs for the event of interest, i.e., th \begin{center} <>= plot(cif.abortion) -@ +@ \caption{CIFs of spontaneous abortion for the controls (solid line) and the exposed (dashed line), using the default settings of the {\tt plot} function.} @@ -136,16 +137,16 @@ plot(cif.abortion) \clearpage -We now add confidence intervals taken at week 27, plus a +We now add confidence intervals taken at week 27, plus a bit of customisation. \setkeys{Gin}{width=0.9\textwidth} \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = 27, col = c(1, 2), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = 27, col = c(1, 2), ci.lwd = 6, lwd = 2, lty = 1, cex = 1.3) -@ +@ \caption{CIFs of spontaneous abortion for the controls (black) and the exposed (red), along with pointwise confidence intervals taken at week 27.} @@ -164,10 +165,10 @@ manipulating the {\tt pos.ci} argument: \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, lwd = 2, lty = c(2, 1), cex = 1.3) -@ +@ \caption{CIFs of spontaneous abortion for the controls (dashed line) and the exposed (solid line), along with pointwise confidence intervals.}\label{decalage} \end{center} @@ -180,9 +181,9 @@ follow-up period. \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.5), +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.5), ci.type = "pointwise", col = c(1, 2), lwd = 2, lty = 1, cex = 1.3) -@ +@ \caption{Same as the last pictures, except for the confidence intervals, that are displayed for the whole follow-up period.} \end{center} @@ -199,11 +200,11 @@ in the call to {\tt plot}. <>= plot(cif.abortion, which.cif = c(1, 2), ylim = c(0, 0.8), lwd = 2, col = c(1, 1, 2, 2), lty = c(1, 2, 1, 2), legend = FALSE) -legend(0, 0.8, c("Control", "Exposed"), col = c(1, 2), lty = 1, +legend(0, 0.8, c("Control", "Exposed"), col = c(1, 2), lty = 1, bty = "n", lwd = 2) -legend(0, 0.7, c("ETOP", "Life Birth"), col = 1, lty = c(1, 2), +legend(0, 0.7, c("ETOP", "Life Birth"), col = 1, lty = c(1, 2), bty = "n", lwd = 2) -@ +@ \end{center} \caption{CIFs of ETOP (solid lines) and life birth (dashed lines) for the exposed, in red, and the controls, in black.} @@ -219,7 +220,7 @@ For those who don't like using plain num events or the group allocation, it is of course possible to give more informative names, either as factors or character vectors. For instance, we define a new group variable that takes value {\tt 'control'} -or {\tt 'exposed'}, and we give more informative names for the pregnancy +or {\tt 'exposed'}, and we give more informative names for the pregnancy outcomes. <<>>= @@ -234,13 +235,13 @@ abortion$treat <- factor(abortion$treat) We can compute the CIFs as before, taking care of changing the {\tt failcode} argument. <<>>= -new.cif <- etmCIF(Surv(entry, exit, status != 0) ~ treat, abortion, +new.cif <- etmCIF(Surv(entry, exit, status != 0) ~ treat, abortion, etype = status, failcode = "spontaneous abortion") new.cif -@ +@ The {\tt summary} and {\tt plot} functions will work as before, except -for a more informative outcome from scratch. +for a more informative outcome from scratch. \paragraph{Taking advantage of the miscellaneous functions defined for {\tt etm} objects} @@ -249,17 +250,17 @@ The {\tt etmCIF} function uses the more for computing the CIFs. Thus the returned {\tt etmCIF} object is for part a list of {\tt etm} objects (one for each covariate level). It is therefore relatively easy to use the methods defined for {\tt etm} on -{\tt etmCIF} objects. +{\tt etmCIF} objects. An example would be to use the {\tt trprob} function to extract the CIF of spontaneous abortion for the controls. This function takes as arguments an {\tt etm} object, the transition we are interested in, in the form ``from to'' (the state a patient comes from is automatically -defined as being 0 in {\tt etmCIF}), and possibly some time points. +defined as being 0 in {\tt etmCIF}), and possibly some time points. Using {\tt new.cif} from the example above: <<>>= trprob(new.cif[[1]], "0 spontaneous abortion", c(1, 10, 27)) -@ +@ We applied the {\tt trprob} function to the {\tt etm} object for the controls (which is in the first item of the output, for the exposed in the second). The transition of interest is from {\tt 0} to {\tt @@ -274,16 +275,16 @@ in the {\tt trprob} function. <>= lines(cif.abortion[[2]], tr.choice = "0 1", col = 2, lwd = 2) -@ +@ \setkeys{Gin}{width=0.9\textwidth} \begin{figure}[!htb] \begin{center} <>= -plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), - ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, +plot(cif.abortion, curvlab = c("Control", "Exposed"), ylim = c(0, 0.6), + ci.type = "bars", pos.ci = c(27, 28), col = c(1, 1), ci.lwd = 6, lwd = 2, lty = c(2, 1), cex = 1.3) lines(cif.abortion[[2]], tr.choice = "0 1", col = 2, lwd = 2) -@ +@ \caption{Figure \ref{decalage} along with the CIF of ETOP for the exposed in red.} \end{center} \end{figure}