timereg/0000755000176200001440000000000014666623403011720 5ustar liggesuserstimereg/MD50000644000176200001440000001431214666623403012231 0ustar liggesusers09cb762ba6a87d0bff6b316f1d678a20 *DESCRIPTION 8f047e7f91e9408620e8c986aa2cea7f *NAMESPACE 5626b58ac5b3148673c12e7917b6be8a *R/Cpred.r 099387f56334cc736e8cb231fb9c45a9 *R/Csmooth.r 7288a70096d1613865a1f6e5146b6f23 *R/Gprop-odds.r ac65573f1ba9279d3703c639e7beea3b *R/aalen-des.r 8f71b7488126898d1f57d7d0d0502cce *R/aalen.r 828e7d515d1ddb5e6ff407e835c9d0d6 *R/aalenC.r ce5df16dab12642b83def64d018f573b *R/additive-compSs.r 825a00585f9c8a88261c1856d5bb68d9 *R/base.r 90a81492629f339340e34698756ab3d5 *R/clusterindex-reshape.r 25123a09bd94c09ff2c3bbea77e91513 *R/comprisk.ipw.r 2a5bd3ceae1dd3377d8184607e8d11ef *R/comprisk.r 8fcbdd34fea0dd6df9da60ac6f52c124 *R/cox-aalen.r ac3e9cba85994ee64d58271355b19c66 *R/cox.ipw.r b86e4223e01cc585c71738fe7831df91 *R/cox.marg.r 4d4e18867d345927fb741137a190d7a5 *R/dynadd.r b042d61b19a0a45488cb4733ae0a8d3f *R/event.r d204c1438ab3a4c7d6fefe06e7e5ba50 *R/event.split.r e4ea65660c583fa2badf2c4ced5e0da5 *R/glm-comprisk.r c7c083d2ef54d38c42daa2e05c321898 *R/ipcw-residualmean.r 059050bba25ecb3573efe3bf39c17907 *R/kmplot.r 8c13dd5267a40d23a05b3bf1727a4a36 *R/krylow.pls.r 875d0bcd6ab756f25829f93dcc4c5f21 *R/mgresid.r 7f4332ab4d956334e9045d494358ff6a *R/new.aalen.r e057c6252fe2053bb8d095eab5e88ec0 *R/new.cox-aalen.r e97aa0b0a0b7cb2e3976ca35886492ef *R/new.dynreg.r 8d36620827445f0c78d85f07b583d98b *R/new.pe-sasieni.r dbee1c579bf6453c892c9f0234522c3a *R/new.prop-excess.r bbdd0812af948739cddf0d7cc8f69cd3 *R/new.timecox.r 2ba646047aa9ed862cc1a4debb9cfc1e *R/plots.r 9e1b99b5b49f4f7dfacaf9c22e29c955 *R/predict-timereg.r e7135ed89e91b6ad4038bc36a98d896f *R/prop-excess.r 4a4af0aca998701f9fe11cf7940fd1a0 *R/prop-odds-subdist.r 21e9898b2d60394a477e2a27c852536f *R/prop-odds.r 1919ca75894e6e4ba1bef85cf973b897 *R/qcut.r 1ada7ca3cc97eb1f61f86489747c520d *R/read-design.r 2aec6e39ea0a684c0f602518837f9a2a *R/recurrent.r ec1d20dfef3c8c448dd24a35721d143b *R/residualsTimereg.r d9eda9827b80fec05cc3b15bcd999d0e *R/restricted.residual.mean.r 54ee566ee5b1fa0665545bbd70fea20b *R/timecox.r 82f4a3df0076148b80060681e144d69c *R/timereg-copy-package.R 24ae9a1c4086cc23e46275bef5d36c8d *R/two-stage-reg.r f9cf9dc925b0eb4532905279dcd07a3f *data/TRACE.txt.gz 4287db3533e463a0c4899b7faad8962b *data/bmt.txt.gz 82f961ec5ff8c270f587e6b37fa0dc36 *data/cd4.txt.gz 11f82920649a881ac6294f42a2d6453a *data/csl.txt.gz 0bcb44d800f82ecdff05128e2cdc667f *data/diabetes.txt.gz 8b1d076260893d0229f17444b3ca13fe *data/mela.pop.txt.gz 5adbdbf1e4b24898191a1de02bcb0a86 *data/melanoma.txt.gz 0515e4b60fa4a9bb9c5d9752f2545050 *data/mypbc.txt.gz f3f92fad3fa105fa22ddbd56db3648f4 *data/sTRACE.txt.gz b61d3b8771eadd513bb517dfa7487cbf *data/tTRACE.txt.gz f3e1568a39f5c4d271647c448db77fec *inst/CITATION 632f65da91c05ddeb3532642177fb1e2 *man/Event.Rd f4b6649c6526904d45c87215faaf1eb5 *man/Gprop.odds.Rd 79c76b64bdcce478ed33d05541cec935 *man/TRACE.Rd e8284679607579f0a4d93b8533d022fc *man/aalen.Rd 7fbc7eae8f3bfea691b749c4b527e3ea *man/bmt.Rd 6d2ea3277d577d050fab1524b69b7b2c *man/cd4.Rd 169ec7e7f3a8ca96cdd8e825090ea06d *man/comp.risk.Rd 350fec0cecc267ae95ea93919eed3f95 *man/const.Rd 8b26d35fbdb93f0d3c6acd34120c1035 *man/cox.Rd 7d5bb7546a7072b66de26ba8d5853f0e *man/cox.aalen.Rd 76c7af2f2a5a628bd96842602d95224c *man/cox.ipw.Rd a492a8b2210cd1576538a38cb9044e15 *man/csl.Rd d36cf628de8ba43ac0e5df33ae653e02 *man/cum.residuals.Rd bdabc53ef7f9e7fc6252f34bfd78c0a8 *man/diabetes.Rd 1742f364a6307469ac4a48eb2564ba54 *man/dynreg.Rd 20384a51a8aa97a93ffd83ac8ca3e2b8 *man/event.split.Rd 51b2684b3427df231d9675f2e08174b7 *man/internal-addreg.Rd 15639ce7d9851fdc71ee6960672bf2e5 *man/krylow.pls.Rd d55feb16a4435a4361cef76a20836d94 *man/mela.pop.Rd e5beb43d6f21fb7d746998b3bc65b98e *man/melanoma.Rd 05c259e250c27f3a8bd74c3238a65b75 *man/mypbc.Rd 882abb59f0c2d83574602bc7eb999067 *man/pava.pred.Rd b641418624eadac51f6d57bda285e1ba *man/pe.sasieni.Rd 72025de21e806ea0678df0ffde962f63 *man/plot.aalen.Rd 8bef80978f9ef499c49ccc62f4680bf6 *man/plot.cum.residuals.Rd e7de67fcf562f623ee7780ee917fdac6 *man/plot.dynreg.Rd 325f6eb8afc83c89f2311e5b582545ec *man/predict.timereg.Rd 387564bb3113e59fb50682b5d0a178fc *man/prep.comp.risk.Rd e9d1aea47071d1a1be53adec1dcc0bab *man/print.aalen.Rd 225b218c8b14b80c65b3b6f487208af2 *man/prop.Rd 7932ee387330784c23638ac49f499a41 *man/prop.excess.Rd 30fe9c58d319b5a17d43b3a2ec141e88 *man/prop.odds.Rd c614af392e58f15a26dc9ca98bdda34b *man/prop.odds.subdist.Rd bd9941d527a00930f5ea4cd9eef2c179 *man/qcut.Rd dff199c02a90c08d5a213d3223dae790 *man/recurrent.marginal.coxmean.Rd 561676b16959b2072d7902162744d90f *man/recurrent.marginal.mean.Rd e2069e66fefd8a0601ea008629bc6513 *man/res.mean.Rd e585fbc99585cbef346682b9c2ed7f7d *man/restricted.residual.mean.Rd a28f24f21384abedf39e210325980a1e *man/summary.aalen.Rd f2866c71545517e06ace846609a3aba9 *man/summary.cum.residuals.Rd 6ce722252b424227ca04ee81b2865703 *man/timecox.Rd 9e1ba96ddf7bc4ab5319a5f81ff8c57d *man/two.stage.Rd 6ca0ff08d96ffde78722a1d7b127a127 *man/wald.test.Rd daef017d341ba712c9eb9d2c77439921 *src/Gprop-odds.c 619d13ce6900fca2139e2139408d39ad *src/Makevars 9f51e3f4c20f83c18f959bc1434c1769 *src/Makevars.win b963f0b3911cc21da984f0fea67e0fb2 *src/aalen.c 3622918d8de5b46d274fdd735a63da4a *src/aalenC.c 5c94ca6e62d4815373dd213c6b313db6 *src/additive-compSs.c 40317638eda1d89fffe307a7eacf19ff *src/breslow.c 06d355d5db087581c5c79e0a44858b25 *src/comprisk.c 4af2092d013aff6795231d8127fe3be5 *src/comptest-cmprsk.c e29122ed5b6d2f81bfe22ec77490623b *src/comptest.c ea3e5ea0f0b035c4b04e193b99214bb0 *src/cox-aalen.c 428348f508251e6ce3f7f4081668c8c7 *src/dynadd.c e7d148e52968b5e6e4e8bbefef40bb09 *src/ipcw-residualmean.c 20e22f72953d0ba8dadd8dd4a63f14e1 *src/matrix.c 2399d655898aa2f709b13d4ca686956e *src/matrix.h ec54718b993096ba261aab9925972bbf *src/mgresid.c 49bbf5d16d6ae2d81a62597862480bbd *src/pava.c 9b164bfbaa8095b13bb6f7cb54f5b14f *src/pe-sasieni.c cebc5a722eee801ed9cb1406c265d788 *src/pred.c 4947e0d0f27fb5d7a772733fca948cd8 *src/prop-excess.c abe6ecba48e8ab502eb17c260084934c *src/prop-odds-subdist2.c 9fa9ecd28092554951bbd510c92d1a65 *src/prop-odds.c c671a8b63762095fc660091b43880c7d *src/smooth.c 3d1cc94c5245d2a1614c2f05cabc0404 *src/smooth2.c 8e4035e154447a80ea75643b60016685 *src/timecox.c 398876f7d6c9f60d8e2e76a373900ad4 *src/timeregister.c 56a51f07aa1b1c2d4595e09fc7d0fb12 *src/two-stage-reg.c 4a3635d48173358c8ff1542026152be4 *src/unifConfBandResampling.c timereg/R/0000755000176200001440000000000014665311644012121 5ustar liggesuserstimereg/R/Cpred.r0000644000176200001440000000316214421510276013333 0ustar liggesusersCpred<-function(cum,xval,start.val=0,cum.startval=0,order=FALSE,comp="smaller",strict=TRUE) { designX<-as.matrix(cum); cumtimes <- designX[,1] px<-as.integer(dim(designX)[2]); nx<-as.integer(dim(designX)[1]); nval<-length(xval); pred<-rep(0,nval); ###sout<-.C("Cpred", ###as.double(cumtimes),as.integer(nx),as.integer(px), ###as.double(xval),as.integer(nval),as.integer(pred), ###as.integer(Tminus),PACKAGE="timereg") ### sindex from prodlim xval.order <- sindex.prodlim(cumtimes,xval,comp=comp,strict=strict) pred.begin <- xval.order pred.begin[xval.order==0] <- 1 ###predcum <- as.matrix(designX[pred.begin,-1]) predcum <- designX[pred.begin,-1,drop=FALSE] predcum[xval.order==0,] <- cum.startval if (order==FALSE) return(cbind(xval,predcum)) else return(list(xval.order=xval.order,pred.begin=pred.begin)) } ## sindex fra prodlim, thanks to Thomas Gerds sindex.prodlim <- function (jump.times, eval.times, comp = "smaller", strict = FALSE) { stopifnot(is.numeric(jump.times)) stopifnot(is.numeric(eval.times)) N <- length(jump.times) if (comp == "greater") { N - sindex.prodlim(jump.times = jump.times, eval.times = eval.times, comp = "smaller", strict = !strict) } else { neval <- length(eval.times) if (!(neval > 0 && N > 0)) stop("missing data") new.order <- order(eval.times) ind <- .C("sindex", index = integer(neval), as.double(sort(jump.times)), as.double(eval.times[new.order]), as.integer(N), as.integer(neval), as.integer(strict), PACKAGE = "timereg")$index ind[order(new.order)] } } timereg/R/base.r0000644000176200001440000002231714665311644013223 0ustar liggesuserscoefBase<- function(object, digits=3, d2logl=0,ci=1,alpha=0.05) { ## {{{ res <- cbind(object$gamma, diag(object$var.gamma)^0.5, diag(object$robvar.gamma)^0.5) if (d2logl==1) res<-cbind(res,diag(object$D2linv)^.5) wald <- object$gamma/diag(object$robvar.gamma)^0.5 waldp <- (1 - pnorm(abs(wald))) * 2 res <- signif(as.matrix(cbind(res, wald, waldp)),digits=digits) if (d2logl==1) colnames(res) <- c("Coef.", "SE", "Robust SE","D2log(L)^-1","z","P-val") else colnames(res) <- c("Coef.", "SE", "Robust SE", "z", "P-val") if (ci==1) { slower <- paste("lower",signif(100*alpha/2,2),"%",sep="") supper <- paste("upper",signif(100*(1-alpha/2),3),"%",sep="") res <- signif(cbind(res,res[,1]+qnorm(alpha/2)*res[,2],res[,1]+qnorm(1-alpha/2)*res[,2]),digits=digits); nn <- ncol(res); colnames(res)[(nn-1):nn] <- c(slower,supper) } ### prmatrix(signif(res, digits)) return(res) } ## }}} coefcox <- function(object, digits=3, d2logl=0,ci=1,alpha=0.05) { ## {{{ res <- cbind(object$coef, diag(object$var)^0.5) wald <- object$coef/diag(object$var)^0.5 waldp <- (1 - pnorm(abs(wald))) * 2 res <- signif(as.matrix(cbind(res, wald, waldp)),digits=digits) colnames(res) <- c("Coef.", "SE", "z", "P-val") if (ci==1) { slower <- paste("lower",signif(100*alpha/2,2),"%",sep="") supper <- paste("upper",signif(100*(1-alpha/2),3),"%",sep="") res <- signif(cbind(res,res[,1]+qnorm(alpha/2)*res[,2],res[,1]+qnorm(1-alpha/2)*res[,2]),digits=digits); nn <- ncol(res); colnames(res)[(nn-1):nn] <- c(slower,supper) } ### prmatrix(signif(res, digits)) return(res) } ## }}} #' Makes wald test #' #' Makes wald test, either by contrast matrix or testing components to 0. Can #' also specify the regression coefficients and the variance matrix. Also #' makes confidence intervals of the defined contrasts. Reads coefficientes #' and variances from timereg and coxph objects. #' #' #' @param object timereg object #' @param coef estimates from some model #' @param Sigma variance of estimates #' @param vcov same as Sigma but more standard in other functions #' @param contrast contrast matrix for testing #' @param coef.null which indeces to test to 0 #' @param null mean of null, 0 by default #' @param print.coef print the coefficients of the linear combinations. #' @param alpha significance level for CI for linear combinations of #' coefficients. #' @author Thomas Scheike #' @keywords survival #' @examples #' #' data(sTRACE) #' # Fits Cox model #' out<-cox.aalen(Surv(time,status==9)~prop(age)+prop(sex)+ #' prop(vf)+prop(chf)+prop(diabetes),data=sTRACE,n.sim=0) #' #' wald.test(out,coef.null=c(1,2,3)) #' ### test age=sex vf=chf #' wald.test(out,contrast=rbind(c(1,-1,0,0,0),c(0,0,1,-1,0))) #' #' ### now same with direct specifation of estimates and variance #' wald.test(coef=out$gamma,Sigma=out$var.gamma,coef.null=c(1,2,3)) #' wald.test(coef=out$gamma,Sigma=out$robvar.gamma,coef.null=c(1,2,3)) #' ### test age=sex vf=chf #' wald.test(coef=out$gamma,Sigma=out$var.gamma, #' contrast=rbind(c(1,-1,0,0,0),c(0,0,1,-1,0))) #' #' @export wald.test <- function(object=NULL,coef=NULL,Sigma=NULL,vcov=NULL,contrast,coef.null=NULL,null=NULL,print.coef=TRUE,alpha=0.05) { ## {{{ coefs <- NULL if (inherits(object,"coxph")) {coef <- matrix(coef(object),ncol=1); Sigma=object$var;} if (inherits(object,"phreg")) {coef <- matrix(c(coef(object)),ncol=1); Sigma=vcov(object);} if (inherits(object,"cox.aalen")) {coef <- object$gamma; Sigma=object$var.gamma;} if (is.null(Sigma)) { if (inherits(object,c("cor","twostage"))) Sigma <- object$var.theta else Sigma <- object$var.gamma; } if (!is.null(object)) { if (inherits(object,c("cor","twostage"))) coefs <- object$theta else coefs <- object$gamma; } if (is.null(coefs)) coefs <- coef(object) if (!is.null(coef)) coefs <- coef ## else stop("No estimates given \n"); nl <- length(coefs) if (missing(contrast)) { contrast <- rep(1,length(coefs)) contrast <- diag(1,nl); ### namesc <- names(c(coefs)) } if (!is.null(coef.null)) { contrast <- c() for (i in coef.null) contrast <- rbind(contrast,c((1:nl)==i)*1) } if (missing(null)) null <- 0 if (is.null(Sigma)) Sigma <- vcov if (is.null(Sigma)) Sigma <- vcov(object) ### Wald test B <- contrast p <- coefs if (is.vector(B)) { B <- rbind(B); colnames(B) <- names(contrast) } varBp <- B%*%Sigma%*%t(B) seBp <- diag(varBp)^.5 lin.comb <- B %*% p Q <- t(B%*%p-null)%*%solve(varBp)%*%(B%*%p-null) zvals <- lin.comb/seBp pvals <- 2*(1-pnorm(abs(zvals))) coef.out <- cbind(lin.comb,seBp,lin.comb+seBp*qnorm(alpha/2),lin.comb+seBp*qnorm(1-alpha/2),pvals) colnames(coef.out) <- c("lin.comb","se","lower","upper","pval") if (print.coef) prmatrix(coef.out) df <- qr(B)$rank; names(df) <- "df" attributes(Q) <- NULL; names(Q) <- "chisq"; pQ <- ifelse(df==0,NA,1-pchisq(Q,df)) method = "Wald test"; ## hypothesis <- res <- list(##data.name=hypothesis, statistic = Q, parameter = df, p.value=pQ, method = method,coef.out=coef.out,varBp=varBp,lin.comb=lin.comb) class(res) <- "htest" attributes(res)$B <- B return(res) } ## }}} timetest<-function(object,digits=3,hyp.label="p-value H_0:constant effect",out=0) { ## {{{ cat("Test for nonparametric terms \n") if (is.null(object$conf.band)==TRUE) mtest<-FALSE else mtest<-TRUE; if (mtest==FALSE) cat("Test not computed, sim=0 \n\n") if (mtest==TRUE) { test0<-cbind(object$obs.testBeq0,object$pval.testBeq0) testC<-cbind(object$obs.testBeqC,object$pval.testBeqC) colnames(test0)<-c("Supremum-test of significance","p-value H_0: B(t)=0") colnames(testC)<-c(" Kolmogorov-Smirnov test",hyp.label) if (is.null(object$obs.testBeqC.is)!=TRUE) { testCis<-cbind(object$obs.testBeqC.is,object$pval.testBeqC.is) colnames(testCis) <- c(" Cramer von Mises test",hyp.label) } cat("\n") cat("Test for non-significant effects \n") prmatrix(signif(test0,digits)) cat("\n") cat("Test for time invariant effects \n") prmatrix(signif(testC,digits)) if (is.null(object$obs.testBeqC.is)!=TRUE) prmatrix(signif(testCis,digits)) cat("\n") if (out==1) return(cbind(test0,testC)); } } ## }}} is.diag <- function(m) { ## {{{ p <- nrow(m) adiag <- min(diag(m)*1) if (adiag==0) ud <- FALSE else ud <- TRUE dm <- diag(p); diag(dm) <- diag(m); ndiag <- sum(abs(c(m - dm))) if (ndiag>0.0000001) ud <- FALSE; return(ud) } ## }}} risk.index <- function(start,stop,id,times) { ## {{{ n <- length(start) nstop <- length(stop) if (n!=nstop) stop("start and stop not of same length\n"); if (is.null(id)) id <- 1:n nid <- length(id) if (n!=nid) stop("id and start not of same length\n"); nt <- length(times) nclust <- .C("atriskindex", as.double(start), as.double(stop), as.integer(id), as.integer(n), as.double(times), as.integer(nt), as.integer(rep(0,nt)),as.integer(rep(0,nt*n)),PACKAGE="timereg") nrisk <- nclust[[7]] riskindex <- matrix(nclust[[8]],nt,n) out <- list(nrisk=nrisk,riskindex=riskindex) } ## }}} namematrix<-function(mat,names) { colnames(mat)<-names; rownames(mat)<-names; return(mat); } nameestimate<-function(mat,names) { colnames(mat)<-"estimate"; rownames(mat)<-names; return(mat); } aalen.des<-function(formula=formula(data),data=parent.frame(),model="aalen") { ## {{{ call <- match.call(); m <- match.call(expand.dots=FALSE); m$model<-NULL special <- c("cluster","prop","const") Terms <- if(missing(data)) terms(formula,special) else terms(formula, special, data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m,"response") des<-read.design(m,Terms,model=model) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ; clusters<-des$clusters; if (attr(m[, 1], "type") == "right") { type<-"right"; status <- m[, 1][, "status"]; time2 <- m[, 1][, "time"]; time <- rep(0,length(time2)); } else if (attr(m[, 1], "type") == "counting") { type<-"counting"; time <- m[, 1][,1]; time2 <- m[, 1][,2]; status <- m[, 1][,3]; } else { stop("only right-censored or counting processes data") } return(list(type=type,time=time,time2=time2,status=status, X=X,Z=Z,px=px,pz=pz,npar=npar, covnamesX=covnamesX,covnamesZ=covnamesZ,clusters=clusters)) } ## }}} #' @export names2formula <- function(formula,names) { ## {{{ covs <- paste("~",names[1],sep="") if (length(names)>=2) for (i in 2:length(names)) covs <- c(paste(covs,paste("+",names[i],sep=""))) covs <- as.formula(covs) formula <- update(formula,covs) return(formula) } ## }}} #' @export timereg.formula <- function(formula,propterms=NULL,special="prop") { ## {{{ vars <- all.vars(update(formula,0~.)) nonpropvars <- NULL if (!is.null(propterms)) { nonpropvars <- vars[-propterms]; vars <- vars[propterms] } covs <- paste("~",special,"(",vars[1],")",sep="") if (length(vars)>=2) for (i in 2:length(vars)) covs <- c(paste(covs,paste("+",special,"(",vars[i],")",sep=""))) if (!is.null(nonpropvars)) { for (i in 1:length(nonpropvars)) covs <- c(paste(covs,paste("+",nonpropvars[i],sep=""))) } covs <- as.formula(covs) formula <- update(formula,covs) return(formula) } ## }}} timereg/R/cox-aalen.r0000644000176200001440000002200614421510276014143 0ustar liggesuserscox.aalenBase<-function (times, fdata, designX, designG, status, id, clusters, Nit = 5, beta = 0, weights=NULL, detail = 0, sim = 1, antsim = 1000, weighted.test= 0, robust = 1, ratesim = 0, residuals = 0, covariance = 1, resample.iid=0,namesZ=NULL,namesX=NULL,beta.fixed=0,strata=NULL, entry=NULL,offsets=0,exactderiv=1,max.timepoint.sim=100,silent=1,basesim=0, propodds=0,caseweight=NULL) ## {{{ { additive.resamp <-0; ridge <- 0; XligZ <- 0; Ntimes <- length(times) ### sim <- rep(sim,3); sim <- basesim; ## c(1,0.2), to simulat starting at 0.2 if (length(sim)==1) sim <- c(sim,0) ### if (ratesim==0 && (max(by(status,clusters,sum))>1)) mjump <- 1 else mjump <- 0; mjump <- 0 ### not working ### sim[2] <- mjump; ### multiple jumps within cluster if (ratesim==0 && mjump==1) cat("Multiple jumps in some clusters, use rate.sim=1\n"); if (is.null(max.timepoint.sim)) max.timepoint.sim <- Ntimes; if (max.timepoint.sim< Ntimes) { ## {{{ qq <- quantile(times, probs = seq(0, 1, length=max.timepoint.sim)) qqc <- cut(times, breaks = qq, include.lowest = TRUE) time.group <- as.integer(factor(qqc, labels = 1:(max.timepoint.sim-1))) time.resolution <- qq mts <- max.timepoint.sim; } else { time.resolution <- qq <- times; time.group <- 0:(Ntimes-1); max.timepoint.sim <- mts <- Ntimes; } ## }}} if (robust==1) antclust <- fdata$antclust else antclust <- 1 designX <- as.matrix(designX); designG <- as.matrix(designG) if (is.matrix(designX) == TRUE) px <- as.integer(dim(designX)[2]) if (is.matrix(designX) == TRUE) nx <- as.integer(dim(designX)[1]) if (is.matrix(designG) == TRUE) pg <- as.integer(dim(designG)[2]) if (is.matrix(designG) == TRUE) ng <- as.integer(dim(designG)[1]) if (nx != ng) print(" X design and Z not same number of rows\n") if (is.null(weights)==FALSE) mw<-1 else { mw <- 0; weights <- rep(1, nx);} if (sum(offsets)==0) mof <- 0 else mof <- 1; nb <- 1; aalen <- 1 if (covariance == 1) covs <- matrix(0, mts, px * px) else covs <- 0 cumAi <- 0; dNit <- 0 ; dM.iid<-0; gammaiid <- matrix(0, pg, fdata$antclust * 1) if (residuals == 1) cumAi <- matrix(0, Ntimes , fdata$antpers * 1) ### if (residuals == 1) dNit <- matrix(0, Ntimes , fdata$antpers * 1) if (residuals == 2) cumAi <- rep(0, fdata$antpers * 1) cumint <- vcum <- matrix(0, Ntimes , px + 1); Rvcu <- matrix(0, mts, px + 1); if (any(is.na(beta))) { cat(" Starting values include NA, possibly from call of coxph\n"); beta[is.na(beta)] <- 0;} if (sum(abs(beta)) == 0) betaS <- rep(0, pg) else betaS <- beta if (length(betaS)!=pg) betaS <- rep(betaS[1],pg); score <- betaS; loglike <- rep(0,2); RVarbeta <- Iinv <- Varbeta <- matrix(0, pg, pg); if (antsim>0) Uit <- matrix(0, mts , 50 * pg) else Uit <- NULL if (additive.resamp == 1) baseproc <- matrix(0, mts, 50 * px) else baseproc <- NULL if (resample.iid == 1) biid <- matrix(0, mts, fdata$antclust * px) else biid <- NULL; gamiid<- matrix(0,fdata$antclust,pg); test <- matrix(0, antsim, 2 * px); testOBS <- rep(0, 2 * px) unifCI <- c(); testval <- c(); rani <- -round(runif(1) * 10000) Ut <- matrix(0, mts , pg + 1); simUt <- matrix(0, antsim, pg) var.score<- matrix(0, Ntimes , pg + 1); if (is.diag( t(designX) %*% designX )==TRUE) stratum <- 1 else stratum <- 0 if (!is.null(strata)) ostratum <- c(stratum[1],length(unique(strata)),strata) else if (stratum==1) ostratum <- c(stratum,px,designX %*% (0:(px-1))) else ostratum <- c(stratum,1,rep(0,nx)); stratum <- ostratum ### print(stratum); ### print(weights); print(offsets) icase <- 0 if (!is.null(caseweight)) {icase <- 1; caseweight <-c(0,caseweight) ### cumint[,1] <- c(0,caseweight) } else caseweight<-rep(0,Ntimes+1) silent <- c(silent,propodds,icase) nparout <- .C("score", as.double(times), as.integer(Ntimes), as.double(designX), as.integer(nx), as.integer(px), as.double(designG), as.integer(ng), as.integer(pg), as.integer(fdata$antpers), as.double(fdata$start), as.double(fdata$stop), as.double(betaS), as.integer(Nit), as.double(cumint), as.double(vcum), as.double(weights), as.integer(mw), as.double(loglike), as.double(Iinv), as.double(Varbeta), as.integer(detail), as.double(offsets), as.integer(mof), as.double(sim), as.integer(antsim), ### as.integer(rani), as.double(Rvcu), as.double(RVarbeta), as.double(test), as.double(testOBS), as.double(Ut), as.double(simUt), as.double(Uit), as.integer(XligZ), as.double(aalen), as.integer(nb), as.integer(id), as.integer(status), as.integer(weighted.test), as.double(dNit), as.integer(ratesim), as.double(score), as.double(cumAi), as.double(gammaiid), as.double(dM.iid), as.integer(residuals), as.integer(robust), as.integer(covariance), as.double(covs), as.integer(additive.resamp), as.double(baseproc), as.integer(resample.iid), as.double(gamiid), as.double(biid),as.integer(clusters),as.integer(antclust), as.double(var.score),as.integer(beta.fixed), as.double(weights),as.integer(entry) ,as.integer(exactderiv), as.integer(time.group), as.integer(max.timepoint.sim),as.integer(stratum), as.double(silent),as.double(caseweight),PACKAGE = "timereg") Iinv <- matrix(nparout[[19]], pg, pg); RVarbeta <- -matrix(nparout[[27]], pg, pg) rvcu <- matrix(nparout[[26]], mts , px + 1); ## convert to approx for times Rvcu <- times; for (i in 2:(px+1)) Rvcu <- cbind(Rvcu,approx(rvcu[,1],rvcu[,i],times,f=0.5)$y) Varbeta <- -matrix(nparout[[20]], pg, pg); cumint <- matrix(nparout[[14]], Ntimes, px + 1); vcum <- matrix(nparout[[15]], Ntimes, px + 1) gamma <- matrix(nparout[[12]], pg, 1); score <- matrix(nparout[[41]], pg, 1) Ut <- matrix(nparout[[30]], mts , pg + 1) if (beta.fixed==1) var.score<-matrix(nparout[[56]],Ntimes,pg+1) gammaiid <-t( matrix(nparout[[43]],pg,fdata$antclust * 1)) gamiid<-matrix(nparout[[52]],fdata$antclust,pg); if (resample.iid==1) { biid<-matrix(nparout[[53]],mts,fdata$antclust*px); B.iid<-list(); for (i in (0:(fdata$antclust-1))*px) { B.iid[[i/px+1]]<-as.matrix(biid[,i+(1:px)]); colnames(B.iid[[i/px+1]])<-namesX; } colnames(gamiid)<-namesZ } else B.iid<-gamiid<-NULL; if (covariance == 1) { covit <- matrix(nparout[[48]], mts, px * px) cov.list <- list() for (i in 1:mts) cov.list[[i]] <- matrix(covit[i,], px, px) } else cov.list <- NULL if (residuals == 1) cumAi <- matrix(nparout[[42]],Ntimes,fdata$antpers * 1) ### if (residuals == 1) dNit <- matrix(nparout[[40]],Ntimes,fdata$antpers * 1) if (residuals == 2) cumAi <- nparout[[42]] cumAi <- list(time = times, dM = cumAi) testUt <- test <- unifCI <- supUtOBS <- UIt <- testOBS <- testval <- pval.testBeq0 <- pval.testBeqC <- obs.testBeq0 <- obs.testBeqC <- sim.testBeq0 <- sim.testBeqC <- testUt <- sim.supUt <- NULL if (antsim>0) { Uit <- matrix(nparout[[32]], mts, 50 * pg) UIt <- list() for (i in (0:49) * pg) UIt[[i/pg + 1]] <- as.matrix(Uit[, i + (1:pg)]) simUt <- matrix(nparout[[31]], antsim, pg) supUtOBS <- apply(abs(as.matrix(Ut[, -1])), 2, max) testUt <- c() for (i in 1:pg) testUt <- c(testUt, pval(simUt[, i], supUtOBS[i])) sim.supUt <- as.matrix(simUt) if (basesim[1]>0) { test <- matrix(nparout[[28]], antsim, 2 * px) testOBS <- nparout[[29]] for (i in 1:(2 * px)) testval <- c(testval, pval(test[, i], testOBS[i])) for (i in 1:px) unifCI <- c(unifCI, percen(test[, i], 0.95)) pval.testBeq0 <- as.vector(testval[1:px]) pval.testBeqC <- as.vector(testval[(px + 1):(2 * px)]) obs.testBeq0 <- as.vector(testOBS[1:px]) obs.testBeqC <- as.vector(testOBS[(px + 1):(2 * px)]) sim.testBeq0 <- as.matrix(test[, 1:px]) sim.testBeqC <- as.matrix(test[, (px + 1):(2 * px)]) } } if (additive.resamp == 1) { baseproc <- matrix(nparout[[50]], mts, 50 * pg) additive.proc <- list() for (i in (0:49) * px) additive.proc[[i/px+1]]<-as.matrix(baseproc[,i+(1:px)]) } else additive.proc <- NULL if (robust==0 & beta.fixed==0) var.score<-NULL; ud <- list(cum = cumint, var.cum = vcum, robvar.cum = Rvcu, gamma = gamma, var.gamma = Varbeta, robvar.gamma = RVarbeta, residuals = cumAi, loglike = nparout[[18]], D2linv = Iinv, score = score, var.score=var.score, pval.testBeq0 = pval.testBeq0, pval.testBeqC = pval.testBeqC, obs.testBeq0 = obs.testBeq0, obs.testBeqC = obs.testBeqC, sim.testBeq0 = sim.testBeq0, sim.testBeqC = sim.testBeqC, conf.band = unifCI, test.procProp = Ut, sim.test.procProp = UIt, pval.Prop = testUt, sim.supProp = sim.supUt, covariance = cov.list, B.iid=B.iid,gamma.iid=gammaiid,time.sim.resolution=qq,stratum=stratum) return(ud) } ## }}} timereg/R/new.pe-sasieni.r0000644000176200001440000002216514421510301015114 0ustar liggesusers#' Fits Proportional excess hazards model with fixed offsets #' #' Fits proportional excess hazards model. The Sasieni proportional excess risk #' model. #' #' The models are written using the survival modelling given in the survival #' package. #' #' The program assumes that there are no ties, and if such are present random #' noise is added to break the ties. #' #' @aliases pe.sasieni summary.pe-sasieni #' @param formula a formula object, with the response on the left of a `~' #' operator, and the terms on the right. The response must be a survival #' object as returned by the `Surv' function. #' @param data a data.frame with the variables. #' @param id gives the number of individuals. #' @param start.time starting time for considered time-period. #' @param max.time stopping considered time-period if different from 0. #' Estimates thus computed from [0,max.time] if max.time>0. Default is max of #' data. #' @param offsets fixed offsets giving the mortality. #' @param Nit number of itterations. #' @param detail if detail is one, prints iteration details. #' @param n.sim number of simulations, 0 for no simulations. #' @return Returns an object of type "pe.sasieni". With the following #' arguments: \item{cum}{baseline of Cox model excess risk.} #' \item{var.cum}{pointwise variance estimates for estimated cumulatives.} #' \item{gamma}{estimate of relative risk terms of model.} #' \item{var.gamma}{variance estimates for gamma.} \item{Ut}{score process for #' Cox part of model.} \item{D2linv}{The inverse of the second derivative.} #' \item{score}{final score} \item{test.Prop}{re-sampled absolute supremum #' values.} \item{pval.Prop}{p-value based on resampling.} #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer Verlag (2006). #' #' Sasieni, P.D., Proportional excess hazards, Biometrika (1996), 127--41. #' #' Cortese, G. and Scheike, T.H., Dynamic regression hazards models for #' relative survival (2007), submitted. #' @keywords survival #' @examples #' #' data(mela.pop) #' out<-pe.sasieni(Surv(start,stop,status==1)~age+sex,mela.pop, #' id=1:205,Nit=10,max.time=7,offsets=mela.pop$rate,detail=0,n.sim=100) #' summary(out) #' #' ul<-out$cum[,2]+1.96*out$var.cum[,2]^.5 #' ll<-out$cum[,2]-1.96*out$var.cum[,2]^.5 #' plot(out$cum,type="s",ylim=range(ul,ll)) #' lines(out$cum[,1],ul,type="s"); lines(out$cum[,1],ll,type="s") #' # see also prop.excess function #' #' @export pe.sasieni<-function (formula = formula(data),data = parent.frame(), id=NULL,start.time=0,max.time=NULL,offsets=0,Nit=50,detail=0,n.sim=500) { call <- match.call() m <- match.call(expand.dots = FALSE) m$id<-m$Nit<-m$detail<-m$start.time <- m$max.time <- m$offsets<-m$n.sim <- NULL 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()) mt <- attr(m, "terms") intercept <- attr(mt, "intercept") Y <- model.extract(m, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") XZ<-model.matrix(Terms,m)[, drop = FALSE] cols<-attributes(XZ)$assign l.cols<-length(cols) X<-as.matrix(XZ[,1]); covnamesX <- dimnames(XZ)[[2]][1]; dimnames(X)[[2]]<-covnamesX; Z<-as.matrix(XZ[,-1]); covnamesZ <- dimnames(XZ)[[2]][-1]; px <- ncol(X); pz <- ncol(Z); pxz <- px + pz if ( (nrow(X)!=nrow(data)) & (!is.null(id))) stop("Missing values in design matrix not allowed with id \n"); ### if (nrow(Z)!=nrow(data)) stop("Missing values in design matrix not allowed\n"); if (attr(m[, 1], "type") == "right") { X <- data.matrix(X); Z <- data.matrix(Z); time2 <- m[, 1][, "time"]; time <- rep(0, length(time2)) status <- m[, 1][, "status"] } else if (attr(m[, 1], "type") == "counting") { X <- data.matrix(X); Z <- data.matrix(Z) ; time <- m[, 1][, 1]; time2 <- m[, 1][, 2]; status <- m[, 1][, 3] } else { stop("only right-censored or counting processes data") } if (sum(duplicated(time2[status==1]))>0) { #cat("Non unique survival times: break ties ! \n") # cat("Break ties yourself\n"); ties<-TRUE dtimes<-time2[status==1] index<-(1:length(time2))[status==1] ties<-duplicated(dtimes); nties<-sum(ties); index<-index[ties] dt<-diff(sort(time2)); dt<-min(dt[dt>0]); time2[index]<-time2[index]+runif(nties,0,min(0.001,dt/2)); } else ties<-FALSE; times<-unique(time2); times <- c(start.time, times[times>start.time]); times <- sort(times) if (is.null(max.time) == TRUE) maxtimes <- max(times) else maxtimes <- max.time times<-times[times<=maxtimes]; times<-c(times,maxtimes) times<-unique(times); Ntimes <- length(times); ldata <- list(start = time, stop =time2) ntot <- ncol(XZ); px <- ncol(X) Nalltimes <- length(times); Ntimes<-sum(status[(time2>times[1]) & (time2<=times[Nalltimes])])+1; X<-as.matrix(X); Z<-as.matrix(Z); px <- as.integer(dim(X)[2]); nx <- as.integer(dim(X)[1]); pg <- as.integer(dim(Z)[2]); ng <- as.integer(dim(Z)[1]); if (length(offsets)==1) mof<-0 else mof<-1; mw<-0; weights<-rep(1,nx); cum<-Vcum<-matrix(0,Ntimes,px+1); Ut<-matrix(0,Nalltimes,pg+1); gamma<-intZHdN<-rep(0,pg); Vargam<-intZHZ<-matrix(0,pg,pg); antpers<-length(unique(id)) dUt<-matrix(0,Ntimes,pg*pg); if (n.sim >0) {testOBS<-rep(0,pg); test<-matrix(0,n.sim,pg);} else {testOBS<-0; test<-0;} rani<- -round(runif(1)*10000) #dyn.load("pes.so"); semiout<-.C("pes", as.double(times),as.integer(Nalltimes),as.integer(Ntimes), as.double(X),as.integer(nx),as.integer(px), as.double(Z),as.integer(ng),as.integer(pg), as.integer(antpers),as.double(time),as.double(time2), as.double(cum),as.double(Vcum),as.double(gamma), as.double(Vargam),as.integer(status),as.double(Ut), as.double(intZHZ),as.double(intZHdN),as.integer(mof), as.double(offsets),as.integer(mw),as.double(weights), as.integer(Nit),as.integer(detail), as.integer(rani),as.integer(n.sim),as.double(test), PACKAGE="timereg"); cum <-matrix(semiout[[13]],Ntimes,px+1); Vcum <-matrix(semiout[[14]],Ntimes,px+1); gamma<-matrix(semiout[[15]],pg,1); Vargam<-matrix(semiout[[16]],pg,pg); intZHZ<-matrix(semiout[[19]],pg,pg); intZHdN<-matrix(semiout[[20]],pg,1); Ut<-matrix(semiout[[18]],Nalltimes,pg+1); #dUt<-matrix(semiout[[27]],Ntimes,pg*pg); dUt.list<-list(); #for (i in 1:Ntimes) dUt.list[[i]]<-matrix(dUt[i,],pg,pg); if (n.sim>0) {test<-matrix(semiout[[29]],n.sim,pg); testOBS<-apply(abs(Ut),2,max)[-1]; testval<-c(); for (i in 1:pg) testval<-c(testval,pval(test[,i],testOBS[i])); pval.Prop<-testval; names(pval.Prop) <- names(testOBS)<-covnamesZ } else {pval.Prop<-NULL;testOBS<-NULL;} ud<-list(cum=cum,var.cum=Vcum,gamma=gamma,var.gamma=Vargam, Ut=Ut,D2linv=intZHZ,score=intZHdN,test.Prop=testOBS,pval.Prop=pval.Prop); colnames(ud$cum) <- colnames(ud$var.cum) <- c("time", covnamesX) ud$gamma<-as.matrix(ud$gamma); rownames(ud$gamma) <- c(covnamesZ) colnames(ud$gamma) <- "estimate" colnames(ud$var.gamma) <- c(covnamesZ) rownames(ud$var.gamma) <- c(covnamesZ) rownames(ud$score) <- c(covnamesZ) colnames(ud$D2linv) <- c(covnamesZ) attr(ud, "Call") <- call attr(ud, "Formula") <- formula attr(ud, "start") <- start.time attr(ud, "time2") <- time2 class(ud) <- "pe.sasieni" ud$call<-call return(ud) } #' @export summary.pe.sasieni <- function (object,digits=3,...) { obj <- object; rm(object); if (!inherits(obj, 'pe.sasieni')) stop ("Must be a Proportional Excess Survival Model object based") if (is.null(obj$gamma)==TRUE) stop(" No proportional terms"); cat("\nProportional Excess Survival Model \n\n") cat("Proportional terms: \n"); res <- cbind(obj$gamma,diag(obj$var.gamma)^.5) z<-c((res[,1]/res[,2])); pval<-1-pchisq(z^2,1) res<-as.matrix(cbind(res,z,pval)); colnames(res) <- c("coef", "se(coef)","z","p") prmatrix(signif(res, digits)); cat(" \n"); if (is.null(obj$pval.Prop)==TRUE) ptest<-FALSE else ptest<-TRUE; if (ptest==TRUE) { cat("Test for Proportionality\n"); testP<-cbind(obj$test.Prop,obj$pval.Prop); testP<-as.matrix(testP); colnames(testP) <- c("sup| hat U(t) |","p-value H_0 ") prmatrix(signif(testP,digits)); cat("\n"); } cat(" Call: "); dput(attr(obj, "Call")); cat("\n") } #' @export print.pe.sasieni <- function (x,digits=3,...) { obj <- x; rm(x); if (!inherits(obj, 'pe.sasieni')) stop ("Must be a Proportional Excess Survival Model object based") if (is.null(obj$gamma)==TRUE) stop(" No proportional terms"); if (is.null(obj$gamma)==TRUE) cox<-FALSE else cox<-TRUE cat(" Proportional Excess Survival Model,\n using Sasieni proportional excess risk \n\n") cat(" Nonparametric terms: "); cat(colnames(obj$cum)[-1]); cat(" \n"); if (cox) { cat(" Proportional terms: "); cat(rownames(obj$gamma)); cat(" \n"); } cat(" \n"); cat(" Call: "); dput(attr(obj, "Call")); cat("\n") } timereg/R/Gprop-odds.r0000644000176200001440000003124414421510301014303 0ustar liggesusers#' Fit Generalized Semiparametric Proportional 0dds Model #' #' Fits a semiparametric proportional odds model: \deqn{ logit(1-S_{X,Z}(t)) = #' log(X^T A(t)) + \beta^T Z } where A(t) is increasing but otherwise #' unspecified. Model is fitted by maximising the modified partial likelihood. #' A goodness-of-fit test by considering the score functions is also computed #' by resampling methods. #' #' An alternative way of writing the model : \deqn{ S_{X,Z}(t)) = \frac{ \exp( #' - \beta^T Z )}{ (X^T A(t)) + \exp( - \beta^T Z) } } such that \eqn{\beta} is #' the log-odds-ratio of dying before time t, and \eqn{A(t)} is the odds-ratio. #' #' The modelling formula uses the standard survival modelling given in the #' \bold{survival} package. #' #' The data for a subject is presented as multiple rows or "observations", each #' of which applies to an interval of observation (start, stop]. The program #' essentially assumes no ties, and if such are present a little random noise #' is added to break the ties. #' #' @param formula a formula object, with the response on the left of a '~' #' operator, and the terms on the right. The response must be a survival #' object as returned by the `Surv' function. #' @param data a data.frame with the variables. #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. This is very useful to #' obtain stable estimates, especially for the baseline. Default is max of #' data. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing time-varying effects. #' @param beta starting value for relative risk estimates #' @param Nit number of iterations for Newton-Raphson algorithm. #' @param detail if 0 no details is printed during iterations, if 1 details are #' given. #' @param sym to use symmetrized second derivative in the case of the #' estimating equation approach (profile=0). This may improve the numerical #' performance. #' @param mle.start starting values for relative risk parameters. #' @return returns an object of type 'cox.aalen'. With the following arguments: #' #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval.} \item{var.cum}{the martingale #' based pointwise variance estimates. } \item{robvar.cum}{robust pointwise #' variances estimates. } \item{gamma}{estimate of proportional odds #' parameters of model.} \item{var.gamma}{variance for gamma. } #' \item{robvar.gamma}{robust variance for gamma. } \item{residuals}{list with #' residuals. Estimated martingale increments (dM) and corresponding time #' vector (time).} \item{obs.testBeq0}{observed absolute value of supremum of #' cumulative components scaled with the variance.} #' \item{pval.testBeq0}{p-value for covariate effects based on supremum test.} #' \item{sim.testBeq0}{resampled supremum values.} \item{obs.testBeqC}{observed #' absolute value of supremum of difference between observed cumulative process #' and estimate under null of constant effect.} \item{pval.testBeqC}{p-value #' based on resampling.} \item{sim.testBeqC}{resampled supremum values.} #' \item{obs.testBeqC.is}{observed integrated squared differences between #' observed cumulative and estimate under null of constant effect.} #' \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{sim.testBeqC.is}{resampled supremum values.} #' \item{conf.band}{resampling based constant to construct robust 95\% uniform #' confidence bands. } \item{test.procBeqC}{observed test-process of difference #' between observed cumulative process and estimate under null of constant #' effect over time.} \item{loglike}{modified partial likelihood, pseudo #' profile likelihood for regression parameters.} \item{D2linv}{inverse of the #' derivative of the score function.} \item{score}{value of score for final #' estimates.} \item{test.procProp}{observed score process for proportional #' odds regression effects.} \item{pval.Prop}{p-value based on resampling.} #' \item{sim.supProp}{re-sampled supremum values.} #' \item{sim.test.procProp}{list of 50 random realizations of test-processes #' for constant proportional odds under the model based on resampling.} #' @author Thomas Scheike #' @references Scheike, A flexible semiparametric transformation model for #' survival data, Lifetime Data Anal. (to appear). #' #' Martinussen and Scheike, Dynamic Regression Models for Survival Data, #' Springer (2006). #' @keywords survival #' @examples #' #' data(sTRACE) #' \donttest{ #' ### runs slowly and is therefore donttest #' data(sTRACE) #' # Fits Proportional odds model with stratified baseline #' age.c<-scale(sTRACE$age,scale=FALSE); #' ## out<-Gprop.odds(Surv(time,status==9)~-1+factor(diabetes)+prop(age.c)+prop(chf)+ #' ## prop(sex)+prop(vf),data=sTRACE,max.time=7,n.sim=50) #' ## summary(out) #' ## par(mfrow=c(2,3)) #' ## plot(out,sim.ci=2); plot(out,score=1) #' #' } #' #' @export Gprop.odds<-function(formula=formula(data),data=parent.frame(),beta=0,Nit=50,detail=0,start.time=0,max.time=NULL,id=NULL,n.sim=500,weighted.test=0,sym=0,mle.start=0) { id.call<-id; call<-match.call(); residuals<-0; robust<-0; ratesim<-0; profile<-0; exppar<-0; m<-match.call(expand.dots = FALSE); m$max.time<-m$start.time<-m$weighted.test<-m$n.sim<-m$id<-m$Nit<-m$detail<-m$beta<-m$sym<-m$mle.start<-NULL if (n.sim==0) sim<-0 else sim<-1; antsim<-n.sim; special <- c("prop") Terms <- if(missing(data)) terms(formula, special) else terms(formula, special, data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m, "response") XZ<-model.matrix(Terms,m)[, drop = FALSE] cols<-attributes(XZ)$assign l.cols<-length(cols) semicov <- attr(Terms, "specials")$prop ZtermsXZ<-semicov-1 # print("semiterms"); print(semicov-1); if (length(semicov)) { renaalen<-FALSE; Zterms<-c(); for (i in ZtermsXZ) Zterms<-c(Zterms,(1:l.cols)[cols==i]); } else {renaalen<-TRUE;} if (length(semicov)) { X<-as.matrix(XZ[,-Zterms]); covnamesZ <- dimnames(XZ)[[2]][-Zterms]; dimnames(X)[[2]]<-covnamesZ; Z<-as.matrix(XZ[,Zterms]); covnamesX <- dimnames(XZ)[[2]][Zterms]; dimnames(Z)[[2]]<-covnamesX; } else {X<-as.matrix(XZ); covnamesZ<-dimnames(XZ)[[2]]} if ((nrow(X)!=nrow(data)) && (!is.null(id))) stop("Missing values in design matrix not allowed with id\n"); # print("X"); print(X[1,]); print(covnamesX); # if (renaalen==FALSE) {print("Z"); print(Z[1,]); # print(covnamesZ); # } px <- ncol(X) if (renaalen == FALSE) pz <- ncol(Z) else pz <- 0 pxz <- px + pz desX<-as.matrix(Z); if(is.matrix(desX) == TRUE) pg <- as.integer(dim(desX)[2]) if(is.matrix(desX) == TRUE) nx <- as.integer(dim(desX)[1]) desZ<-as.matrix(X); px<-ncol(desZ); if (is.diag( t(desZ) %*% desZ )==TRUE) stratum <- 1 else stratum <- 0 if (!inherits(Y, "Surv")) stop("Response must be a survival object") if (attr(m[, 1], "type") == "right") { time2 <- m[, 1][, "time"]; time <- rep(0,length(time2)); status <- m[, 1][, "status"] } else if (attr(m[, 1], "type") == "counting") { time <- m[, 1][,1]; time2 <- m[, 1][,2]; status <- m[, 1][,3]; } else { stop("only right-censored or counting processes data") } Ntimes <- sum(status); # adds random noise to make survival times unique if (sum(duplicated(time2[status==1]))>0) { #cat("Non unique survival times: break ties ! \n") #cat("Break ties yourself\n"); ties<-TRUE dtimes<-time2[status==1]; index<-(1:length(time2))[status==1]; ties<-duplicated(dtimes); nties<-sum(ties); index<-index[ties] dt<-diff(sort(time2)); dt<-min(dt[dt>0]); time2[index]<-time2[index]+runif(nties,0,min(0.001,dt/2)); } else ties<-FALSE; start<-time; stop<-time2; times<-c(start.time,time2[status==1]); times<-sort(times); if (is.null(max.time)) maxtimes<-max(times)+0.1 else maxtimes<-max.time; times<-times[times0) { if (sim==1) { colnames(ud$test.procProp)<-c("time",covnamesX) names(ud$pval.Prop)<-covnamesX names(ud$conf.band)<-names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<-names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<-colnames(ud$sim.testBeq0)<-covnamesZ; } } rownames(ud$gamma)<-c(covnamesX); colnames(ud$gamma)<-"estimate"; rownames(ud$score)<-c(covnamesX); colnames(ud$score)<-"score"; namematrix(ud$var.gamma,covnamesX); namematrix(ud$robvar.gamma,covnamesX); namematrix(ud$D2linv,covnamesX); attr(ud,"Call")<-call; attr(ud,"Formula")<-formula; attr(ud,"id")<-id.call; class(ud)<-"cox.aalen" return(ud); } timereg/R/new.aalen.r0000644000176200001440000004632714421510301014145 0ustar liggesusers#' Fit additive hazards model #' #' Fits both the additive hazards model of Aalen and the semi-parametric #' additive hazards model of McKeague and Sasieni. Estimates are un-weighted. #' Time dependent variables and counting process data (multiple events per #' subject) are possible. #' #' Resampling is used for computing p-values for tests of time-varying effects. #' #' The modelling formula uses the standard survival modelling given in the #' \bold{survival} package. #' #' The data for a subject is presented as multiple rows or 'observations', each #' of which applies to an interval of observation (start, stop]. For counting #' process data with the )start,stop] notation is used, the 'id' variable is #' needed to identify the records for each subject. The program assumes that #' there are no ties, and if such are present random noise is added to break #' the ties. #' #' @param formula a formula object with the response on the left of a '~' #' operator, and the independent terms on the right as regressors.The response #' must be a survival object as returned by the `Surv' function. Time- #' invariant regressors are specified by the wrapper const(), and cluster #' variables (for computing robust variances) by the wrapper cluster(). #' @param data a data.frame with the variables. #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. Default is max of data. #' @param robust to compute robust variances and construct processes for #' resampling. May be set to 0 to save memory. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param clusters cluster variable for computation of robust variances. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing time-varying effects. #' @param residuals to returns residuals that can be used for model validation #' in the function cum.residuals #' @param covariance to compute covariance estimates for nonparametric terms #' rather than just the variances. #' @param resample.iid to return i.i.d. representation for nonparametric and #' parametric terms. #' @param deltaweight uses weights to estimate semiparametric model, under #' construction, default=1 is standard least squares estimates #' @param silent set to 0 to print warnings for non-inverible design-matrices #' for different timepoints, default is 1. #' @param weights weights for estimating equations. #' @param max.clust sets the total number of i.i.d. terms in i.i.d. #' decompostition. This can limit the amount of memory used by coarsening the #' clusters. When NULL then all clusters are used. Default is 1000 to save #' memory and time. #' @param gamma fixes gamme at this value for estimation. #' @param offsets offsets for the additive model, to make excess risk #' modelling. #' @param caseweight caseweight: mutiplied onto dN for score equations. #' @return returns an object of type "aalen". With the following arguments: #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval. } \item{var.cum}{the martingale #' based pointwise variance estimates for cumulatives.} #' \item{robvar.cum}{robust pointwise variances estimates for cumulatives.} #' \item{gamma}{estimate of parametric components of model. } #' \item{var.gamma}{variance for gamma. } \item{robvar.gamma}{robust variance #' for gamma. } \item{residuals}{list with residuals. Estimated martingale #' increments (dM) and corresponding time vector (time).} #' \item{obs.testBeq0}{observed absolute value of supremum of cumulative #' components scaled with the variance.} \item{pval.testBeq0}{p-value for #' covariate effects based on supremum test.} \item{sim.testBeq0}{resampled #' supremum values.} \item{obs.testBeqC}{observed absolute value of supremum of #' difference between observed cumulative process and estimate under null of #' constant effect.} \item{pval.testBeqC}{p-value based on resampling.} #' \item{sim.testBeqC}{resampled supremum values.} #' \item{obs.testBeqC.is}{observed integrated squared differences between #' observed cumulative and estimate under null of constant effect.} #' \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{sim.testBeqC.is}{resampled supremum values.} #' \item{conf.band}{resampling based constant to construct robust 95\% uniform #' confidence bands. } \item{test.procBeqC}{observed test-process of difference #' between observed cumulative process and estimate under null of constant #' effect over time. } \item{sim.test.procBeqC}{list of 50 random realizations #' of test-processes under null based on resampling.} #' \item{covariance}{covariances for nonparametric terms of model.} #' \item{B.iid}{Resample processes for nonparametric terms of model.} #' \item{gamma.iid}{Resample processes for parametric terms of model.} #' \item{deviance}{Least squares of increments.} #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' data(sTRACE) #' # Fits Aalen model #' out<-aalen(Surv(time,status==9)~age+sex+diabetes+chf+vf, #' sTRACE,max.time=7,n.sim=100) #' #' summary(out) #' par(mfrow=c(2,3)) #' plot(out) #' #' # Fits semi-parametric additive hazards model #' out<-aalen(Surv(time,status==9)~const(age)+const(sex)+const(diabetes)+chf+vf, #' sTRACE,max.time=7,n.sim=100) #' #' summary(out) #' par(mfrow=c(2,3)) #' plot(out) #' #' ## Excess risk additive modelling #' data(mela.pop) #' dummy<-rnorm(nrow(mela.pop)); #' #' # Fits Aalen model with offsets #' out<-aalen(Surv(start,stop,status==1)~age+sex+const(dummy), #' mela.pop,max.time=7,n.sim=100,offsets=mela.pop$rate,id=mela.pop$id, #' gamma=0) #' summary(out) #' par(mfrow=c(2,3)) #' plot(out,main="Additive excess riks model") #' #' # Fits semi-parametric additive hazards model with offsets #' out<-aalen(Surv(start,stop,status==1)~age+const(sex), #' mela.pop,max.time=7,n.sim=100,offsets=mela.pop$rate,id=mela.pop$id) #' summary(out) #' plot(out,main="Additive excess riks model") #' ##' @export aalen<-function (formula = formula(data), data = parent.frame(), start.time = 0, max.time = NULL, robust=1, id=NULL, clusters=NULL, residuals = 0, n.sim = 1000, weighted.test= 0,covariance=0,resample.iid=0, deltaweight=1,silent=1,weights=NULL,max.clust=1000, gamma=NULL,offsets=0,caseweight=NULL){ ## {{{ ## {{{ setting up variables if (n.sim == 0) sim <- 0 else sim <- 1 if (resample.iid==1 & robust==0) { robust <- 1;} if (covariance==1 & robust==0) { covariance<-0;} if (sim==1 & robust==0) { n.sim<-0;sim <- 0} if (n.sim>0 & n.sim<50) {n.sim<-50 ; cat("Minimum 50 simulations\n");} call <- match.call() m <- match.call(expand.dots = FALSE) m$start.time <- m$weighted.test <- m$max.time <- m$robust <- m$weights <- m$residuals <- m$n.sim <- m$id <- m$covariance <- m$resample.iid <- m$clusters <- m$deltaweight<-m$silent <- m$max.clust <- m$gamma <- m$offsets <- m$caseweight <- NULL special <- c("const","cluster") Terms <- if (missing(data)){ terms(formula, special) } else { terms(formula, special, data = data) } m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept <- attr(mt, "intercept") Y <- model.extract(m, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") des<-read.design(m,Terms) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ if(is.null(clusters)) clusters <- des$clusters ########## pxz <- px + pz; if ((nrow(X)!=nrow(data) && (!is.null(id)))) stop("Missing values in design matrix not allowed with id \n"); ### if (nrow(Z)!=nrow(data)) stop("Missing values in design matrix not allowed\n"); if (!is.null(id)) { if (length(id)!=nrow(X)) stop("id length and data not the same\n"); } cluster.call<- clusters; survs<-read.surv(m,id,npar,clusters,start.time,max.time,silent=silent) times<-survs$times; id<-survs$id.cal; id.call<-id; clusters<-gclusters <- survs$clusters; stop.call <- time2<-survs$stop start.call <- survs$start status<-survs$status; orig.max.clust <- survs$antclust dtimes <- sort(survs$stop[survs$status==1]) nobs <- nrow(X); if (is.null(weights)) weights <- rep(1,nrow(X)); weights.call <- weights; if ((!is.null(max.clust))) if (max.clust= 1) { colnames(ud$test.procBeqC) <- c("time", covnamesX) names(ud$conf.band) <- names(ud$pval.testBeq0) <- names(ud$pval.testBeqC) <- names(ud$pval.testBeqC.is) <- names(ud$obs.testBeq0) <- names(ud$obs.testBeqC) <- names(ud$obs.testBeqC.is) <- colnames(ud$sim.testBeq0) <- colnames(ud$sim.testBeqC) <- colnames(ud$sim.testBeqC.is) <- covnamesX ud$sim.testBeqC.is <- ud$sim.testBeqC <- FALSE } } ## }}} else { ## {{{ Semiparametric additive risk model if (px == 0) stop("No nonparametric terms (needs one!)") ud<-semiaalen(times, ldata, X, Z, status, id , clusters, robust = robust, sim = sim, antsim = n.sim, weighted.test = weighted.test, retur = residuals,covariance=covariance, resample.iid=resample.iid,namesX=covnamesX,namesZ=covnamesZ, deltaweight=deltaweight,gamma=gamma, silent=silent,weights=weights,entry=entry,offsets=offsets,caseweight=caseweight) if (px > 0) { colnames(ud$cum) <- colnames(ud$var.cum) <- c("time", covnamesX) if (robust == 1) colnames(ud$robvar.cum) <- c("time", covnamesX) if (sim >= 1) { colnames(ud$test.procBeqC) <- c("time", covnamesX) names(ud$conf.band) <- names(ud$pval.testBeq0) <- names(ud$pval.testBeqC) <- names(ud$pval.testBeqC.is) <- names(ud$obs.testBeqC.is) <- names(ud$obs.testBeq0) <- names(ud$obs.testBeqC) <- colnames(ud$sim.testBeq0) <- colnames(ud$sim.testBeqC.is) <- colnames(ud$sim.testBeqC) <- covnamesX ud$sim.testBeqC.is <- ud$sim.testBeqC <- FALSE } } ud$gamma<-as.matrix(ud$gamma); rownames(ud$gamma) <- c(covnamesZ) rownames(ud$intZHdN) <- c(covnamesZ) colnames(ud$gamma) <- "estimate" colnames(ud$var.gamma) <- c(covnamesZ) rownames(ud$var.gamma) <- c(covnamesZ) colnames(ud$robvar.gamma) <- c(covnamesZ) colnames(ud$intZHZ) <- c(covnamesZ) rownames(ud$var.gamma) <- c(covnamesZ) } ## }}} attr(ud,"stratum")<-ud$stratum; attr(ud, "Call") <- call attr(ud, "Formula") <- formula attr(ud, "id") <- id.call attr(ud, "cluster.call") <- cluster.call attr(ud, "cluster") <- gclusters attr(ud, "start.time") <- start.time attr(ud, "stop") <- stop.call attr(ud, "start") <- start.call attr(ud, "status") <- survs$status attr(ud, "residuals") <- residuals attr(ud, "max.clust") <- max.clust; attr(ud, "max.time") <- max.time; attr(ud, "weights") <- weights.call; attr(ud, "orig.max.clust") <- orig.max.clust class(ud) <- "aalen" ud$call<-call return(ud) } ## }}} #' Plots estimates and test-processes #' #' This function plots the non-parametric cumulative estimates for the additive #' risk model or the test-processes for the hypothesis of time-varying effects #' with re-sampled processes under the null. #' #' #' @aliases plot.aalen plot.cox.aalen plot.timecox plot.prop.excess #' @param x the output from the "aalen" function. #' @param pointwise.ci if >1 pointwise confidence intervals are plotted with #' lty=pointwise.ci #' @param hw.ci if >1 Hall-Wellner confidence bands are plotted with lty=hw.ci. #' Only 0.95 \% bands can be constructed. #' @param sim.ci if >1 simulation based confidence bands are plotted with #' lty=sim.ci. These confidence bands are robust to non-martingale behaviour. #' @param robust.ci robust standard errors are used to estimate standard error #' of estimate, otherwise martingale based standard errors are used. #' @param col specifice colors of different components of plot, in order: #' c(estimate,pointwise.ci,robust.ci,hw.ci,sim.ci) so for example, when we ask #' to get pointwise.ci, hw.ci and sim.ci we would say c(1,2,3,4) to use colors #' as specified. #' @param specific.comps all components of the model is plotted by default, but #' a list of components may be specified, for example first and third "c(1,3)". #' @param level gives the significance level. #' @param start.time start of observation period where estimates are plotted. #' @param stop.time end of period where estimates are plotted. Estimates thus #' plotted from [start.time, max.time]. #' @param add.to.plot to add to an already existing plot. #' @param mains add names of covariates as titles to plots. #' @param xlab label for x-axis. #' @param ylab label for y-axis. #' @param score to plot test processes for test of time-varying effects along #' with 50 random realization under the null-hypothesis. #' @param ... unused arguments - for S3 compatibility #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' # see help(aalen) #' data(sTRACE) #' out<-aalen(Surv(time,status==9)~chf+vf,sTRACE,max.time=7,n.sim=100) #' par(mfrow=c(2,2)) #' plot(out,pointwise.ci=1,hw.ci=1,sim.ci=1,col=c(1,2,3,4)) #' par(mfrow=c(2,2)) #' plot(out,pointwise.ci=0,robust.ci=1,hw.ci=1,sim.ci=1,col=c(1,2,3,4)) #' ##' @export plot.aalen <- function (x, pointwise.ci=1, hw.ci=0, sim.ci=0, robust.ci=0, col=NULL, specific.comps=FALSE,level=0.05, start.time = 0, stop.time = 0, add.to.plot=FALSE, mains=TRUE, xlab="Time", ylab ="Cumulative coefficients",score=FALSE,...) { ## {{{ object <- x; rm(x); if (!inherits(object,'aalen') ) stop ("Must be output from Aalen function") if (score==FALSE) plot.cums(object, pointwise.ci=pointwise.ci, hw.ci=hw.ci, sim.ci=sim.ci, robust.ci=robust.ci, col=col, specific.comps=specific.comps,level=level, start.time = start.time, stop.time = stop.time, add.to.plot=add.to.plot, mains=mains, xlab=xlab, ylab =ylab,...) else plotScore(object, specific.comps=specific.comps, mains=mains, xlab=xlab,ylab =ylab,...); } ## }}} ##' @export vcov.aalen <- function(object,robust=0, ...) { if (robust==0) rv <- object$var.gamma else rv <- object$robvar.gamma if (!identical(rv, matrix(0, nrow = 1L, ncol = 1L))) rv # else return NULL } #' Prints call #' #' Prints call for object. Lists nonparametric and parametric terms of model #' #' #' @aliases print.aalen print.cox.aalen print.comprisk print.prop.excess #' print.dynreg print.timecox print.cum.residuals #' @param x an aalen object #' @param ... unused arguments - for S3 compatibility #' @author Thomas Scheike #' @keywords survival ##' @export "print.aalen" <- function (x,...) { ## {{{ summary.aalen(x,...) ### object <- x; rm(x); ### if (!inherits(object, 'aalen')) stop ("Must be an aalen object") ### ### if (is.null(object$gamma)==TRUE) semi<-FALSE else semi<-TRUE ### ### # We print information about object: ### ### cat("Additive Aalen Model \n\n") ### cat(" Nonparametric terms : "); cat(colnames(object$cum)[-1]); cat(" \n"); ### if (semi) { ### cat(" Parametric terms : "); cat(rownames(object$gamma)); ### cat(" \n"); } ### cat(" \n"); ### ### cat(" Call: \n"); dput(attr(object, "Call")); cat("\n"); } ## }}} #' Prints summary statistics #' #' Computes p-values for test of significance for nonparametric terms of model, #' p-values for test of constant effects based on both supremum and integrated #' squared difference. #' #' Returns parameter estimates and their standard errors. #' #' #' @aliases summary.aalen summary.cox.aalen summary.prop.excess summary.timecox #' summary.dynreg #' @param object an aalen object. #' @param digits number of digits in printouts. #' @param ... unused arguments - for S3 compatibility #' @author Thomas Scheike #' @references Martinussen and Scheike, #' @keywords survival #' @examples #' #' ### see help(aalen) #' ##' @export "summary.aalen" <- function (object,digits = 3,...) { ## {{{ aalen.object <- object; rm(object); obj<-aalen.object if (!inherits(aalen.object, 'aalen')) stop ("Must be an aalen object") if (is.null(aalen.object$gamma)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: cat("Additive Aalen Model \n\n") #cat("Nonparametric terms : "); cat(colnames(aalen.object$cum)[-1]); #cat(" \n"); timetest(obj,digits=digits); if (semi) { cat("Parametric terms : "); #cat(rownames(aalen.object$gamma)); } cat(" \n"); if (semi) { out=coef.aalen(aalen.object,digits=digits); out=signif(out,digits=digits) print(out) if (is.null(aalen.object$pstest.pval)==FALSE) { res<-cbind(aalen.object$sup.pscore,aalen.object$pstest.pval); colnames(res)<-c("sup of pseudo-score test","p-value H_0: B(t)=b t"); cat(" \n"); cat("Test for time invariant effects \n") prmatrix(signif(res,digits)) } } cat(" \n"); cat(" Call: \n") dput(attr(aalen.object, "Call")) cat("\n") } ## }}} ##' @export coef.aalen <- function(object, digits=3,...) { coefBase(object,digits=digits,...) } timereg/R/qcut.r0000644000176200001440000000115714421510276013254 0ustar liggesusers#' Cut a variable #' #' Calls the cut function to cut variables on data frame. #' #' #' @param x variable to cut #' @param cuts number of groups, 4 gives quartiles #' @param breaks can also give breaks #' @param ... other argument for cut function of R #' @author Thomas Scheike #' @keywords survival #' @examples #' #' data(sTRACE) #' gx <- qcut(sTRACE$age) #' table(gx) #' #' @export qcut <- function(x,cuts=4,breaks=NULL,...) {# {{{ if (is.null(breaks)) { probs <- seq(0,1,length.out=cuts+1) bb <- quantile(x,probs) } else bb <- breaks gx<- cut(x,breaks=bb,include.lowest=TRUE,...) return(gx) }# }}} timereg/R/new.dynreg.r0000644000176200001440000005266514421510301014357 0ustar liggesusers#' Fit time-varying regression model #' #' Fits time-varying regression model with partly parametric components. #' Time-dependent variables for longitudinal data. The model assumes that the #' mean of the observed responses given covariates is a linear time-varying #' regression model : #' #' \deqn{ E( Z_{ij} | X_{ij}(t) ) = \beta^T(t) X_{ij}^1(t) + \gamma^T X_{ij}^2(t) } #' where \eqn{Z_{ij}} is the j'th measurement at time t for the #' i'th subject with covariates \eqn{X_{ij}^1} and \eqn{X_{ij}^2}. Resampling #' is used for computing p-values for tests of timevarying effects. # #' The data for a subject is presented as multiple rows or 'observations', each #' of which applies to an interval of observation (start, stop]. For counting #' process data with the )start,stop] notation is used the 'id' variable is #' needed to identify the records for each subject. The program assumes that #' there are no ties, and if such are present random noise is added to break #' the ties. #' @param formula a formula object with the response on the left of a '~' #' operator, and the independent terms on the right as regressors. #' @param data a data.frame with the variables. #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. Default is max of data. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing time-varying effects. #' @param aalenmod Aalen model for measurement times. Specified as a survival #' model (see aalen function). #' @param bandwidth bandwidth for local iterations. Default is 50\% of the #' range of the considered observation period. #' @param bhat initial value for estimates. If NULL local linear estimate is #' computed. #' @param meansub if '1' then the mean of the responses is subtracted before #' the estimation is carried out. #' @param resample returns resample processes. #' @return returns an object of type "dynreg". With the following arguments: #' \item{cum}{the cumulative regression coefficients. This is the efficient #' estimator based on an initial smoother obtained by local linear regression : #' \deqn{ \hat B(t) = \int_0^t \tilde \beta(s) ds+ \hspace{4 cm}} #' \deqn{\int_0^t X^{-} (Diag(z) -Diag( X^T(s) \tilde \beta(s)) ) dp(ds \times dz), } #' where \eqn{\tilde \beta(t)} is an initial estimate either #' provided or computed by local linear regression. To plot this estimate use #' type="eff.smooth" in the plot() command. } #' \item{var.cum}{the martingale based pointwise variance estimates.} #' \item{robvar.cum}{robust pointwise variances estimates.} #' \item{gamma}{estimate of semi-parametric components of model.} #' \item{var.gamma}{variance for gamma.} #' \item{robvar.gamma}{robust variance for gamma.} #' \item{cum0}{simple estimate of cumulative regression #' coefficients that does not use use an initial smoothing based estimate #' \deqn{ \hat B_0(t) = \int_0^t X^{-} Diag(z) dp(ds \times dz). } To plot this #' estimate use type="0.mpp" in the plot() command. } #' \item{var.cum0}{the martingale based pointwise variance estimates of cum0.} #' \item{cum.ms}{estimate of cumulative regression coefficients based on #' initial smoother (but robust to this estimator). \deqn{ \hat B_{ms}(t) = #' \int_0^t X^{-} (Diag(z)-f(s)) dp(ds \times dz), } where \eqn{f} is chosen as #' the matrix \deqn{ f(s) = Diag( X^T(s) \tilde \beta(s)) ( I - X_\alpha(s) X_\alpha^-(s) ), } #' where \eqn{X_{\alpha}} is the design for the sampling #' intensities. #' This is also an efficient estimator when the initial estimator is consistent #' for \eqn{\beta(t)} and then asymptotically equivalent to cum, but small #' sample properties appear inferior. Its variance is estimated by var.cum. #' To plot this estimate use type="ms.mpp" in the plot() command. } #' \item{cum.ly}{estimator where local averages are subtracted. Special case of #' cum.ms. To plot this estimate use type="ly.mpp" in plot. } #' \item{var.cum.ly}{the martingale based pointwise variance estimates. } #' \item{gamma0}{estimate of parametric component of model. } #' \item{var.gamma0}{estimate of variance of parametric component of model. } #' \item{gamma.ly}{estimate of parametric components of model. } #' \item{var.gamma.ly}{estimate of variance of parametric component of model. } #' \item{gamma.ms}{estimate of variance of parametric component of model. } #' \item{var.gamma.ms}{estimate of variance of parametric component of model.} #' \item{obs.testBeq0}{observed absolute value of supremum of cumulative #' components scaled with the variance.} \item{pval.testBeq0}{p-value for #' covariate effects based on supremum test.} \item{sim.testBeq0}{resampled #' supremum values.} \item{obs.testBeqC}{observed absolute value of supremum of #' difference between observed cumulative process and estimate under null of #' constant effect.} \item{pval.testBeqC}{p-value based on resampling.} #' \item{sim.testBeqC}{resampled supremum values.} #' \item{obs.testBeqC.is}{observed integrated squared differences between #' observed cumulative and estimate under null of constant effect.} #' \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{sim.testBeqC.is}{resampled supremum values.} #' \item{conf.band}{resampling based constant to construct robust 95\% uniform #' confidence bands.} #' \item{test.procBeqC}{observed test-process of difference #' between observed cumulative process and estimate under null of constant effect.} #' \item{sim.test.procBeqC}{list of 50 random realizations of #' test-processes under null based on resampling.} #' \item{covariance}{covariances for nonparametric terms of model.} #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' \donttest{ #' ## this runs slowly and is therfore donttest #' data(csl) #' indi.m<-rep(1,length(csl$lt)) #' #' # Fits time-varying regression model #' out<-dynreg(prot~treat+prot.prev+sex+age,data=csl, #' Surv(lt,rt,indi.m)~+1,start.time=0,max.time=2,id=csl$id, #' n.sim=100,bandwidth=0.7,meansub=0) #' summary(out) #' par(mfrow=c(2,3)) #' plot(out) #' #' # Fits time-varying semi-parametric regression model. #' outS<-dynreg(prot~treat+const(prot.prev)+const(sex)+const(age),data=csl, #' Surv(lt,rt,indi.m)~+1,start.time=0,max.time=2,id=csl$id, #' n.sim=100,bandwidth=0.7,meansub=0) #' summary(outS) #' } #' ##' @export dynreg<-function(formula=formula(data),data=parent.frame(),aalenmod, bandwidth=0.5,id=NULL,bhat=NULL,start.time=0, max.time=NULL,n.sim=500,meansub=1,weighted.test=0,resample=0) { if (n.sim==0) sim<-0 else sim<-1; smoothXX<-0 if (n.sim>0 & n.sim<50) {n.sim<-50 ; cat("Minimum 50 simulations\n");} b<-bandwidth call <- match.call() m <- match.call(expand.dots=FALSE) m$weighted.test<-m$meansub<-m$bandwidth<-m$aalenmod<-m$start.time<-m$max.time<- m$return.mg<-m$n.sim<-m$bhat<-m$id<-m$clusters<-m$resample<-NULL special <- c("const") Terms <- if(missing(data)) terms(formula, special) else terms(formula, special, data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m, "response") des<-read.design(m,Terms) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ pxz <- px + pz; XZ<-cbind(X,Z); clusters <- des$clusters ########## #################################################################### ### Aalen design is interpreted udaal<-aalen.des(aalenmod,data=data); time<-udaal$time; time2<-udaal$time2; covarA<-data.matrix(udaal$X); status<-udaal$status; pa<-ncol(covarA); #################################################################### meanY<-mean(Y); if (meansub==1) { Y<-Y-meanY;} covar<-data.matrix(cbind(Y,XZ,covarA)); #################################################################### Ntimes <- sum(status); # adds random noise to make survival times unique if (sum(duplicated(time2[status==1]))>0) { # cat("Non unique survival times: break ties ! \n") # cat("Break ties yourself\n"); ties<-TRUE; dtimes<-time2[status==1] index<-(1:length(time2))[status==1] ties<-duplicated(dtimes); nties<-sum(ties); index<-index[ties] dt<-diff(sort(time2)); dt<-min(dt[dt>0]); time2[index]<-time2[index]+runif(nties,0,min(0.001,dt/2)); } else ties<-FALSE; if (is.null(id)==TRUE) stop("Must specify subject id variable \n") Ntimes <- Ntimes+1; times<-c(0,time2[status==1]); if (is.null(max.time)==TRUE) max.time<-max(times)+0.1 else max.time<-min(max(times),max.time); times<-times[timesstart.time]; times<-sort(times); Ntimes<-length(times); clusters<-cluster.call<-des$clusters; if (is.null(id)==TRUE) {antpers<-length(time); id<-0:(antpers-1); } else { pers<-unique(id); antpers<-length(pers); id<-as.integer(factor(id,labels=1:(antpers)))-1; } ldata<-list(start=time,stop=time2, antpers=antpers,antclust=des$antclust); ### X<-as.matrix(covar); if (npar==TRUE) { #cat("Nonparametric Additive Model "); cat("\n") # local linear regression for preliminary estimates #################################################### bandwidth<-(max.time-start.time)*bandwidth; if (is.null(bhat)==TRUE) { xval<-seq(times[2],times[Ntimes],length=30); bhat<-localTimeReg(time2,Y[status==1],X[status==1,],xval,b,lin=1)[,1:(px+1)] } ud<-dynregBase(times,status,Y,ldata,X,covarA,id,clusters, sim=sim,resample=resample,antsim=n.sim,b=b,bhat=bhat, smoothXX=smoothXX,weighted.test=weighted.test); colnames(ud$cum.ly)<- colnames(ud$var.cum.ly)<- colnames(ud$cum)<-colnames(ud$var.cum)<- colnames(ud$cum0)<- colnames(ud$cum.ms)<-colnames(ud$robvar.cum)<-c("time",covnamesX) if (sim==1) { colnames(ud$test.procBeqC)<- c("time",covnamesX) names(ud$conf.band)<- names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<- names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<- names(ud$obs.testBeqC.is)<- names(ud$pval.testBeqC.is)<- colnames(ud$sim.testBeq0)<- colnames(ud$sim.testBeqC) <- colnames(ud$sim.testBeqC.is) <- covnamesX; } } else { #cat(" Semiparametric Additive Model"); cat("\n") if (is.null(bhat)==TRUE) { cat(" Computes initial estimates based on local regression\n") cat(" for efficient estimates, you may provide these\n"); xval<-seq(times[2],times[Ntimes],length=30); bhat<-localTimeReg(time2,Y[status==1],XZ[status==1,],xval,b,lin=1); bhat<-bhat[,1:(pxz+1)]; gamma<-apply(as.matrix(bhat[,((px+2):(pxz+1))]),2,mean); bhat<-bhat[,1:(px+1)]; } else {bhat<-cbind(xval,matrix(0,30,px)); gamma<-rep(0,pz);} #if (is.null(bhat)==TRUE) { #ud<-dynregBase(times,status,Y,ldata, #X,covarA,id,bhat=bhat, #sim=0,retur=0,antsim=0,b=b,smoothXX=smoothXX, #weighted.test=weighted.test); ##pcregci(ud$cum,ud$var.cum,0,3); #xval<-seq(times[1],times[Ntimes],length=30); #bhat<-CsmoothB(ud$cum,xval,b); #gamma<-ud$cum[signif(Ntimes*3/4),(px+2):(px+pz+1)]/ # ud$cum[signif(Ntimes*3/4),1]; #}; #print(apply(cbind(X[,1:(pxz+1)],X[,(pxz+2):(pxz+pa+1)]),2,mean)) #print(ud$cum[200,]); ud<-semiregBase(times,status,Y,ldata,X,Z,covarA,id,clusters, bhat=bhat,sim=sim,antsim=n.sim,b=b,gamma=gamma,weighted.test=weighted.test, resample=resample); if (px>0) { colnames(ud$cum)<- colnames(ud$var.cum)<- colnames(ud$cum0)<- colnames(ud$cum.ms)<- colnames(ud$robvar.cum)<-c("time",covnamesX) if (sim==1) { colnames(ud$test.procBeqC)<- c("time",covnamesX) names(ud$conf.band)<- names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<- names(ud$pval.testBeqC.is)<- names(ud$obs.testBeqC.is)<- names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<- colnames(ud$sim.testBeq0)<- colnames(ud$sim.testBeqC.is)<- colnames(ud$sim.testBeqC)<- covnamesX; } } ud$gamma<-nameestimate(ud$gamma,covnamesZ); ud$gamma.ms<-nameestimate(ud$gamma.ms,covnamesZ); ud$gamma0<-nameestimate(ud$gamma0,covnamesZ); ud$gamma.ly<-nameestimate(ud$gamma.ly,covnamesZ); #ud$gamma.ef<-nameestimate(ud$gamma.ef,covnamesZ); #ud$gamma.efms<-nameestimate(ud$gamma.efms,covnamesZ); ud$var.gamma<-namematrix(ud$var.gamma,covnamesZ); ud$robvar.gamma<-namematrix(ud$robvar.gamma,covnamesZ); ud$var.gamma.ms<-namematrix(ud$var.gamma.ms,covnamesZ); ud$var.gamma.ly<-namematrix(ud$var.gamma.ly,covnamesZ); #ud$var.gamma.ef<-namematrix(ud$var.gamma.ef,covnamesZ); #ud$robvar.gamma.ef<-namematrix(ud$robvar.gamma.ef,covnamesZ); ud$mean.response<-meanY; } attr(ud,"Call")<-call; class(ud)<-"dynreg" return(ud); } namematrix<-function(mat,names) { colnames(mat)<-names; rownames(mat)<-names; return(mat); } nameestimate<-function(mat,names) { colnames(mat)<-"estimate"; rownames(mat)<-names; return(mat); } #' Plots estimates and test-processes #' #' This function plots the non-parametric cumulative estimates for the additive #' risk model or the test-processes for the hypothesis of constant effects with #' re-sampled processes under the null. #' #' @param x the output from the "dynreg" function. #' @param type the estimator plotted. Choices "eff.smooth", "ms.mpp", "0.mpp" #' and "ly.mpp". See the dynreg function for more on this. #' @param pointwise.ci if >1 pointwise confidence intervals are plotted with #' lty=pointwise.ci #' @param hw.ci if >1 Hall-Wellner confidence bands are plotted with lty=hw.ci. #' Only 0.95 \% bands can be constructed. #' @param sim.ci if >1 simulation based confidence bands are plotted with #' lty=sim.ci. These confidence bands are robust to non-martingale behaviour. #' @param robust robust standard errors are used to estimate standard error of #' estimate, otherwise martingale based estimate are used. #' @param specific.comps all components of the model is plotted by default, but #' a list of components may be specified, for example first and third "c(1,3)". #' @param level gives the significance level. #' @param start.time start of observation period where estimates are plotted. #' @param stop.time end of period where estimates are plotted. Estimates thus #' plotted from [start.time, max.time]. #' @param add.to.plot to add to an already existing plot. #' @param mains add names of covariates as titles to plots. #' @param xlab label for x-axis. #' @param ylab label for y-axis. #' @param score to plot test processes for test of time-varying effects along #' with 50 random realization under the null-hypothesis. #' @param ... unused arguments - for S3 compatibility #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' \donttest{ #' ### runs slowly and therefore donttest #' data(csl) #' indi.m<-rep(1,length(csl$lt)) #' #' # Fits time-varying regression model #' out<-dynreg(prot~treat+prot.prev+sex+age,csl, #' Surv(lt,rt,indi.m)~+1,start.time=0,max.time=3,id=csl$id, #' n.sim=100,bandwidth=0.7,meansub=0) #' #' par(mfrow=c(2,3)) #' # plots estimates #' plot(out) #' # plots tests-processes for time-varying effects #' plot(out,score=TRUE) #' } #' ##' @export plot.dynreg<-function(x,type="eff.smooth",pointwise.ci=1,hw.ci=0, sim.ci=0,robust=0,specific.comps=FALSE,level=0.05,start.time=0,stop.time=0, add.to.plot=FALSE,mains=TRUE,xlab="Time",ylab ="Cumulative coefficients",score=FALSE,...) { object <- x; rm(x); if (!inherits(object, 'dynreg')) stop ("Must be output from dynreg() function") if (score==FALSE) { if (type=="eff.smooth") { B<-object$cum;V<-object$var.cum;} else if (type=="ms.mpp") {B<-object$cum.ms;V<-object$var.cum;} else if (type=="0.mpp") { B<-object$cum0; if (is.numeric(object$gamma)==FALSE) V<-object$var.cum0 else V<-B*0; } else if (type=="ly.mpp") { if (is.numeric(object$gamma)==FALSE) { B<-object$cum.ly; V<-object$var.cum.ly;} else stop("Non-par estimates not computed for LY correction\n"); } else stop("not valid type"); p<-dim(B)[[2]]; if (is.null(V)==TRUE) robust<-1; if (robust>=1) V<-object$robvar.cum; if (sum(specific.comps)==FALSE) comp<-2:p else comp<-specific.comps+1 if (stop.time==0) stop.time<-max(B[,1]); med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; Bs<-B[1,]; B<-t(t(B)-Bs); B[,1]<-B[,1]+Bs[1]; V<-V[med,]; Vs<-V[1,]; V<-t( t(V)-Vs); Vrob<-object$robvar.cum; Vrob<-Vrob[med,]; Vrobs<-Vrob[1,]; Vrob<-t( t(Vrob)-Vrobs); c.alpha<- qnorm(1-level/2) for (v in comp) { c.alpha<- qnorm(1-level/2) est<-B[,v];ul<-B[,v]+c.alpha*V[,v]^.5;nl<-B[,v]-c.alpha*V[,v]^.5; if (add.to.plot==FALSE) { plot(B[,1],est,ylim=1.05*range(ul,nl),type="s",xlab=xlab,ylab=ylab) if (mains==TRUE) title(main=colnames(B)[v]); } else lines(B[,1],est,type="s"); if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="s"); lines(B[,1],nl,lty=pointwise.ci,type="s"); } if (robust>=1) { lines(B[,1],ul,lty=robust,type="s"); lines(B[,1],nl,lty=robust,type="s"); } if (hw.ci>=1) { if (level!=0.05) cat("Hall-Wellner bands only 95 % \n"); tau<-length(B[,1]) nl<-B[,v]-1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) ul<-B[,v]+1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) lines(B[,1],ul,lty=hw.ci,type="s"); lines(B[,1],nl,lty=hw.ci,type="s"); } if (sim.ci>=1) { if (sum(object$conf.band)==FALSE) cat("Uniform simulation based bands only computed for n.sim> 0\n") if (level!=0.05) c.alpha<-percen(object$sim.testBeq0[,v-1],1-level) else c.alpha<-object$conf.band[v-1]; nl<-B[,v]-c.alpha*Vrob[,v]^.5; ul<-B[,v]+c.alpha*Vrob[,v]^.5; lines(B[,1],ul,lty=sim.ci,type="s"); lines(B[,1],nl,lty=sim.ci,type="s"); } abline(h=0) } } else { # plot score proces dim1<-ncol(object$test.procBeqC) if (sum(specific.comps)==FALSE) comp<-2:dim1 else comp<-specific.comps+1 for (i in comp) { ul<-2*max(abs(object$test.procBeqC[,i])); plot(object$test.procBeqC[,1], object$test.procBeqC[,i],type="l",ylim=c(-ul,ul), lwd=2,xlab=xlab,ylab=ylab) if (mains==TRUE) title(main=colnames(object$test.procBeqC)[i]); for (j in 1:50) lines(object$test.procBeqC[,1], as.matrix(object$sim.test.procBeqC[[j]])[,i-1],lwd=1,col="grey",lty=1) lines(object$test.procBeqC[,1],object$test.procBeqC[,i],lwd=2) } } } ##' @export "print.dynreg" <- function (x,...) { dynreg.object <- x; rm(x); if (!inherits(dynreg.object, 'dynreg')) stop ("Must be a dynreg object") if (is.null(dynreg.object$gamma0)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: cat("Dynamic Additive Regression Model \n\n") cat(" Nonparametric terms : "); cat(colnames(dynreg.object$cum)[-1]); cat(" \n"); if (semi) { cat(" Parametric terms : "); cat(rownames(dynreg.object$gamma0)); cat(" \n"); } cat(" \n"); cat(" Call: \n") dput(attr(dynreg.object, "Call")) cat("\n") } ##' @export "summary.dynreg" <- function(object,digits = 3,...) { dynreg.object <- object; rm(object); obj<-dynreg.object if (!inherits(dynreg.object, 'dynreg')) stop ("Must be an dynreg object") if (is.null(dynreg.object$gamma.ms)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: cat("Dynamic Additive Regression Model \n\n") cat(" Nonparametric terms : "); cat(colnames(dynreg.object$cum)[-1]); cat(" \n"); timetest(obj,digits=digits); if (semi) { cat(" Parametric terms : "); cat(rownames(dynreg.object$gamma0)); cat(" \n"); out=coef.dynreg(dynreg.object); out=signif(out,digits=digits) print(out) cat(" \n"); } ### cat(" Call: \n") ### dput(attr(dynreg.object, "Call")) cat("\n") } ##' @export coef.dynreg<- function(object,...,digits=3) { coefBase(object,digits=digits) } ##' @export aalen.des<-function(formula=formula(data),data=parent.frame(),model="aalen") { call <- match.call(); m <- match.call(expand.dots=FALSE); m$model<-NULL special <- c("cluster","prop","const") Terms <- if(missing(data)) terms(formula,special) else terms(formula, special, data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m,"response") des<-read.design(m,Terms,model=model) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ; clusters<-des$clusters; if (attr(m[, 1], "type") == "right") { type<-"right"; status <- m[, 1][, "status"]; time2 <- m[, 1][, "time"]; time <- rep(0,length(time2)); } else if (attr(m[, 1], "type") == "counting") { type<-"counting"; time <- m[, 1][,1]; time2 <- m[, 1][,2]; status <- m[, 1][,3]; } else { stop("only right-censored or counting processes data") } return(list(type=type,time=time,time2=time2,status=status, X=X,Z=Z,px=px,pz=pz,npar=npar, covnamesX=covnamesX,covnamesZ=covnamesZ,clusters=clusters)) } timereg/R/krylow.pls.r0000644000176200001440000000346714421510276014432 0ustar liggesusers###krylow.pls<-function(D,d,dim) ###{ ###R=d; Sxxsxy=R; ###if (dim>=2) ###for (i in 2:dim) ###{ ###Sxxsxy=D %*% Sxxsxy ; ###R=cbind(R,Sxxsxy); ###} ###beta= R %*% solve(t(R) %*% D %*% R) %*% t(R) %*% d ###beta= beta; ###return(list(beta=beta)) ###} ### Anders Gorst Rasmussen's code #' Fits Krylow based PLS for additive hazards model #' #' Fits the PLS estimator for the additive risk model based on the least #' squares fitting criterion #' #' \deqn{ L(\beta,D,d) = \beta^T D \beta - 2 \beta^T d } where \eqn{D=\int Z H #' Z dt} and \eqn{d=\int Z H dN}. #' #' #' @param D defined above #' @param d defined above #' @param dim number of pls dimensions #' @return returns a list with the following arguments: \item{beta}{PLS #' regression coefficients} #' @author Thomas Scheike #' @references Martinussen and Scheike, The Aalen additive hazards model with #' high-dimensional regressors, submitted. #' #' Martinussen and Scheike, Dynamic Regression Models for Survival Data, #' Springer (2006). #' @keywords survival #' @examples #' #' ## makes data for pbc complete case #' data(mypbc) #' pbc<-mypbc #' pbc$time<-pbc$time+runif(418)*0.1; pbc$time<-pbc$time/365 #' pbc<-subset(pbc,complete.cases(pbc)); #' covs<-as.matrix(pbc[,-c(1:3,6)]) #' covs<-cbind(covs[,c(1:6,16)],log(covs[,7:15])) #' #' ## computes the matrices needed for the least squares #' ## criterion #' out<-aalen(Surv(time,status>=1)~const(covs),pbc,robust=0,n.sim=0) #' S=out$intZHZ; s=out$intZHdN; #' #' out<-krylow.pls(S,s,dim=2) #' #' @export krylow.pls <- function(D,d,dim = 1) { r <- d p <- r rsold <- drop(t(r) %*% r) x <- rep(0,length(d)) for(k in 1:dim){ Ap <- D %*% p; alpha <-drop(rsold / (t(p) %*% Ap)); x <- x + alpha * p; r <- r - alpha * Ap; rsnew <- drop(t(r) %*% r); p <- r + rsnew / rsold * p; rsold <-rsnew; } return(x) } timereg/R/timereg-copy-package.R0000644000176200001440000002064114421510301016221 0ustar liggesusers #' The Bone Marrow Transplant Data #' #' Bone marrow transplant data with 408 rows and 5 columns. #' #' #' @format The data has 408 rows and 5 columns. \describe{ \item{cause}{a #' numeric vector code. Survival status. 1: dead from treatment related #' causes, 2: relapse , 0: censored.} \item{time}{ a numeric vector. Survival #' time. } \item{platelet}{a numeric vector code. Plalelet 1: more than 100 x #' \eqn{10^9} per L, 0: less.} \item{tcell}{a numeric vector. T-cell depleted #' BMT 1:yes, 0:no.} \item{age}{a numeric vector code. Age of patient, scaled #' and centered ((age-35)/15).} } #' @references NN #' @name bmt #' @docType data #' @source Simulated data #' @keywords package #' @examples #' #' data(bmt) #' names(bmt) #' NULL #' The multicenter AIDS cohort study #' #' CD4 counts collected over time. #' #' #' @format This data frame contains the following columns: \describe{ #' \item{obs}{a numeric vector. Number of observations.} \item{id}{a numeric #' vector. Id of subject.} \item{visit}{ a numeric vector. Timings of the #' visits in years.} \item{smoke}{a numeric vector code. 0: non-smoker, 1: #' smoker.} \item{age}{a numeric vector. Age of the patient at the start of the #' trial.} \item{cd4}{a numeric vector. CD4 percentage at the current visit.} #' \item{cd4.prev}{a numeric vector. CD4 level at the preceding visit.} #' \item{precd4}{a numeric vector. Post-infection CD4 percentage.} \item{lt}{a #' numeric vector. Gives the starting time for the time-intervals.} \item{rt}{a #' numeric vector. Gives the stopping time for the time-interval.} } #' @references Kaslow et al. (1987), The multicenter AIDS cohort study: #' rational, organisation and selected characteristics of the participants. #' Am. J. Epidemiology 126, 310--318. #' @source MACS Public Use Data Set Release PO4 (1984-1991). See reference. #' @name cd4 #' @docType data #' @keywords package #' @examples #' #' data(cd4) #' names(cd4) #' NULL #' CSL liver chirrosis data #' #' Survival status for the liver chirrosis patients of Schlichting et al. #' #' #' @format This data frame contains the following columns: \describe{ #' \item{id}{ a numeric vector. Id of subject. } #' #' \item{time}{ a numeric vector. Time of measurement. } \item{prot}{ a #' numeric vector. Prothrombin level at measurement time. } \item{dc}{ a #' numeric vector code. 0: censored observation, 1: died at eventT. } #' \item{eventT}{ a numeric vector. Time of event (death). } \item{treat}{ a #' numeric vector code. 0: active treatment of prednisone, 1: placebo #' treatment. } \item{sex}{ a numeric vector code. 0: female, 1: male. } #' \item{age}{ a numeric vector. Age of subject at inclusion time subtracted #' 60. } \item{prot.base}{ a numeric vector. Prothrombin base level before #' entering the study. } \item{prot.prev}{ a numeric vector. Level of #' prothrombin at previous measurement time. } \item{lt}{ a numeric vector. #' Gives the starting time for the time-intervals. } \item{rt}{ a numeric #' vector. Gives the stopping time for the time-intervals. } } #' @references Schlichting, P., Christensen, E., Andersen, P., Fauerholds, L., #' Juhl, E., Poulsen, H. and Tygstrup, N. (1983), The Copenhagen Study Group #' for Liver Diseases, Hepatology 3, 889--895 #' @name csl #' @docType data #' @keywords package #' @source P.K. Andersen #' @examples #' #' data(csl) #' names(csl) #' NULL #' The Diabetic Retinopathy Data #' #' The data was colleceted to test a laser treatment for delaying blindness in #' patients with dibetic retinopathy. The subset of 197 patiens given in Huster #' et al. (1989) is used. #' #' #' @format This data frame contains the following columns: \describe{ #' \item{id}{a numeric vector. Patient code.} \item{agedx}{a numeric vector. #' Age of patient at diagnosis.} \item{time}{a numeric vector. Survival time: #' time to blindness or censoring.} \item{status}{ a numeric vector code. #' Survival status. 1: blindness, 0: censored.} \item{trteye}{a numeric vector #' code. Random eye selected for treatment. 1: left eye 2: right eye.} #' \item{treat}{a numeric vector. 1: treatment 0: untreated.} \item{adult}{a #' numeric vector code. 1: younger than 20, 2: older than 20.} } #' @source Huster W.J. and Brookmeyer, R. and Self. S. (1989) MOdelling paired #' survival data with covariates, Biometrics 45, 145-56. #' @name diabetes #' @docType data #' @keywords package #' @examples #' #' data(diabetes) #' names(diabetes) #' NULL #' Melanoma data and Danish population mortality by age and sex #' #' Melanoma data with background mortality of Danish population. #' #' #' @format This data frame contains the following columns: \describe{ #' \item{id}{ a numeric vector. Gives patient id. } \item{sex}{ a numeric #' vector. Gives sex of patient. } \item{start}{ a numeric vector. Gives the #' starting time for the time-interval for which the covariate rate is #' representative. } \item{stop}{ a numeric vector. Gives the stopping time #' for the time-interval for which the covariate rate is representative. } #' \item{status}{ a numeric vector code. Survival status. 1: dead from #' melanoma, 0: alive or dead from other cause. } \item{age}{ a numeric vector. #' Gives the age of the patient at removal of tumor. } \item{rate}{ a numeric #' vector. Gives the population mortality for the given sex and age. Based on #' Table A.2 in Andersen et al. (1993). } } #' @source Andersen, P.K., Borgan O, Gill R.D., Keiding N. (1993), #' \emph{Statistical Models Based on Counting Processes}, Springer-Verlag. #' @name mela.pop #' @docType data #' @keywords package #' @examples #' #' data(mela.pop) #' names(mela.pop) #' NULL #' The Melanoma Survival Data #' #' The melanoma data frame has 205 rows and 7 columns. It contains data #' relating to survival of patients after operation for malignant melanoma #' collected at Odense University Hospital by K.T. Drzewiecki. #' #' #' @format This data frame contains the following columns: \describe{ #' \item{no}{ a numeric vector. Patient code. } \item{status}{ a numeric vector #' code. Survival status. 1: dead from melanoma, 2: alive, 3: dead from other #' cause. } \item{days}{ a numeric vector. Survival time. } \item{ulc}{ a #' numeric vector code. Ulceration, 1: present, 0: absent. } \item{thick}{ a #' numeric vector. Tumour thickness (1/100 mm). } \item{sex}{ a numeric vector #' code. 0: female, 1: male. } } #' @source Andersen, P.K., Borgan O, Gill R.D., Keiding N. (1993), #' \emph{Statistical Models Based on Counting Processes}, Springer-Verlag. #' #' Drzewiecki, K.T., Ladefoged, C., and Christensen, H.E. (1980), Biopsy and #' prognosis for cutaneous malignant melanoma in clinical stage I. Scand. J. #' Plast. Reconstru. Surg. 14, 141-144. #' @name melanoma #' @docType data #' @keywords package #' @examples #' #' data(melanoma) #' names(melanoma) #' NULL #' The TRACE study group of myocardial infarction #' #' The TRACE data frame contains 1877 patients and is a subset of a data set #' consisting of approximately 6000 patients. It contains data relating #' survival of patients after myocardial infarction to various risk factors. #' #' sTRACE is a subsample consisting of 300 patients. #' #' tTRACE is a subsample consisting of 1000 patients. #' #' #' @aliases TRACE sTRACE tTRACE #' @format This data frame contains the following columns: \describe{ #' \item{id}{a numeric vector. Patient code. } \item{status}{ a numeric vector #' code. Survival status. 9: dead from myocardial infarction, 0: alive, 7: dead #' from other causes. } \item{time}{ a numeric vector. Survival time in years. #' } \item{chf}{ a numeric vector code. Clinical heart pump failure, 1: #' present, 0: absent. } \item{diabetes}{ a numeric vector code. Diabetes, 1: #' present, 0: absent. } \item{vf}{ a numeric vector code. Ventricular #' fibrillation, 1: present, 0: absent. } \item{wmi}{ a numeric vector. #' Measure of heart pumping effect based on ultrasound measurements where 2 is #' normal and 0 is worst. } \item{sex}{ a numeric vector code. 1: female, 0: #' male. } \item{age}{ a numeric vector code. Age of patient. } } #' @source The TRACE study group. #' #' Jensen, G.V., Torp-Pedersen, C., Hildebrandt, P., Kober, L., F. E. Nielsen, #' Melchior, T., Joen, T. and P. K. Andersen (1997), Does in-hospital #' ventricular fibrillation affect prognosis after myocardial infarction?, #' European Heart Journal 18, 919--924. #' @name TRACE #' @docType data #' @keywords package #' @examples #' #' data(TRACE) #' names(TRACE) #' NULL timereg/R/plots.r0000644000176200001440000000720414421510301013425 0ustar liggesusersplot.cums <- function (x , pointwise.ci=1, hw.ci=0, sim.ci=0, robust.ci=0, col=NULL, specific.comps=FALSE,level=0.05, start.time = 0, stop.time = 0, add.to.plot=FALSE,main=NULL,mains=TRUE, xlab="Time", ylab ="Cumulative coefficients",ylim=NULL,...) { ## {{{ object<-x; rm(x); B<-object$cum; V<-object$var.cum; p<-dim(B)[[2]]; if (robust.ci>=1) {V<-object$robvar.cum;} ### color for estimate, pointwise, robust-pointwise, sim.ci , hw.ci cis <- c(1,pointwise.ci>=1,robust.ci>=1,sim.ci>=1,hw.ci>=1) if (is.null(col)) cols<-rep(1,5) else { cols <- rep(1,5) cols[which(cis==TRUE)] <- col } if (sum(specific.comps)==FALSE) comp<-2:p else comp<-specific.comps+1 if (stop.time==0) stop.time<-max(B[,1]); med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; Bs<-B[1,]; B<-t(t(B)-Bs); B[,1]<-B[,1]+Bs[1]; V<-V[med,]; Vs<-V[1,]; V<-t( t(V)-Vs); Vrob<-object$robvar.cum; Vrob<-Vrob[med,]; Vrobs<-Vrob[1,]; Vrob<-t( t(Vrob)-Vrobs); c.alpha<- qnorm(1-level/2) i <- 0 for (v in comp) { i <- i+1 c.alpha<- qnorm(1-level/2) est<-B[,v];ul<-B[,v]+c.alpha*V[,v]^.5;nl<-B[,v]-c.alpha*V[,v]^.5; if (add.to.plot==FALSE) { if (is.null(ylim)) plot(B[,1],est,ylim=1.05*range(ul,nl),type="s",xlab=xlab,ylab=ylab,col=cols[1],...) else plot(B[,1],est,ylim=ylim,type="s",xlab=xlab,ylab=ylab,col=cols[1],...) if (!is.null(main)) { if (length(main)==1) main <- rep(main,length(comp)); mains <- FALSE; } if (!is.null(main)) title(main=main[i]); if (mains==TRUE) title(main=colnames(B)[v]); } else lines(B[,1],est,type="s",col=cols[1]); if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="s",col=cols[2]); lines(B[,1],nl,lty=pointwise.ci,type="s",col=cols[2]); } if (robust.ci>=1) { lines(B[,1],ul,lty=robust.ci,type="s",col=cols[3]); lines(B[,1],nl,lty=robust.ci,type="s",col=cols[3]); } if (hw.ci>=1) { if (level!=0.05) cat("Hall-Wellner bands only 95 % \n"); tau<-length(B[,1]) nl<-B[,v]-1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) ul<-B[,v]+1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) lines(B[,1],ul,lty=hw.ci,type="s",col=cols[5]); lines(B[,1],nl,lty=hw.ci,type="s",col=cols[5]); } if (sim.ci>=1) { if (is.null(object$conf.band)==TRUE) cat("Uniform simulation based bands only computed for n.sim> 0\n") if (level!=0.05) c.alpha<-percen(object$sim.testBeq0[,v-1],1-level) else c.alpha<-object$conf.band[v-1]; nl<-B[,v]-c.alpha*Vrob[,v]^.5; ul<-B[,v]+c.alpha*Vrob[,v]^.5; lines(B[,1],ul,lty=sim.ci,type="s",col=cols[4]); lines(B[,1],nl,lty=sim.ci,type="s",col=cols[4]); } abline(h=0) } } ## }}} plotScore<-function (object,specific.comps=FALSE,main=NULL,mains=TRUE,xlab="Time", ylab="Cumulative MG-residuals",ylim=NULL,...) { ## {{{ if (inherits(object,"cox.aalen")) { obsProc<-object$test.procProp; simProc<-object$sim.test.procProp; } else { obsProc<-object$test.procBeqC; simProc<-object$sim.test.procBeq; } dim1<-ncol(obsProc) if (sum(specific.comps)==FALSE) comp<-2:dim1 else comp<-specific.comps+1 if (!is.null(main)) {if (length(main)==1) main <- rep(main,length(comp)); mains <- FALSE; } v <- 0 for (i in comp) { v <- v+1 ranyl<-range(obsProc[,i]); for (j in 1:50) ranyl<-range(c(ranyl,as.matrix(simProc[[j]])[,i-1])); mr<-max(abs(ranyl)); if (is.null(ylim)) plot(obsProc[,1],obsProc[,i],ylim=c(-mr,mr),lwd=2,xlab=xlab,ylab=ylab,type="s",...) else plot(obsProc[,1],obsProc[,i],ylim=ylim,lwd=2,xlab=xlab,ylab=ylab,type="s",...) if (!is.null(main)) title(main=main[v]); if (mains==TRUE) title(main=colnames(obsProc)[i]); for (j in 1:50) lines(obsProc[,1],as.matrix(simProc[[j]])[,i-1], col="grey",lwd=1,lty=1,type="s") lines(obsProc[,1],obsProc[,i],lwd=2,type="s") } } ## }}} timereg/R/kmplot.r0000644000176200001440000000530214421510276013602 0ustar liggesusers #' @export plotConfregion <- function(sfit,add=TRUE,polygon=TRUE,cols=1,ltys=1,...) {# {{{ nn <- names(sfit$strata) if (is.null(nn)) ll <- 1 else ll <- length(nn) if (length(cols)!=ll) cols <- seq(cols[1],ll) else cols <- cols if (length(cols)!=ll) ltys <- seq(ltys[1],ll) else ltys <- ltys ss <- 1 for (i in seq(ll)) { if (ll>1 & i>1) ss <- ss+sfit$strata[i-1] if (ll==1) index <- 1:length(sfit$time) else index <- ss:(ss+sfit$strata[i]-1) nl <- cbind(sfit$time[index],sfit$lower[index]) ul <- cbind(sfit$time[index],sfit$upper[index]) ## if call is from survfit type with hazard plot "fun="cumhaz")) ## checks if ... contains "fun="cumhaz" if (hasArg("fun")) { nl <- cbind(sfit$time[index],-log(sfit$lower[index])) ul <- cbind(sfit$time[index],-log(sfit$upper[index])) } if (!polygon) { lines(nl,type="s",col=cols[i],lty=ltys[i]+1,lwd=3,...) lines(ul,type="s",col=cols[i],lty=ltys[i]+1,lwd=3,...) } else { ll <- length(nl[,1]) timess <- nl[,1] ttp <- c(timess[1],rep(timess[-c(1,ll)],each=2),timess[ll]) tt <- c(ttp,rev(ttp)) yy <- c(rep(nl[-ll,2],each=rep(2)),rep(rev(ul[-ll,2]),each=2)) col.alpha<-0.1 col.ci<-cols[i] col.trans <- sapply(col.ci, FUN=function(x) do.call(grDevices::rgb,as.list(c(grDevices::col2rgb(x)/255,col.alpha)))) polygon(tt,yy,lty=0,col=col.trans) } } }# }}} #' @export kmplot<- function(x,add=FALSE,loc=NULL,col=NULL,lty=NULL,conf.int=TRUE,polygon=TRUE,add.legend=TRUE,...) { ## {{{ ### default location if loc not given if (is.null(loc)) { if (min(x$surv)>0.7) loc <- "bl" else loc <- "bl" if (hasArg("fun")) loc <- "tl" } if (loc=="bl") loc <- "bottomleft" else if (loc=="br") loc <- "bottomright" else if (loc=="tr") loc <- "topright" else if (loc=="tl") loc <- "topleft" else loc <- "bottomleft" nn <- names(x$strata) if (is.null(nn)) ll <- 1 else ll <- length(nn) if (is.null(col)) cols <- seq(ll) else cols <- col if (is.null(lty)) ltys <- seq(ll) else ltys <- lty plot(x,col=cols,lty=ltys,conf.int=FALSE,...) if (!is.null(nn) & add.legend) legend(loc,legend=names(x$strata),col=cols,lty=ltys) if (conf.int) { plotConfregion(x,add=TRUE,ltys=ltys,cols=cols,polygon=polygon,...) } } ## }}} ### library(mets) ### library(lava) ### ### data(melanoma) ### dhead(melanoma) ### dtable(melanoma,~status) ### melanoma <- dtransform(melanoma,status=0,status==2) ### melanoma <- dtransform(melanoma,stat1=(status==1)*1) ### melanoma <- dtransform(melanoma,time=days/365.25) ### ### ### fit=survfit(Surv(time,status!=0)~sex,data=melanoma) ### par(mfrow=c(1,2)) ### kmplot(fit) ### kmplot(fit,fun="cumhaz") timereg/R/additive-compSs.r0000644000176200001440000000655214421510301015324 0ustar liggesusers additive.compSs<-function (formula = formula(data), data = parent.frame(), start.time=0,max.time=NULL,id=NULL,scale=FALSE,silent=0,omit=NULL) { ## {{{ call <- match.call() m <- match.call(expand.dots = FALSE) m$start.time <- m$max.time <- m$id <- m$scale<- m$silent<- m$omit<-NULL special <- c("const") Terms <- if (missing(data)) terms(formula, special) else terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept <- attr(mt, "intercept") Y <- model.extract(m, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") des<-read.design(m,Terms) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ if (scale==TRUE) Z<-scale(Z); pxz <- px + pz; clusters=NULL; survs<-read.surv(m,id,FALSE,clusters,start.time,max.time) times<-survs$times;id<-id.call<-survs$id.cal; clusters<-cluster.call<-survs$clusters; time2<-survs$stop; time<-survs$start status<-survs$status; if (!is.null(omit)) { time<-time[-omit] time2<-time2[-omit]; status<-status[-omit] X<-X[-omit,]; Z<-Z[-omit,]; id<-id[omit]; times<-time2 if (is.null(max.time) == TRUE) maxtimes <- max(times) else maxtimes <- max.time times <- times[times <= maxtimes] times <- c(times, maxtimes) times <- unique(times) } Nalltimes <- length(times) Ntimes <- sum(status[(time2 > times[1]) & (time <= times[Nalltimes])]) + 1 nx<-nrow(X); fix<-0; if ( (attr(m[, 1], "type") == "right" ) ) { fix<-1 if (fix==1) ot<-order(time2,status==1); # order in time, status=1 first for ties if (fix==2) ot<-order(time2,status==0); # order in time, status=1 first for ties time2<-time2[ot]; status<-status[ot]; time<-time[ot]; X<-as.matrix(X[ot,]) Z<-as.matrix(Z[ot,]) survs$stop<-time2; id<-(1:nx)-1; } deltaweight<-1; intZHZ<-matrix(0,pz,pz); intZHdN<-matrix(0,pz,1); if (fix==0) { semiout<-.C("compSs", as.double(times),as.integer(Nalltimes),as.integer(Ntimes), as.double(X),as.integer(nx),as.integer(px), as.double(Z),as.integer(nx),as.integer(pz), as.integer(survs$antpers),as.double(time),as.double(time2), as.integer(id),as.integer(status), as.integer(deltaweight), as.double(intZHZ),as.double(intZHdN),as.integer(silent) ,PACKAGE="timereg") } if (fix==1) { semiout<-.C("compSsrev", as.double(times),as.integer(Nalltimes),as.integer(Ntimes), as.double(X),as.integer(nx),as.integer(px), as.double(Z),as.integer(nx),as.integer(pz), as.integer(survs$antpers),as.double(time),as.double(time2), as.integer(id),as.integer(status), as.integer(deltaweight), as.double(intZHZ),as.double(intZHdN),as.integer(silent) ,PACKAGE="timereg") } if (fix==2) { semiout<-.C("compSsforward", as.double(times),as.integer(Nalltimes),as.integer(Ntimes), as.double(X),as.integer(nx),as.integer(px), as.double(Z),as.integer(nx),as.integer(pz), as.integer(survs$antpers),as.double(time),as.double(time2), as.integer(id),as.integer(status), as.integer(deltaweight), as.double(intZHZ),as.double(intZHdN),as.integer(silent) ,PACKAGE="timereg") } intZHZ=matrix(semiout[[16]],pz,pz); intZHdN=matrix(semiout[[17]],pz,1); ud<-list(intZHZ=intZHZ,intZHdN=intZHdN) class(ud) <- "pls" attr(ud, "Call") <- call attr(ud, "Formula") <- formula ud$call <- call return(ud) } ## }}} timereg/R/ipcw-residualmean.r0000644000176200001440000006230314664040562015716 0ustar liggesusers#' Residual mean life (restricted) #' #' Fits a semiparametric model for the residual life (estimator=1): \deqn{ E( #' \min(Y,\tau) -t | Y>=t) = h_1( g(t,x,z) ) } or cause specific years lost of #' Andersen (2012) (estimator=3) \deqn{ E( \tau- \min(Y_j,\tau) | Y>=0) = #' \int_0^t (1-F_j(s)) ds = h_2( g(t,x,z) ) } where \eqn{Y_j = \sum_j Y #' I(\epsilon=j) + \infty * I(\epsilon=0)} or (estimator=2) \deqn{ E( \tau- #' \min(Y_j,\tau) | Y<\tau, \epsilon=j) = h_3( g(t,x,z) ) = h_2(g(t,x,z)) #' F_j(\tau,x,z) }{} where \eqn{F_j(s,x,z) = P(Y<\tau, \epsilon=j | x,z )} for a #' known link-function \eqn{h()} and known prediction-function \eqn{g(t,x,z)} #' #' Uses the IPCW for the score equations based on \deqn{ w(t) #' \Delta(\tau)/P(\Delta(\tau)=1| T,\epsilon,X,Z) ( Y(t) - h_1(t,X,Z)) } and #' where \eqn{\Delta(\tau)}{} is the at-risk indicator given data and requires a #' IPCW model. #' #' Since timereg version 1.8.4. the response must be specified with the #' \code{\link{Event}} function instead of the \code{\link[survival]{Surv}} function and #' the arguments. #' #' @param formula a formula object, with the response on the left of a '~' #' operator, and the terms on the right. The response must be a survival object #' as returned by the `Event' function. The status indicator is not important #' here. Time-invariant regressors are specified by the wrapper const(), and #' cluster variables (for computing robust variances) by the wrapper cluster(). #' @param data a data.frame with the variables. #' @param cause For competing risk models specificies which cause we consider. #' @param restricted gives a possible restriction times for means. #' @param times specifies the times at which the estimator is considered. #' Defaults to all the times where an event of interest occurs, with the first #' 10 percent or max 20 jump points removed for numerical stability in #' simulations. #' @param Nit number of iterations for Newton-Raphson algorithm. #' @param clusters specifies cluster structure, for backwards compability. #' @param gamma starting value for constant effects. #' @param n.sim number of simulations in resampling. #' @param weighted Not implemented. To compute a variance weighted version of #' the test-processes used for testing time-varying effects. #' @param model "additive", "prop"ortional. #' @param detail if 0 no details are printed during iterations, if 1 details #' are given. #' @param interval specifies that we only consider timepoints where the #' Kaplan-Meier of the censoring distribution is larger than this value. #' @param resample.iid to return the iid decomposition, that can be used to #' construct confidence bands for predictions #' @param cens.model specified which model to use for the ICPW, KM is #' Kaplan-Meier alternatively it may be "cox" or "aalen" model for further #' flexibility. #' @param cens.formula specifies the regression terms used for the regression #' model for chosen regression model. When cens.model is specified, the #' default is to use the same design as specified for the competing risks #' model. "KM","cox","aalen","weights". "weights" are user specified weights #' given is cens.weight argument. #' @param time.pow specifies that the power at which the time-arguments is #' transformed, for each of the arguments of the const() terms, default is 1 #' for the additive model and 0 for the proportional model. #' @param time.pow.test specifies that the power the time-arguments is #' transformed for each of the arguments of the non-const() terms. This is #' relevant for testing if a coefficient function is consistent with the #' specified form A_l(t)=beta_l t^time.pow.test(l). Default is 1 for the #' additive model and 0 for the proportional model. #' @param silent if 0 information on convergence problems due to non-invertible #' derviates of scores are printed. #' @param conv gives convergence criterie in terms of sum of absolute change of #' parameters of model #' @param estimator specifies what that is estimated. #' @param cens.weights censoring weights for estimating equations. #' @param conservative for slightly conservative standard errors. #' @param weights weights for estimating equations. #' @return returns an object of type 'comprisk'. With the following arguments: #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval.} \item{var.cum}{pointwise variances #' estimates. } \item{gamma}{estimate of proportional odds parameters of #' model.} \item{var.gamma}{variance for gamma. } \item{score}{sum of absolute #' value of scores.} \item{gamma2}{estimate of constant effects based on the #' non-parametric estimate. Used for testing of constant effects.} #' \item{obs.testBeq0}{observed absolute value of supremum of cumulative #' components scaled with the variance.} \item{pval.testBeq0}{p-value for #' covariate effects based on supremum test.} \item{obs.testBeqC}{observed #' absolute value of supremum of difference between observed cumulative process #' and estimate under null of constant effect.} \item{pval.testBeqC}{p-value #' based on resampling.} \item{obs.testBeqC.is}{observed integrated squared #' differences between observed cumulative and estimate under null of constant #' effect.} \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{conf.band}{resampling based constant to construct 95\% uniform #' confidence bands.} \item{B.iid}{list of iid decomposition of non-parametric #' effects.} \item{gamma.iid}{matrix of iid decomposition of parametric #' effects.} \item{test.procBeqC}{observed test process for testing of #' time-varying effects} \item{sim.test.procBeqC}{50 resample processes for for #' testing of time-varying effects} \item{conv}{information on convergence for #' time points used for estimation.} #' @author Thomas Scheike #' @references #' Andersen (2013), Decomposition of number of years lost according #' to causes of death, Statistics in Medicine, 5278-5285. #' #' Scheike, and Cortese (2015), Regression Modelling of Cause Specific Years Lost, #' #' Scheike, Cortese and Holmboe (2015), Regression Modelling of Restricted #' Residual Mean with Delayed Entry, #' @keywords survival #' @examples #' #' data(bmt); #' tau <- 100 #' #' ### residual restricted mean life #' out<-res.mean(Event(time,cause>=1)~factor(tcell)+factor(platelet),data=bmt,cause=1, #' times=0,restricted=tau,n.sim=0,model="additive",estimator=1); #' summary(out) #' #' out<-res.mean(Event(time,cause>=1)~factor(tcell)+factor(platelet),data=bmt,cause=1, #' times=seq(0,90,5),restricted=tau,n.sim=0,model="additive",estimator=1); #' par(mfrow=c(1,3)) #' plot(out) #' #' ### restricted years lost given death #' out21<-res.mean(Event(time,cause)~factor(tcell)+factor(platelet),data=bmt,cause=1, #' times=0,restricted=tau,n.sim=0,model="additive",estimator=2); #' summary(out21) #' out22<-res.mean(Event(time,cause)~factor(tcell)+factor(platelet),data=bmt,cause=2, #' times=0,restricted=tau,n.sim=0,model="additive",estimator=2); #' summary(out22) #' #' #' ### total restricted years lost #' out31<-res.mean(Event(time,cause)~factor(tcell)+factor(platelet),data=bmt,cause=1, #' times=0,restricted=tau,n.sim=0,model="additive",estimator=3); #' summary(out31) #' out32<-res.mean(Event(time,cause)~factor(tcell)+factor(platelet),data=bmt,cause=2, #' times=0,restricted=tau,n.sim=0,model="additive",estimator=3); #' summary(out32) #' #' #' ### delayed entry #' nn <- nrow(bmt) #' entrytime <- rbinom(nn,1,0.5)*(bmt$time*runif(nn)) #' bmt$entrytime <- entrytime #' #' bmtw <- prep.comp.risk(bmt,times=tau,time="time",entrytime="entrytime",cause="cause") #' #' out<-res.mean(Event(time,cause>=1)~factor(tcell)+factor(platelet),data=bmtw,cause=1, #' times=0,restricted=tau,n.sim=0,model="additive",estimator=1, #' cens.model="weights",weights=bmtw$cw,cens.weights=1/bmtw$weights); #' summary(out) #' #' @export res.mean<-function(formula,data=parent.frame(),cause=1,restricted=NULL,times=NULL,Nit=50, clusters=NULL,gamma=0,n.sim=0,weighted=0,model="additive",detail=0,interval=0.01,resample.iid=1, cens.model="KM",cens.formula=NULL,time.pow=NULL,time.pow.test=NULL,silent=1,conv=1e-6,estimator=1,cens.weights=NULL, conservative=1,weights=NULL){ ## {{{ # restricted residual mean life models, using IPCW # two models, additive and proportional # trans=1 E(min(Y,tau) - t | Y>= t) = ( x' b(b)+ z' gam (tau-t)) # trans=2 E(min(Y,tau) - t | Y>= t) = exp( x' b(b)+ z' gam (tau-t)) # unrestricted residual mean life models, using IPCW # trans=1 E(Y - t | Y>= t) = ( x' b(b)+ z' gam ) # trans=2 E(Y - t | Y>= t) = exp( x' b(b)+ z' gam ) if (model=="additive") trans<-1; if (model=="prop") trans<-2; if (model=="additive") Nit=2; ### one for estimation and one for residuals # estimator =1 E(min(Y,tau)-t | Y>=t) or E(Y - t | Y>=t) # estimator =2 Year lost due to cause 1 up to time tau given event # estimator =2 E( tau - min(T,tau) | T <= tau, epsilon=j) # estimator =3 PKA Years lost due to cause 1 up to time tau # estimator =3 E( tau - min(T_j,tau) | T>t ) = \int_t^tau (1-F_j(s)) ds / S(t) # estimator =3 E( tau - min(T,tau) | T <= tau, epsilon=j, T>t) * F_j(tau) cens.tau <- 1 line <- 0 m<-match.call(expand.dots = FALSE); m$gamma<-m$times<-m$cause<-m$Nit<-m$weighted<-m$n.sim<- ### m$cens.tau <- m$model<- m$detail<- m$cens.model<-m$time.pow<-m$silent<- m$interval<- m$clusters<-m$resample.iid<-m$restricted <- m$weights <- m$time.pow.test<-m$conv<-m$estimator <- m$cens.weights <- m$conservative <- m$cens.formula <- NULL special <- c("const","cluster") if (missing(data)) { Terms <- terms(formula, special) } else { Terms <- terms(formula, special, data = data) } m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept <- attr(mt, "intercept") Y <- model.extract(m, "response") ## {{{ Event stuff cens.code <- attr(Y,"cens.code") if (ncol(Y)==3) stop("Left-truncation, through weights \n"); time2 <- eventtime <- Y[,1] status <- delta <- Y[,2] event <- (status==cause) entrytime <- rep(0,length(time2)) if (sum(event)==0) stop("No events of interest in data\n"); ## }}} if (n.sim==0) sim<-0 else sim<-1; antsim<-n.sim; des<-read.design(m,Terms) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ; if(is.null(clusters)){ clusters <- des$clusters} if(is.null(clusters)){ clusters <- 0:(nrow(X) - 1) antclust <- nrow(X) } else { clusters <- as.integer(factor(clusters))-1 antclust <- length(unique(clusters)) } pxz <-px+pz; ### always survival case status; ### cause==1 and cause==0 censoring if (is.null(restricted)) tau <- max(time2)+0.1 else tau <- restricted if (is.null(times)) { times<-sort(unique(time2[status==cause])); if (tau>0) times <- times[times1]<-1; Gcx[Gcx<0]<-0 Gfit<-rbind(c(0,1),cbind(time2,Gcx)); Gctimes<-Cpred(Gfit,times)[,2]; Gctimes[Gctimes<=0] <- 1 ## }}} } else if (cens.model=="weights") { if (length(weights)!=n) stop(paste("Weights length=",length(weights),"do not have length \n",length(time2),"problems with missing values?\n")); Gcx <- cens.weights ord2 <- order(time2) Gctimes <- Cpred(cbind(time2[ord2],Gcx[ord2]),times) Gctimes[Gctimes<=0] <- 1 } else { stop('Unknown censoring model') } ## }}} if (resample.iid == 1) { biid <- double(ntimes* antclust * px); gamiid<- double(antclust *pg); } else { gamiid <- biid <- NULL; } ps<-px; hess<-matrix(0,ps,ps); var<-score<-matrix(0,ntimes,ps+1); if (sum(gamma)==0) gamma<-rep(0,pg); gamma2<-rep(0,ps); test<-matrix(0,antsim,3*ps); testOBS<-rep(0,3*ps); unifCI<-c(); testval<-c(); rani<--round(runif(1)*10000); Ut<-matrix(0,ntimes,ps+1); simUt<-matrix(0,ntimes,50*ps); var.gamma<-matrix(0,pg,pg); pred.covs.sem<-0 if (is.null(time.pow)==TRUE & !is.null(restricted)) time.pow<-rep(1,pg); if (is.null(time.pow.test)==TRUE & !is.null(restricted)) time.pow<-rep(1,pg); ### if (is.null(time.pow)==TRUE & model=="additive") time.pow<-rep(1,pg); if (is.null(time.pow)==TRUE & is.null(restricted)) time.pow<-rep(0,pg); if (is.null(time.pow.test)==TRUE & is.null(restricted)) time.pow<-rep(0,pg); silent <- c(silent,rep(0,ntimes-1)); if (!is.null(restricted)) time2 <- pmin(time2,restricted) ### print(restricted); print(time2); print(table(deltatau)); print(table(status)); ### print(table(status)); print(times); print(summary(Gctimes)); print(summary(Gcx)); ### important to start in 0 for linear model est<-matrix(0,ntimes,ps+1) if (model!="additive") est[,2] <- log(mean(time2)) betaS<-rep(0,ps); if (model=="prop") betaS[1] <- log(mean(time2)) ordertime <- order(eventtime); out<-.C("resmean", as.double(times),as.integer(ntimes),as.double(time2), as.integer(deltatau), as.integer(status),as.double(Gcx), as.double(X),as.integer(n),as.integer(px), as.integer(Nit), as.double(betaS), as.double(score), as.double(hess), as.double(est), as.double(var), as.integer(sim),as.integer(antsim),as.integer(rani), as.double(test), as.double(testOBS), as.double(Ut), as.double(simUt),as.integer(weighted),as.double(gamma), as.double(var.gamma),as.integer(fixed),as.double(Z), as.integer(pg),as.integer(trans),as.double(gamma2), as.integer(cause),as.integer(line),as.integer(detail), as.double(biid),as.double(gamiid),as.integer(resample.iid), as.double(time.pow),as.integer(clusters),as.integer(antclust), as.double(time.pow.test),as.integer(silent), as.double(conv),as.double(tau),as.integer(estimator), as.integer(cause),as.double(weights),as.double(Gctimes), as.integer(ordertime-1),as.integer(conservative),as.integer(cens.code), PACKAGE="timereg") gamma<-matrix(out[[24]],pg,1); var.gamma<-matrix(out[[25]],pg,pg); gamma2<-matrix(out[[30]],ps,1); rownames(gamma2)<-covnamesX; conv <- list(convp=out[[41]],convd=out[[42]]); if (fixed==0) gamma<-NULL; if (resample.iid==1) { biid<-matrix(out[[34]],ntimes,antclust*px); if (fixed==1) gamiid<-matrix(out[[35]],antclust,pg) else gamiid<-NULL; B.iid<-list(); for (i in (0:(antclust-1))*px) { B.iid[[i/px+1]]<-matrix(biid[,i+(1:px)],ncol=px); colnames(B.iid[[i/px+1]])<-covnamesX; } if (fixed==1) colnames(gamiid)<-covnamesZ } else B.iid<-gamiid<-NULL; if (sim==1) { simUt<-matrix(out[[22]],ntimes,50*ps); UIt<-list(); for (i in (0:49)*ps) UIt[[i/ps+1]]<-as.matrix(simUt[,i+(1:ps)]); Ut<-matrix(out[[21]],ntimes,ps+1); test<-matrix(out[[19]],antsim,3*ps); testOBS<-out[[20]]; supUtOBS<-apply(abs(as.matrix(Ut[,-1])),2,max); p<-ps for (i in 1:(3*p)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:p) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); pval.testBeq0<-as.vector(testval[1:p]); pval.testBeqC<-as.vector(testval[(p+1):(2*p)]); pval.testBeqC.is<-as.vector(testval[(2*p+1):(3*p)]); obs.testBeq0<-as.vector(testOBS[1:p]); obs.testBeqC<-as.vector(testOBS[(p+1):(2*p)]); obs.testBeqC.is<-as.vector(testOBS[(2*p+1):(3*p)]); sim.testBeq0<-as.matrix(test[,1:p]); sim.testBeqC<-as.matrix(test[,(p+1):(2*p)]); sim.testBeqC.is<-as.matrix(test[,(2*p+1):(3*p)]); } else {test<-unifCI<-Ut<-UIt<-pval.testBeq0<-pval.testBeqC<-obs.testBeq0<- obs.testBeqC<- sim.testBeq0<-sim.testBeqC<- sim.testBeqC.is<- pval.testBeqC.is<- obs.testBeqC.is<-NULL; } est<-matrix(out[[14]],ntimes,ps+1); score<-matrix(out[[12]],ntimes,ps+1); var<-matrix(out[[15]],ntimes,ps+1); colnames(var)<-colnames(est)<-c("time",covnamesX); if (sim>=1) { colnames(Ut)<- c("time",covnamesX) names(unifCI)<-names(pval.testBeq0)<- names(pval.testBeqC)<- names(pval.testBeqC.is)<- names(obs.testBeq0)<- names(obs.testBeqC)<- names(obs.testBeqC.is)<- colnames(sim.testBeq0)<- colnames(sim.testBeqC)<- colnames(sim.testBeqC.is)<- covnamesX; } if (fixed==1) { rownames(gamma)<-c(covnamesZ); colnames(var.gamma)<- rownames(var.gamma)<-c(covnamesZ); } colnames(score)<-c("time",covnamesX); if (is.na(sum(score))==TRUE) score<-NA else if (sum(score[,-1])<0.00001) score<-sum(score[,-1]); ud<-list(cum=est,var.cum=var,gamma=gamma,score=score, gamma2=gamma2,var.gamma=var.gamma,robvar.gamma=var.gamma, pval.testBeq0=pval.testBeq0,pval.testBeqC=pval.testBeqC, obs.testBeq0=obs.testBeq0, obs.testBeqC.is=obs.testBeqC.is, obs.testBeqC=obs.testBeqC,pval.testBeqC.is=pval.testBeqC.is, conf.band=unifCI,B.iid=B.iid,gamma.iid=gamiid, test.procBeqC=Ut,sim.test.procBeqC=UIt,conv=conv, cens.weights=Gcx,time=time2,delta.tau=deltatau,time2tau=time2tau) ud$call<-match.call(); ud$model<-model; ud$n<-n; ud$formula<-formula; class(ud)<-"resmean"; attr(ud, "Call") <- match.call() attr(ud, "Formula") <- formula attr(ud, "time.pow") <- time.pow attr(ud, "cause") <- cause attr(ud, "restricted") <- restricted attr(ud, "times") <- times attr(ud, "model") <- model attr(ud, "estimator") <- estimator return(ud); } ## }}} #' @export print.resmean <- function (x,...) { ## {{{ object <- x; rm(x); if (!inherits(object, 'resmean')) stop ("Must be an resmean object") if (is.null(object$gamma)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: cat(paste("Residual mean model with",object$model,"\n")) if (!is.null(attr(object,"restricted"))) cat(paste("Restricted at ",attr(object,"restricted","\n"))) cat("\n") cat(" Nonparametric terms : "); cat(colnames(object$cum)[-1]); cat(" \n"); if (semi) { cat(" Parametric terms : "); cat(rownames(object$gamma)); cat(" \n"); } if (object$conv$convd>=1) { cat("Warning problem with convergence for time points:\n") cat(object$cum[object$conv$convp>0,1]) cat("\nReadjust analyses by removing points\n") } cat(" \n"); } ## }}} #' @export coef.resmean <- function(object, digits=3,...) { ## {{{ coefBase(object,digits=digits) } ## }}} #' @export summary.resmean <- function (object,digits = 3,ci=0, alpha=0.05,silent=0, ...) { ## {{{ if (!inherits(object, 'resmean')) stop ("Must be a resmean object") if (is.null(object$gamma)==TRUE) semi<-FALSE else semi<-TRUE if (silent==0) { # We print information about object: cat(paste("Residual mean model with",object$model,"\n")) ### cat("Residual mean model \n\n") if (attr(object,"estimator")==1) cat("Residual mean life:") if (attr(object,"estimator")==2) cat("Years Lost to cause given event:") if (attr(object,"estimator")==3) cat("Years Lost to cause:") if (!is.null(attr(object,"restricted"))) cat(paste("Restricted at ",attr(object,"restricted","\n"))) cat("\n"); cat("\n") modelType<-object$model #if (modelType=="additive" || modelType=="rcif") if (sum(object$obs.testBeq0)==FALSE) cat("No test for non-parametric terms\n") else timetest(object,digits=digits); } if (semi) { if (silent==0) cat("Parametric terms : \n"); out=coef.resmean(object); out=signif(out,digits=digits) if (silent==0) { print(out); cat(" \n"); } } else { if (silent==0) cat("Non-Parametric terms : \n"); if (nrow(object$cum)==1) { out=cbind(c(object$cum[,-1]),c(object$var.cum[,-1]^.5)) colnames(out) <- c("resmean","se") out=signif(out,digits=digits) } else { se.cum <- object$var.cum[,-1]^.5 colnames(se.cum) <- paste("se",colnames(se.cum),paste="") out=cbind(object$cum,se.cum) out=signif(head(out),digits=digits) } if (silent==0) cat(" \n"); } if (ci==1) { out <- round(cbind(out,out[,1]+qnorm(alpha/2)*out[,2],out[,1]+qnorm(1-alpha/2)*out[,2]),digits=digits); nn <- ncol(out); colnames(out)[(nn-1):nn] <- c("lower","upper") } if (silent==0) { if (object$conv$convd>=1) { cat("WARNING problem with convergence for time points:\n") cat(object$cum[object$conv$convp>0,1]) cat("\nReadjust analyses by removing points\n\n") } cat(" Call: \n") dput(attr(object, "Call")) cat("\n") } out } ## }}} #' @export vcov.resmean <- function(object, ...) { rv <- object$robvar.gamma if (!identical(rv, matrix(0, nrow = 1L, ncol = 1L))) rv # else return NULL } #' @export plot.resmean <- function (x, pointwise.ci=1, hw.ci=0, sim.ci=0, specific.comps=FALSE,level=0.05, start.time = 0, stop.time = 0, add.to.plot=FALSE, mains=TRUE, xlab="Time", ylab ="Coefficients",score=FALSE,...){ ## {{{ object <- x; rm(x); if (!inherits(object,'resmean') ){ stop ("Must be output from res.mean function") } if (score==FALSE) { B<-object$cum; V<-object$var.cum; p<-dim(B)[[2]]; if (sum(specific.comps)==FALSE){ comp<-2:p } else { comp<-specific.comps+1 } if (stop.time==0) { stop.time<-max(B[,1]); } med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; V<-V[med,]; c.alpha<- qnorm(1-level/2) for (v in comp) { c.alpha<- qnorm(1-level/2) est<-B[,v]; ul<-B[,v]+c.alpha*V[,v]^.5; nl<-B[,v]-c.alpha*V[,v]^.5; if (add.to.plot==FALSE) { plot(B[,1],est,ylim=1.05*range(ul,nl),type="l",xlab=xlab,ylab=ylab) if (mains==TRUE) title(main=colnames(B)[v]); } else { lines(B[,1],est,type="l"); } if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="l"); lines(B[,1],nl,lty=pointwise.ci,type="l"); } if (hw.ci>=1) { if (level!=0.05){ cat("Hall-Wellner bands only 95 % \n"); } tau<-length(B[,1]) nl<-B[,v]-1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) ul<-B[,v]+1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) lines(B[,1],ul,lty=hw.ci,type="l"); lines(B[,1],nl,lty=hw.ci,type="l"); } if (sim.ci>=1) { if (is.null(object$conf.band)==TRUE){ cat("Uniform simulation based bands only computed for n.sim> 0\n") } if (level!=0.05){ c.alpha<-percen(object$sim.testBeq0[,v-1],1-level) } else { c.alpha<-object$conf.band[v-1]; } nl<-B[,v]-c.alpha*V[,v]^.5; ul<-B[,v]+c.alpha*V[,v]^.5; lines(B[,1],ul,lty=sim.ci,type="l"); lines(B[,1],nl,lty=sim.ci,type="l"); } abline(h = 0) } } else { # plot score proces if (is.null(object$pval.testBeqC)==TRUE) { cat("Simulations not done \n"); cat("To construct p-values and score processes under null n.sim>0 \n"); } else { if (ylab=="Cumulative regression function"){ ylab<-"Test process"; } dim1<-ncol(object$test.procBeqC) if (sum(specific.comps)==FALSE){ comp<-2:dim1 } else { comp<-specific.comps+1 } for (i in comp){ ranyl<-range(object$test.procBeqC[,i]); for (j in 1:50){ ranyl<-range(c(ranyl,(object$sim.test.procBeqC[[j]])[,i-1])); } mr<-max(abs(ranyl)); plot(object$test.procBeqC[,1], object$test.procBeqC[,i], ylim=c(-mr,mr),lwd=2,xlab=xlab,ylab=ylab,type="l") if (mains==TRUE){ title(main=colnames(object$test.procBeqC)[i]); } for (j in 1:50){ lines(object$test.procBeqC[,1], as.matrix(object$sim.test.procBeqC[[j]])[,i-1],col="grey",lwd=1,lty=1,type="l") } lines(object$test.procBeqC[,1],object$test.procBeqC[,i],lwd=2,type="l") } } } } ## }}} timereg/R/dynadd.r0000644000176200001440000002540214421510276013542 0ustar liggesusersdynregBase<-function(times,status,response,fdata,designX,designA,id, clusters, bhat=NULL,b=1,sim=1,antsim=1000,resample=0,smoothXX=0, weighted.test=0) { Ntimes <- length(times) designA<-as.matrix(designA); pa <- as.integer(dim(designA)[2]); na <- as.integer(dim(designA)[1]) designX<-as.matrix(designX); px <- as.integer(dim(designX)[2]); nx <- as.integer(dim(designX)[1]) #if (nx!=na) print(" A design og B designs er ikke ens\n"); w<-rep(1,nx); mw<-0; vcum.ly<-cum.ly<-cum0<-cumf<-cum.ms<-vcum0<-vcumf<-robvcumf<-matrix(0,Ntimes,px+1); ly<-NULL; if (resample==1) cumBi<-matrix(0,Ntimes,fdata$antpers*px) else cumBi<-0; test<-matrix(0,antsim,3*px); testOBS<-rep(0,3*px); testval<-c(); unifCI<-c(); rani<--round(runif(1)*10000) # 50 tilfaeldige score processer til test H: b(t)=b returneres if (sim==1) simUt<-matrix(0,Ntimes,50*px) else simUt<-NULL; Ut<-matrix(0,Ntimes,px+1); if (is.null(id) == TRUE) { antpers <- length(time); id <- 0:(antpers - 1); } else { pers <- unique(id); antpers <- length(pers); id<-as.integer(factor(id, labels = 1:(antpers))) - 1; } clusters<-id; antclust<-antpers; fdata$antpers <- antpers; fdata$antclust <- antclust out.aalen<-aalenBaseC(times,fdata,designA,status,id,clusters); ###aalenBase(times,fdata,designX,status,id,clusters,robust=0,sim=0,retur=0,antsim=1000,weighted.test=1, ### covariance=0,resample.iid=0,namesX=NULL,silent=0,weights=NULL,entry=NULL,offsets=0) if (!is.null(bhat)) xval<-bhat[,1] else xval<-seq(times[2],times[Ntimes],length=30); smooth.aalen<-CsmoothB(out.aalen$cum,xval,b); nxval<-length(xval); #print(smooth.aalen[,1:4]); print(bhat); if (is.null(bhat)) { bhat<-matrix(0,nxval,px+1); bhat[,1]<-smooth.aalen[,1];} if (length(b)==1) b<-rep(b,nxval); bhatny<-bhat nparout<-.C("dynadd", as.double(times),as.double(response),as.integer(Ntimes), as.double(designX),as.integer(nx),as.integer(px), as.double(designA),as.integer(na),as.integer(pa), as.double(smooth.aalen),as.double(bhat),as.double(bhatny), as.integer(nxval),as.integer(fdata$antpers),as.double(fdata$start), as.double(fdata$stop), as.double(cum0), as.double(cumf), as.double(cum.ms), as.double(vcum0), as.double(vcumf), as.double(robvcumf), as.double(w),as.integer(mw),as.integer(rani), as.integer(sim),as.integer(antsim), as.double(cumBi), as.double(test),as.double(testOBS), as.integer(status),as.double(Ut),as.double(simUt), as.double(b),as.double(cum.ly),as.integer(resample),as.integer(id), as.integer(smoothXX),as.integer(weighted.test),as.double(vcum.ly), as.integer(clusters),as.integer(fdata$antclust)) ### , PACKAGE="timereg") cum0 <-matrix(nparout[[17]],Ntimes,px+1); cumf <-matrix(nparout[[18]],Ntimes,px+1); cum.ms <-matrix(nparout[[19]],Ntimes,px+1); vcum0 <-matrix(nparout[[20]],Ntimes,px+1); vcumf <-matrix(nparout[[21]],Ntimes,px+1); robvcumf <-matrix(nparout[[22]],Ntimes,px+1); cum.ly <-matrix(nparout[[35]],Ntimes,px+1) vcum.ly <-matrix(nparout[[40]],Ntimes,px+1) if (resample==1) { cumBi<-matrix(nparout[[28]],Ntimes,fdata$antpers*px); cumBI<-list(); for (i in (0:(fdata$antpers-1))*px) cumBI[[i/px+1]]<-as.matrix(cumBi[,i+(1:px)]); } else cumBI<-NULL; if (sim==1) { Uit<-matrix(nparout[[33]],Ntimes,50*px); UIt<-list(); for (i in (0:49)*px) UIt[[i/px+1]]<-Uit[,i+(1:px)]; Ut<-matrix(nparout[[32]],Ntimes,(px+1)); test<-matrix(nparout[[29]],antsim,3*px); testOBS<-nparout[[30]]; for (i in 1:(3*px)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:px) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); pval.testBeq0<-as.vector(testval[1:px]); pval.testBeqC<-as.vector(testval[(px+1):(2*px)]); pval.testBeqC.is<-as.vector(testval[(2*px+1):(3*px)]); obs.testBeq0<-as.vector(testOBS[1:px]); obs.testBeqC<-as.vector(testOBS[(px+1):(2*px)]); obs.testBeqC.is<-as.vector(testOBS[(2*px+1):(3*px)]); sim.testBeq0<-as.matrix(test[,1:px]); sim.testBeqC<-as.matrix(test[,(px+1):(2*px)]); sim.testBeqC.is<-as.matrix(test[,(2*px+1):(3*px)]); } else {test<-NULL; unifCI<-NULL; Ut<-NULL; UIt<-NULL; pval.testBeqC.is<-NULL; obs.testBeqC.is<-NULL; sim.testBeqC.is<-NULL; pval.testBeq0<-NULL;pval.testBeqC<-NULL; obs.testBeq0<-NULL;obs.testBeqC<-NULL; sim.testBeq0<-NULL;sim.testBeqC<-NULL; } out <- list(cum=cumf,var.cum=vcumf,robvar.cum=robvcumf, cum0=cum0,var.cum0=vcum0, cum.ms=cum.ms,var.cum.ms=vcumf, cum.ly=cum.ly,var.cum.ly=vcum.ly, B.iid=cumBI, pval.testBeq0=pval.testBeq0,pval.testBeqC=pval.testBeqC, pval.testBeqC.is=pval.testBeqC.is, obs.testBeqC.is=obs.testBeqC.is, sim.testBeqC.is=sim.testBeqC.is, obs.testBeq0=obs.testBeq0,obs.testBeqC=obs.testBeqC, sim.testBeq0= sim.testBeq0,sim.testBeqC=sim.testBeqC, conf.band=unifCI,test.procBeqC=Ut,sim.test.procBeqC=UIt) return(out) } semiregBase<-function(times,status,response,fdata,designX, designG,designA,id,clusters,gamma=0,bhat=NULL,b=1,sim=1,antsim=1000, resample=0,weighted.test=0) { Ntimes <- length(times); maxtime<-times[Ntimes]; designX<-as.matrix(designX); designG<-as.matrix(designG); designA<-as.matrix(designA); px <- as.integer(dim(designX)[2]); nx <- as.integer(dim(designX)[1]) pg <- as.integer(dim(designG)[2]); ng <- as.integer(dim(designG)[1]) pa <- as.integer(dim(designA)[2]); nar <- as.integer(dim(designA)[1]) if (nx!=nar) print("Aalen-design and X designs are not consistent\n"); if (nx!=ng) print("Semi-design and and X designs are not consistent\n"); if (resample==1) { gamma.iid<-matrix(0,fdata$antpers,pg); B.iid<-matrix(0,Ntimes,fdata$antpers*px) } else { B.iid<-gamma.iid<-NULL; } w<-rep(1,nx); mw<-0; cumly<-cum0<-cumf<-cumMS<-vcum0<-vcumf<-robvcumf<-matrix(0,Ntimes,px+1); test<-matrix(0,antsim,3*px); testOBS<-rep(0,3*px); testval<-c(); unifCI<-c(); rani<--round(runif(1)*10000) # 50 tilfaeldige score processer til test H: b(t)=b returneres if (sim==1) simUt<-matrix(0,Ntimes,50*px) else simUt<-NULL; Ut<-matrix(0,Ntimes,px+1); resid<-matrix(0,Ntimes,fdata$antpers*px) if (is.null(id) == TRUE) { antpers <- length(time); id <- 0:(antpers - 1);} else { pers <- unique(id); antpers <- length(pers); id<-as.integer(factor(id, labels = 1:(antpers))) - 1; } clusters<-id; antclust<-antpers; fdata$antpers <- antpers; fdata$antclust <- antclust out.aalen<-aalenBaseC(times,fdata,designA,status,id,clusters); xval<-seq(times[2],times[Ntimes],length=30); smooth.aalen<-CsmoothB(out.aalen$cum,xval,b); #print(smooth.aalen); naval<-nrow(smooth.aalen); if (length(b)==1) b<-rep(b,naval); if (is.null(bhat)) {bhat<-matrix(0,naval,px+pg+1); bhat[,1]<-smooth.aalen[,1];} nxval<-nrow(bhat); bhatny<-bhat; if (sum(gamma)==0) gamma<-apply(bhat[,(px+2):(px+pg+1)],1,mean); #print("Prelim estimate of gamma based on non-parametric model is"); gamma2<-gamly<-gamkor<-gameffi<-gameffims<-gamma cum0<-cumf<-cumef<-rvcum<-rvcumef<-matrix(0,Ntimes,px+1); Vgam0<-Vgamef<-Vkorgam<-robvargam<-robvargame<-VgammaLY<-Vgamma<-Vkorgam<-C<-matrix(0,pg,pg); semiout<-.C("semidynadd", as.double(times),as.double(response),as.integer(Ntimes), as.double(designX),as.integer(nx),as.integer(px), as.double(designG),as.integer(ng),as.integer(pg), as.double(designA),as.integer(nar),as.integer(pa), as.double(smooth.aalen),as.integer(naval),as.double(bhat), as.integer(nxval),as.integer(fdata$antpers),as.double(fdata$start), as.double(fdata$stop),as.double(cum0),as.double(cumf), as.double(cumMS), as.double(rvcum), as.double(rvcumef), as.double(gamma),as.double(gamma2),as.double(gamly), as.double(gamkor),as.double(gameffi),as.double(gameffims), as.double(Vgamma),as.double(Vkorgam),as.double(Vgamef), as.double(robvargam),as.double(robvargame), as.double(w), as.integer(mw), as.integer(rani), as.integer(sim), as.integer(antsim), as.double(resid),as.double(test), as.double(testOBS), as.double(Ut),as.double(simUt), as.double(b),as.integer(id), as.integer(status), as.integer(weighted.test),as.double(VgammaLY),as.integer(clusters), as.integer(fdata$antclust), as.integer(resample),as.double(gamma.iid), as.double(B.iid), PACKAGE="timereg") if (resample==1) { gamma.iid<-matrix(semiout[[54]],fdata$antclust,pg); covit<-matrix(semiout[[55]],Ntimes,fdata$antclust*px); B.iid<-list(); for (i in (0:(fdata$antclust-1))*px) { B.iid[[(i/px)+1]]<-as.matrix(covit[,i+(1:px)]); ###colnames(B.iid[[i/px+1]])<-namesX; } ###colnames(gamma.iid)<-namesZ } } cum0 <-matrix(semiout[[20]],Ntimes,px+1); cumf <-matrix(semiout[[21]],Ntimes,px+1); cum.ms <-matrix(semiout[[22]],Ntimes,px+1); vcumf<-matrix(semiout[[23]],Ntimes,px+1); robvcumf<-matrix(semiout[[23]],Ntimes,px+1); vcum0 <-NULL; #cum.ly<-matrix(semiout[[36]],Ntimes,px+1); cum.ly<-NULL; var.cum.ly<-NULL; gamma<-matrix(semiout[[25]],pg,1); gamma2<-matrix(semiout[[26]],pg,1); gamly<-matrix(semiout[[27]],pg,1); gamkor<-matrix(semiout[[28]],pg,1); gameffi<-matrix(semiout[[29]],pg,1); gameffims<-matrix(semiout[[30]],pg,1); Vgamma<-matrix(semiout[[31]],pg,pg); Vkorgam<-matrix(semiout[[32]],pg,pg); Vgamef<-matrix(semiout[[33]],pg,pg); robvargam<-matrix(semiout[[34]],pg,pg); robvargame<-matrix(semiout[[35]],pg,pg); VgammaLY<-matrix(semiout[[50]],pg,pg); if (resample==1) { cumBi<-matrix(semiout[[41]],Ntimes,fdata$antpers*px); cumBI<-list(); for (i in (0:(fdata$antpers-1))*px) cumBI[[i/px+1]]<-cumBi[,i+(1:px)] } else cumBI<-NULL; if (sim==1) { test<-matrix(semiout[[42]],antsim,3*px); testOBS<-semiout[[43]]; Ut<-matrix(semiout[[44]],Ntimes,(px+1)); Uit<-matrix(semiout[[45]],Ntimes,50*px); UIt<-list(); for (i in (0:49)*px) UIt[[i/px+1]]<-Uit[,i+(1:px)]; for (i in 1:(3*px)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:px) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); pval.testBeq0<-as.vector(testval[1:px]); pval.testBeqC<-as.vector(testval[(px+1):(2*px)]); pval.testBeqC.is<-as.vector(testval[(2*px+1):(3*px)]); obs.testBeq0<-as.vector(testOBS[1:px]); obs.testBeqC<-as.vector(testOBS[(px+1):(2*px)]); obs.testBeqC.is<-as.vector(testOBS[(2*px+1):(3*px)]); sim.testBeq0<-as.matrix(test[,1:px]); sim.testBeqC<-as.matrix(test[,(px+1):(2*px)]); sim.testBeqC.is<-as.matrix(test[,(2*px+1):(3*px)]); } else {test<-NULL; unifCI<-NULL; Ut<-NULL; UIt<-NULL; pval.testBeq0<-NULL; obs.testBeq0<-NULL; sim.testBeq0<-NULL; pval.testBeqC<-NULL; obs.testBeqC<-NULL; sim.testBeqC<-NULL; pval.testBeqC.is<-NULL; obs.testBeqC.is<-NULL; sim.testBeqC.is<-NULL; } #gamma.ef=gameffi,gamma.efms=gameffims, #var.gamma.ef=Vgamef,robvar.gamma.ef=robvargame, out <- list(cum=cumf,var.cum=vcumf,robvar.cum=robvcumf,cum.ms=cum.ms, cum0=cum0,var.cum0=vcum0,cum.ly=cum.ly,var.cum.ly=NULL, gamma0=gamma,var.gamma0=Vgamma,gamma.ly=gamly,var.gamma.ly=VgammaLY, gamma=gamkor,gamma.ms=gamma2,var.gamma=Vkorgam,var.gamma.ms=Vkorgam, robvar.gamma=robvargam, residuals=cumBI, pval.testBeq0=pval.testBeq0, pval.testBeqC=pval.testBeqC, pval.testBeqC.is=pval.testBeqC.is, obs.testBeqC.is=obs.testBeqC.is, sim.testBeqC.is=sim.testBeqC.is, obs.testBeq0=obs.testBeq0,obs.testBeqC=obs.testBeqC, sim.testBeq0= sim.testBeq0,sim.testBeqC=sim.testBeqC, conf.band=unifCI,test.procBeqC=Ut,sim.test.procBeqC=UIt, gamma.iid=gamma.iid, B.iid=B.iid) return(out) } timereg/R/cox.marg.r0000644000176200001440000000542314421510301014003 0ustar liggesusers #' @export cox.marg <- function(survformula,glmformula,d=parent.frame(),max.clust=NULL,ipw.se=FALSE,tie.seed=100) { ## {{{ ggl <- glm(glmformula,family='binomial',data=d) mat <- model.matrix(glmformula,data=d); glmcovs <- attr(ggl$terms,"term.labels") ppp <-predict(ggl,type="response") ppp[ggl$y==0] <- 1- ppp[ggl$y==0] d$ppp <- ppp ### dcc <- na.omit(d) ## {{{ checking and breaking ties ties <- FALSE survtimes <- all.vars(update(survformula,.~0)) if (length(survtimes)==2) {itime <- 1; time2 <- d[,survtimes[1]]; status <- d[,survtimes[2]]; } if (length(survtimes)==3) {itime <- 2; time2 <- d[,survtimes[2]]; status <- d[,survtimes[3]]; } jtimes <- time2[status==1]; dupli <- duplicated(jtimes) if (sum(dupli)>0) { set.seed(tie.seed) jtimes[dupli] <- jtimes[dupli]+runif(sum(dupli))*0.01 time2[status==1] <- jtimes d[,survtimes[itime]] <- time2 ties <- TRUE } ## }}} ### dcc <- d[ggl$y==1,] dcc <- d ppp <- dcc$ppp ### print(head(1/ppp)) timeregformula <- timereg.formula(survformula) udcox <- coxph(survformula,data=dcc,weights=1/ppp) udca <- cox.aalen(timeregformula,data=dcc,weights=1/ppp,n.sim=0,max.clust=max.clust) ### print(summary(udca)) ### iid of beta for Cox model coxiid <- udca$gamma.iid if (ipw.se==TRUE) { ## {{{ ###requireNamespace("lava"); requireNamespace("NumDeriv"); glmiid <- lava::iid(ggl) ###mat <- mat par <- coef(ggl) coxalpha <- function(par) { ## {{{ rr <- mat %*% par pw <- c(exp(rr)/(1+exp(rr))) pw[ggl$y==0] <- 1 - pw[ggl$y==0] assign("pw",pw,envir=environment(survformula)) ### if (coxph==FALSE) ud <- cox.aalen(timeregformula,data=dcc,weights=1/pw,beta=udca$gamma,Nit=1,n.sim=0,robust=0) ### else { ud <- coxph(survformula,data=dcc,weights=1/pw,iter.max=1,init=udca$gamma) ### ud <- coxph.detail(ud,data=dcc) ### } ud$score } ## }}} DU <- numDeriv::jacobian(coxalpha,par,) IDU <- udca$D2linv %*% DU alphaiid <-t( IDU %*% t(glmiid)) ### iidfull <- alphaiid ### iidfull <- coxiid + alphaiid ### var2 <- t(iidfull) %*% iidfull se <- cbind(diag(var2)^.5); colnames(se) <- "se" } else { iidfull <- NULL; var2 <- NULL; se <- NULL} ## }}} se.naive=coef(udca)[,3,drop=FALSE]; colnames(se.naive) <- "se.naive" res <- list(iid=iidfull,coef=udca$gamma,var=var2,se=se,se.naive=se.naive,ties=list(ties=ties,time2=time2,cox=udca)) class(res) <- "cox.marg" return(res) } ## }}} #' @export summary.cox.marg <- function(object,digits=3,...) { tval <- object$coef/object$se pval <- 2*(1-pnorm(abs(tval))) res <- cbind(object$coef,object$se,object$se.naive,pval) colnames(res) <- c("coef","se","se.naive","pval") return(res) } #' @export coef.cox.marg<- function(object,digits=3,...) { summary.cox.marg(object) } #' @export print.cox.marg <- function(x,...) { summary.cox.marg(x) } timereg/R/prop-odds-subdist.r0000644000176200001440000005031414421510301015646 0ustar liggesusers#' Fit Semiparametric Proportional 0dds Model for the competing risks #' subdistribution #' #' Fits a semiparametric proportional odds model: \deqn{ logit(F_1(t;X,Z)) = #' log( A(t)) + \beta^T Z }{} where A(t) is increasing but otherwise unspecified. #' Model is fitted by maximising the modified partial likelihood. A #' goodness-of-fit test by considering the score functions is also computed by #' resampling methods. #' #' An alternative way of writing the model : \deqn{ F_1(t;X,Z) = \frac{ \exp( #' \beta^T Z )}{ (A(t)) + \exp( \beta^T Z) } }{} such that \eqn{\beta} is the #' log-odds-ratio of cause 1 before time t, and \eqn{A(t)} is the odds-ratio. #' #' The modelling formula uses the standard survival modelling given in the #' \bold{survival} package. #' #' The data for a subject is presented as multiple rows or "observations", each #' of which applies to an interval of observation (start, stop]. The program #' essentially assumes no ties, and if such are present a little random noise #' is added to break the ties. #' #' @param formula a formula object, with the response on the left of a '~' #' operator, and the terms on the right. The response must be an object as #' returned by the `Event' function. #' @param data a data.frame with the variables. #' @param cause cause indicator for competing risks. #' @param beta starting value for relative risk estimates #' @param Nit number of iterations for Newton-Raphson algorithm. #' @param detail if 0 no details is printed during iterations, if 1 details are #' given. #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. This is very useful to #' obtain stable estimates, especially for the baseline. Default is max of #' data. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing time-varying effects. #' @param profile use profile version of score equations. #' @param sym to use symmetrized second derivative in the case of the #' estimating equation approach (profile=0). This may improve the numerical #' performance. #' @param cens.model specifies censoring model. So far only Kaplan-Meier "KM". #' @param cens.formula possible formula for censoring distribution covariates. #' Default all ! #' @param clusters to compute cluster based standard errors. #' @param max.clust number of maximum clusters to be used, to save time in iid #' decomposition. #' @param baselinevar set to 0 to save time on computations. #' @param weights additional weights. #' @param cens.weights specify censoring weights related to the observations. #' @return returns an object of type 'cox.aalen'. With the following arguments: #' #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval.} \item{var.cum}{the martingale #' based pointwise variance estimates. } \item{robvar.cum}{robust pointwise #' variances estimates. } \item{gamma}{estimate of proportional odds #' parameters of model.} \item{var.gamma}{variance for gamma. } #' \item{robvar.gamma}{robust variance for gamma. } \item{residuals}{list with #' residuals. Estimated martingale increments (dM) and corresponding time #' vector (time).} \item{obs.testBeq0}{observed absolute value of supremum of #' cumulative components scaled with the variance.} #' \item{pval.testBeq0}{p-value for covariate effects based on supremum test.} #' \item{sim.testBeq0}{resampled supremum values.} \item{obs.testBeqC}{observed #' absolute value of supremum of difference between observed cumulative process #' and estimate under null of constant effect.} \item{pval.testBeqC}{p-value #' based on resampling.} \item{sim.testBeqC}{resampled supremum values.} #' \item{obs.testBeqC.is}{observed integrated squared differences between #' observed cumulative and estimate under null of constant effect.} #' \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{sim.testBeqC.is}{resampled supremum values.} #' \item{conf.band}{resampling based constant to construct robust 95\% uniform #' confidence bands. } \item{test.procBeqC}{observed test-process of difference #' between observed cumulative process and estimate under null of constant #' effect over time.} \item{loglike}{modified partial likelihood, pseudo #' profile likelihood for regression parameters.} \item{D2linv}{inverse of the #' derivative of the score function.} \item{score}{value of score for final #' estimates.} \item{test.procProp}{observed score process for proportional #' odds regression effects.} \item{pval.Prop}{p-value based on resampling.} #' \item{sim.supProp}{re-sampled supremum values.} #' \item{sim.test.procProp}{list of 50 random realizations of test-processes #' for constant proportional odds under the model based on resampling.} #' @author Thomas Scheike #' @references Eriksson, Li, Zhang and Scheike (2014), The proportional odds #' cumulative incidence model for competing risks, Biometrics, to appear. #' #' Scheike, A flexible semiparametric transformation model for survival data, #' Lifetime Data Anal. (2007). #' #' Martinussen and Scheike, Dynamic Regression Models for Survival Data, #' Springer (2006). #' @keywords survival #' @examples #' #' library(timereg) #' data(bmt) #' # Fits Proportional odds model #' out <- prop.odds.subdist(Event(time,cause)~platelet+age+tcell,data=bmt, #' cause=1,cens.model="KM",detail=0,n.sim=1000) #' summary(out) #' par(mfrow=c(2,3)) #' plot(out,sim.ci=2); #' plot(out,score=1) #' #' # simple predict function without confidence calculations #' pout <- predictpropodds(out,X=model.matrix(~platelet+age+tcell,data=bmt)[,-1]) #' matplot(pout$time,pout$pred,type="l") #' #' # predict function with confidence intervals #' pout2 <- predict(out,Z=c(1,0,1)) #' plot(pout2,col=2) #' pout1 <- predictpropodds(out,X=c(1,0,1)) #' lines(pout1$time,pout1$pred,type="l") #' #' # Fits Proportional odds model with stratified baseline, does not work yet! #' ###out <- Gprop.odds.subdist(Surv(time,cause==1)~-1+factor(platelet)+ #' ###prop(age)+prop(tcell),data=bmt,cause=bmt$cause, #' ###cens.code=0,cens.model="KM",causeS=1,detail=0,n.sim=1000) #' ###summary(out) #' ###par(mfrow=c(2,3)) #' ###plot(out,sim.ci=2); #' ###plot(out,score=1) #' #' @export prop.odds.subdist<-function(formula,data=parent.frame(),cause=1,beta=NULL, Nit=10,detail=0,start.time=0,max.time=NULL,id=NULL,n.sim=500,weighted.test=0, profile=1,sym=0,cens.model="KM",cens.formula=NULL, clusters=NULL,max.clust=1000,baselinevar=1,weights=NULL, cens.weights=NULL) { ## {{{ ## {{{ if (!missing(cause)){ if (length(cause)!=1) stop("Argument cause specifies the cause of interest, see help(prop.odds.subdist) for details.") } ## {{{ reading formula rate.sim <- 1 cause.call <- causeS <- cause m<-match.call(expand.dots=FALSE); if (n.sim==0) sim<-0 else sim<-1; antsim<-n.sim; id.call<-id; residuals<-0; robust<-1; resample.iid <- 1 m$cens.model <- m$cause <- m$sym<-m$profile <- m$max.time<- m$start.time<- m$weighted.test<- m$n.sim<- m$id<-m$Nit<-m$detail<-m$beta <- m$baselinevar <- m$clusters <- m$max.clust <- m$weights <- NULL m$cens.weights <- m$cens.formula <- NULL special <- c("cluster") if (missing(data)) { Terms <- terms(formula, special) } else { Terms <- terms(formula, special, data = data) } m$formula <- Terms if (substr(as.character(m$formula)[2],1,4)=="Hist") { stop("Since timereg version 1.8.6.: The left hand side of the formula must be specified as Event(time, event) or with non default censoring codes Event(time, event, cens.code=0).") } if (substr(as.character(m$formula)[2],1,4)=="Surv") stop("Must call with Event(time,cause) \n"); m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) if (NROW(m) == 0) stop("No (non-missing) observations") mt <- attr(m, "terms") intercept <- attr(mt, "intercept") event.history <- model.extract(m, "response") ## }}} ## {{{ Hist to Event stuff if (match("Hist",class(event.history),nomatch=0)==1){ stop("Since timereg version 1.8.6., the right hand side of the formula must be specified as Event(time, event) or Event(time, event, cens.code=0).") } ## }}} ## {{{ Event stuff if (match("Surv",class(event.history),nomatch=0)==1){ } else { cens.code <- attr(event.history,"cens.code") time2 <- eventtime <- event.history[,1] status <- delta <- event.history[,2] event <- (status==cause) entrytime <- rep(0,length(time2)) if (sum(event)==0) stop("No events of interest in data\n"); } ## }}} ## {{{ if (n.sim==0) sim<-0 else sim<-1; antsim<-n.sim; desX <- model.matrix(Terms, m)[,-1,drop=FALSE]; covnamesX<-dimnames(desX)[[2]]; ###desX<-as.matrix(X); if(is.matrix(desX) == TRUE) pg <- as.integer(dim(desX)[2]) if(is.matrix(desX) == TRUE) nx <- as.integer(dim(desX)[1]) px<-1; if ( (nx!=nrow(data)) & (!is.null(id))) stop("Missing values in design matrix not allowed with id \n"); # adds random noise to make survival times unique time2 <- eventtime jtimes <- time2[event==1] if (sum(duplicated(jtimes))>0) { ties<-TRUE index<-(1:length(time2))[event==1] ties<-duplicated(jtimes); nties<-sum(ties); index<-index[ties] dt<-diff(sort(jtimes)); dt<-min(dt[dt>0]); time2[index]<-time2[index]+runif(nties,0,min(0.001,dt/2)); } else ties<-FALSE; times<-time2[event==1]; index<-(1:length(time2))[event==1]; index <- index[order(times)]; times<-sort(times); times <- c(start.time,times) index <- c(0,index) start <- entrytime stop <- time2 if (is.null(max.time)==TRUE) maxtimes<-max(times)+0.1 else maxtimes<-max.time; times<-times[times<=maxtimes] Ntimes <- length(times); ## }}} ## {{{ cluster and id set up if (is.null(id)==TRUE) {antpers<-length(time2); id<-0:(antpers-1); } else { pers<-unique(id); antpers<-length(pers); id<-as.integer(factor(id,labels=1:(antpers)))-1; } cluster.call<-clusters; if (is.null(clusters)== TRUE) {clusters<-id; antclust<-antpers;} else { clus<-unique(clusters); antclust<-length(clus); clusters <- as.integer(factor(clusters, labels = 1:(antclust))) - 1; } if ((!is.null(max.clust))) if (max.clust5) { cat("Warning, starting values from Cox model large, may set beta=\n") } } if (residuals==1) { cumAi<-matrix(0,Ntimes,antpers*1); cumAiiid<-matrix(0,Ntimes,antpers*1); } else { cumAi<-0; cumAiiid<-0; } cumint<-matrix(0,Ntimes,px+1); vcum<-matrix(0,Ntimes,px+1); Rvcu<-matrix(0,Ntimes,px+1); score<-beta; Varbeta<-matrix(0,pg,pg); Iinv<-matrix(0,pg,pg); RVarbeta<-matrix(0,pg,pg); if (sim==1) Uit<-matrix(0,Ntimes,50*pg) else Uit<-NULL; test<-matrix(0,antsim,2*px); testOBS<-rep(0,2*px); unifCI<-c(); testval<-c(); rani<--round(runif(1)*10000); Ut<-matrix(0,Ntimes,pg+1); simUt<-matrix(0,antsim,pg); loglike<-0; ## }}} ## {{{ censoring and estimator if (is.null(cens.weights)) { ## {{{ censoring model stuff with possible truncation if (cens.model=="KM") { ## {{{ ud.cens<-survfit(Surv(time2,delta==cens.code)~+1); Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); KMti<-Cpred(Gfit,time2)[,2]; KMtimes<-Cpred(Gfit,times)[,2]; ## }}} } else if (cens.model=="cox") { ## {{{ if (!is.null(cens.formula)) desXc <- model.matrix(cens.formula,data=data)[,-1] else desXc <- desX; ud.cens<-cox.aalen(Surv(time2,delta==cens.code)~prop(desXc),n.sim=0,robust=0) ### baseout <- basehaz(ud.cens,centered=FALSE); ### baseout <- cbind(baseout$time,baseout$hazard) Gcx<-Cpred(ud.cens$cum,time2)[,2]; RR<-exp(desXc %*% ud.cens$gamma) KMti<-exp(-Gcx*RR) KMtimes<-Cpred(cbind(time2,KMti),times)[,2]; ## }}} } else if (cens.model=="aalen") { ## {{{ if (!is.null(cens.formula)) desXc <- model.matrix(cens.formula,data=data) else desXc <- desX; ud.cens<-aalen(Surv(time2,delta==cens.code)~desXc+ cluster(clusters),n.sim=0,residuals=0,robust=0,silent=1) KMti <- Cpred(ud.cens$cum,time2)[,-1]; Gcx<-exp(-apply(Gcx*desXc,1,sum)) Gcx[Gcx>1]<-1; Gcx[Gcx<0]<-0 Gfit<-rbind(c(0,1),cbind(time2,Gcx)); KMti <- Gcx KMtimes<-Cpred(Gfit,times)[,2]; ## }}} } else if (cens.model=="test") { KMti <- 1-time2/6; KMtimes <- 1-times/6; } else if (cens.model=="po") { KMti <- rep(1,length(time2)); KMtimes <- rep(1,length(times)); } else { stop('Unknown censoring model') } } else { if (length(cens.weights)!=nx) stop("censoring weights must have length equal to nrow in data\n"); KMti <- cens.weights Gctimes <- rep(1,length(times)); ord2 <- order(time2) KMtimes<-Cpred(cbind(time2[ord2],cens.weights[ord2]),times)[,2]; } ## }}} if (is.null(weights)) weights <- rep(1,nx); if (length(weights)!=nx) stop("weights must have same length as data\n"); tmp <- status!=0 & status!=causeS if (any(tmp)==TRUE) if (min(KMti[tmp])==0) stop("Other causes have censoring weight equal to 0\n"); ## }}} ###print(table(status)) ###print(head(stop)) ###print(head(times)) ###print(Ntimes) ###print(sum(KMtimes)) ###print(sum(KMti)) ###print(cens.code) ###print(table(status)) ###print(causeS) nparout<- .C("posubdist2", as.double(times),as.integer(Ntimes),as.double(desX), as.integer(nx),as.integer(pg),as.integer(antpers), as.double(start),as.double(stop), as.double(beta), as.integer(Nit), as.double(cumint), as.double(vcum), as.double(Iinv),as.double(Varbeta),as.integer(detail), as.integer(sim),as.integer(antsim),as.integer(rani), as.double(Rvcu),as.double(RVarbeta),as.double(test), as.double(testOBS),as.double(Ut),as.double(simUt), as.double(Uit),as.integer(id),as.integer(status), as.integer(weighted.test),as.integer(rate.sim),as.double(score), as.double(cumAi),as.double(cumAiiid),as.integer(residuals), as.double(loglike),as.integer(profile),as.integer(sym), as.double(KMtimes),as.double(KMti),as.double(time2), as.integer(causeS), as.integer(index-1), as.integer(baselinevar), as.integer(clusters), as.integer(antclust), as.integer(cens.code), as.double(biid),as.double(gamiid),as.double(weights),PACKAGE="timereg"); ## {{{ output handling gamma<-matrix(nparout[[9]],pg,1); cumint<-matrix(nparout[[11]],Ntimes,px+1); vcum<-matrix(nparout[[12]],Ntimes,px+1); Iinv<-matrix(nparout[[13]],pg,pg); Varbeta<--matrix(nparout[[14]],pg,pg); Rvcu<-matrix(nparout[[19]],Ntimes,px+1); RVarbeta<--matrix(nparout[[20]],pg,pg); score<-matrix(nparout[[30]],pg,1); Ut<-matrix(nparout[[23]],Ntimes,pg+1); loglike<-nparout[[34]] if (residuals==1) { cumAi<-matrix(nparout[[31]],Ntimes,antpers*1); cumAiiid<-matrix(nparout[[32]],Ntimes,antpers*1); cumAi<-list(time=times,dmg=cumAi,dmg.iid=cumAiiid);} else cumAi<-NULL; if (resample.iid==1) { biid<-matrix(nparout[[46]],Ntimes,antclust); gamiid<-matrix(nparout[[47]],antclust,pg) gamiid <- t(Iinv %*% t(gamiid)) B.iid<-list(); for (i in (1:antclust)) { B.iid[[i]]<-matrix(biid[,i],ncol=1); colnames(B.iid[[i]])<-"Baselineiid"; } colnames(gamiid)<-covnamesX } else B.iid<-gamiid<-NULL; if (sim==1) { Uit<-matrix(nparout[[25]],Ntimes,50*pg); UIt<-list(); for (i in (0:49)*pg) UIt[[i/pg+1]]<-as.matrix(Uit[,i+(1:pg)]); simUt<-matrix(nparout[[24]],antsim,pg); test<-matrix(nparout[[21]],antsim,2*px); testOBS<-nparout[[22]]; supUtOBS<-apply(abs(as.matrix(Ut[,-1])),2,max); for (i in 1:(2*px)) testval<-c(testval,pval(test[,i],testOBS[i])); for (i in 1:px) unifCI<-c(unifCI,percen(test[,i],0.95)); testUt<-c(); for (i in 1:pg) testUt<-c(testUt,pval(simUt[,i],supUtOBS[i])); pval.testBeq0<-as.vector(testval[1:px]); pval.testBeqC<-as.vector(testval[(px+1):(2*px)]); obs.testBeq0<-as.vector(testOBS[1:px]); obs.testBeqC<-as.vector(testOBS[(px+1):(2*px)]); sim.testBeq0<-as.matrix(test[,1:px]); sim.testBeqC<-as.matrix(test[,(px+1):(2*px)]); sim.supUt<-as.matrix(simUt); } if (sim!=1) { testUt<-NULL;test<-NULL;unifCI<-NULL;supUtOBS<-NULL;UIt<-NULL;testOBS<-NULL;testval<-NULL; pval.testBeq0<- pval.testBeqC<- obs.testBeq0<- obs.testBeqC<- sim.testBeq0<- sim.testBeqC<-NULL; testUt<-NULL; sim.supUt<-NULL; } ud<-list(cum=cumint,var.cum=vcum,robvar.cum=Rvcu, gamma=gamma,var.gamma=Varbeta,robvar.gamma=RVarbeta, resid.dMG=cumAi,D2linv=Iinv,score=score,loglike=loglike, pval.testBeq0=pval.testBeq0,pval.testBeqC=pval.testBeqC, obs.testBeq0=obs.testBeq0,obs.testBeqC=obs.testBeqC, sim.testBeq0= sim.testBeq0,sim.testBeqC=sim.testBeqC, conf.band=unifCI, test.procProp=Ut,sim.test.procProp=UIt,pval.Prop=testUt, sim.supProp=sim.supUt,prop.odds=TRUE,B.iid=B.iid,gamma.iid=gamiid,cens.weights=KMti) colnames(ud$cum)<-colnames(ud$var.cum)<- c("time","Baseline") colnames(ud$robvar.cum)<- c("time","Baseline"); if (px>0) { if (sim==1) { colnames(ud$test.procProp)<-c("time",covnamesX) names(ud$pval.Prop)<-covnamesX names(ud$conf.band)<-names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<-names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<-colnames(ud$sim.testBeq0)<-"Baseline"; } } rownames(ud$gamma)<-c(covnamesX); colnames(ud$gamma)<-"estimate"; rownames(ud$score)<-c(covnamesX); colnames(ud$score)<-"score"; namematrix(ud$var.gamma,covnamesX); namematrix(ud$robvar.gamma,covnamesX); namematrix(ud$D2linv,covnamesX); ## }}} attr(ud,"Call")<-call; attr(ud,"Formula")<-formula; attr(ud,"id")<-id.call; attr(ud,"baselinevar") <- 1 if (cens.model!="po") attr(ud,"type") <- "comprisk" else attr(ud,"type") <- "survival" class(ud)<-"cox.aalen" return(ud); } ## }}} ## }}} #' @export predictpropodds <- function(out,X=NULL,times=NULL) { ## {{{ beta <- out$gamma baseline <- out$cum[,2] btimes <- out$cum[,1] if (!is.null(times)) btimes <- times; pcum <- Cpred(out$cum,btimes) RR <- matrix(X,ncol=length(beta),byrow=TRUE) %*% beta HRR <- outer(pcum[,2],exp(RR),"*")[,,1] pred <- HRR/(1+HRR) return(list(pred=pred,time=btimes)) } ## }}} #' @export prop.odds.subdist.ipw <- function(compriskformula,glmformula,data=parent.frame(),cause=1, max.clust=NULL,ipw.se=FALSE,...) { ## {{{ ggl <- glm(glmformula,family='binomial',data=data) mat <- model.matrix(glmformula,data=data); glmcovs <- attr(ggl$terms,"term.labels") data$ppp <- predict(ggl,type='response') dcc <- data[ggl$y==1,] ppp <- dcc$ppp udca <- prop.odds.subdist(compriskformula,data=dcc,cause=cause,weights=1/ppp,n.sim=0, max.clust=max.clust,...) ### iid of beta for comprisk model compriskiid <- udca$gamma.iid if (ipw.se==TRUE) { ## {{{ ###requireNamespace("lava"); ###requireNamespace("NumDeriv"); glmiid <- lava::iid(ggl) mat <- mat[ggl$y==1,] par <- coef(ggl) compriskalpha <- function(par) { ## {{{ rr <- mat %*% par pw <- c(exp(rr)/(1+exp(rr))) assign("pw",pw,envir=environment(compriskformula)) ud <- prop.odds.subdist(compriskformula,data=dcc, cause=cause, weights=1/pw,baselinevar=0,beta=udca$gamma, Nit=1,n.sim=0,...) ud$score } ## }}} DU <- numDeriv::jacobian(compriskalpha,par) IDU <- udca$D2linv %*% DU alphaiid <-t( IDU %*% t(glmiid)) ### iidfull <- alphaiid ### iidfull[ggl$y==1,] <- compriskiid + alphaiid[ggl$y==1,] ### var2 <- t(iidfull) %*% iidfull se <- cbind(diag(var2)^.5); colnames(se) <- "se" } else { iidfull <- NULL; var2 <- NULL; se <- NULL} ## }}} var.naive=udca$robvar.gamma se.naive=matrix(diag(var.naive)^.5,nrow(var.naive),1); colnames(se.naive) <- "se.naive" res <- list(iid=iidfull,coef=udca$gamma,var.naive=var.naive, se.naive=se.naive,var=var2,se=se, comprisk.ipw=udca) class(res) <- "comprisk.ipw" return(res) } ## }}} timereg/R/comprisk.ipw.r0000644000176200001440000000474214421510301014715 0ustar liggesuserscomprisk.ipw <- function(compriskformula,glmformula,data=parent.frame(),cause=1, max.clust=NULL,ipw.se=FALSE,...) { ## {{{ ggl <- glm(glmformula,family='binomial',data=data) mat <- model.matrix(glmformula,data=data); glmcovs <- attr(ggl$terms,"term.labels") data$ppp <- predict(ggl,type='response') dcc <- data[ggl$y==1,] ppp <- dcc$ppp udca <- comp.risk(compriskformula,data=dcc,cause=cause,weights=1/ppp,n.sim=0, max.clust=max.clust,...) ### iid of beta for comprisk model compriskiid <- udca$gamma.iid if (ipw.se==TRUE) { ## {{{ ###requireNamespace("lava"); ###requireNamespace("NumDeriv"); glmiid <- lava::iid(ggl) mat <- mat[ggl$y==1,] par <- coef(ggl) compriskalpha <- function(par) { ## {{{ rr <- mat %*% par pw <- c(exp(rr)/(1+exp(rr))) assign("pw",pw,envir=environment(compriskformula)) ud <- comp.risk(compriskformula,data=dcc,cause=cause, weights=1/pw, est=udca$cum,gamma=udca$gamma,Nit=1,n.sim=0,...) ud$scores$gamscore } ## }}} DU <- numDeriv::jacobian(compriskalpha,par) IDU <- udca$Dscore.gamma %*% DU alphaiid <-t( IDU %*% t(glmiid)) ### iidfull <- alphaiid ### iidfull[ggl$y==1,] <- compriskiid + alphaiid[ggl$y==1,] ### var2 <- t(iidfull) %*% iidfull se <- cbind(diag(var2)^.5); colnames(se) <- "se" } else { iidfull <- NULL; var2 <- NULL; se <- NULL} ## }}} var.naive=udca$robvar.gamma se.naive=matrix(diag(var.naive)^.5,nrow(var.naive),1); colnames(se.naive) <- "se.naive" res <- list(iid=iidfull,coef=udca$gamma,var.naive=var.naive, se.naive=se.naive,var=var2,se=se, comprisk.ipw=udca) class(res) <- "comprisk.ipw" return(res) ## }}} } ### glmformula must have cause specific covariates if ### logit(P(e_i==1| V_i , cause_i==1)) ### logit(P(e_i==1| V_i , cause_i!=1)) ### potentially ### logit(P(e_i==1| V_i , cause_i==i)) can be specified where V_i are the covariates that ### are always observed and used for estimating the probability of sampling ### then glmformula must allow this but can still use comprisk.ipw function summary.comprisk.ipw <- function(object,digits=3,...) { ## {{{ tval <- object$coef/object$se pval <- 2*(1-pnorm(abs(tval))) res <- cbind(object$coef,object$se,object$se.naive,pval) colnames(res) <- c("coef","se","se.naive","pval") return(res) } ## }}} coef.comprisk.ipw<- function(object,digits=3,...) { ## {{{ summary.comprisk.ipw(object) } ## }}} print.comprisk.ipw <- function(x,...) { ## {{{ summary.comprisk.ipw(x) } ## }}} timereg/R/prop-excess.r0000644000176200001440000001457214421510276014555 0ustar liggesusers#source('propbase.r') prop.excessBase<-function(time,status,X,Z,excess,tol=0.0001,alpha=1,frac=1,no.sim=500){ X<-as.matrix(X); Z<-as.matrix(Z); n<-length(time);p<-dim(X)[2];q<-dim(Z)[2] status[status!=1]<-0 #beta<-rep(0,q) #beta<-c(0.12,-1.28,0.06) #print(c('q: ',q)) beta<-coxph(Surv(time,status)~Z[,1:q])$coeff beta<-matrix(beta,q,1)#; print(c('beta:',beta)) phi<-numeric(n) #if (int==1){X<-cbind(1+numeric(n),X); # p<-p+1}#Intercept is added ; Is now added automatically X.til<-cbind(X,phi) k<-sum(status);s.time<-sort(time[status==1]); Uinp<-matrix(0,q,1);dUinp<-matrix(0,q,q);optinp<-matrix(0,q,q); Psiinp<-matrix(0,p+1,k);CoVarPsiinp<-matrix(0,(p+1)*(p+1),k) VarPsiinp<-matrix(0,(p+1),k); testinp<-matrix(0,p+1,(no.sim+1)); testinpHW<-matrix(0,p+1,(no.sim+1)); testinpCM<-matrix(0,p+1,(no.sim+1)); Scoreinp<-matrix(0,k*q,51);#Score-vector-function and 50 simulated values testinpGOFCM<-numeric((no.sim+1)); rani<-(-round(runif(1)*10000)); k1<-round(frac*k) storage.mode(time)<-"double" storage.mode(status)<-"double" storage.mode(X)<-"double" storage.mode(X.til)<-"double" storage.mode(Z)<-"double" storage.mode(Uinp)<-"double" storage.mode(dUinp)<-"double" storage.mode(optinp)<-"double" storage.mode(excess)<-"double" storage.mode(phi)<-"double" storage.mode(s.time)<-"double" storage.mode(beta)<-"double" storage.mode(tol)<-"double" storage.mode(alpha)<-"double" storage.mode(Psiinp)<-"double" storage.mode(CoVarPsiinp)<-"double" storage.mode(VarPsiinp)<-"double" storage.mode(testinp)<-"double" storage.mode(testinpHW)<-"double" storage.mode(testinpCM)<-"double" storage.mode(Scoreinp)<-"double" storage.mode(testinpGOFCM)<-"double" storage.mode(n)<-"integer" storage.mode(p)<-"integer" storage.mode(q)<-"integer" storage.mode(k)<-"integer" storage.mode(k1)<-"integer" storage.mode(rani)<-"integer" storage.mode(no.sim)<-"integer" #dyn.load("allfunctions.o") #dyn.load("addmult.so") #dyn.load("linaddmult.so") #if (system=="unix") dyn.load("addmult.so") #if (system=="linux") dyn.load("linaddmult.so") #print(c('CHECK')) #print(cbind(time,status)[111:121,]) #print(status) #print(X[1:10,]) #print(X.til) #print(Z[1:10,]) #print(excess) #print(phi) #print(s.time) #print(beta) #print(c('n, k, k1',n,k,k1)) #print(c('p,q',p,q)) #print(c('alpha,no.sim,tol',alpha,no.sim,tol)) U.out<-.C("addmult",time,status,X,X.til,Z,Uinp,dUinp,optinp, excess,phi,s.time,beta,n,p,q,k,tol,alpha, Psiinp,CoVarPsiinp,VarPsiinp,rani,testinp,testinpHW,testinpCM, testinpGOFCM,Scoreinp,no.sim,k1,PACKAGE="timereg") U.bet<-U.out[[6]] D.bet<-U.out[[7]];#print(c('D.bet',D.bet)) I.bet<-U.out[[8]];#print(c('I.bet',I.bet)) V.bet<-U.out[[8]]; rank.D.bet<-qr(D.bet)$rank no.it<-U.out[[13]];#print(c('no.it',no.it)) if (rank.D.bet==q){eigenV<-eigen(D.bet)$values;#print(c('eigenV',eigenV)) indik<-sum( (eigenV<0) ); if (indik=1) {test<-matrix(0,5*pdim,antsim); testOBS<-rep(0,5*pdim);} else {test<-0; testOBS<-0;} rani<--round(runif(1)*10000); testval<-c(); unifCI<-c(); # 50 tilfaeldige score processer til test H: b(t)=b returneres if (sim>=1) simUt<-matrix(0,Ntimes,50*pdim) else simUt<-NULL; Ut<-matrix(0,Ntimes,pdim+1); if (method=="basic") { timeout<- .C("OStimecox", as.double(times), as.integer(Ntimes),as.double(designX), as.integer(nx),as.integer(p),as.integer(fdata$antpers), as.double(fdata$start),as.double(fdata$stop),as.integer(nb), as.double(bhat), as.double(cum),as.double(Vcum), as.integer(it),as.double(band),as.integer(degree), as.integer(id), as.integer(status), as.integer(sim), as.integer(antsim), as.double(cumAi), as.double(test), as.integer(rani),as.double(testOBS),as.double(Ut), as.double(simUt), as.double(rvcu), as.integer(retur), as.integer(weighted.test),as.double(cumAiid), as.integer(robust), as.integer(covariance),as.double(covs), PACKAGE="timereg"); if (covariance==1) { covit<-matrix(timeout[[32]],Ntimes,p*p); cov.list<-list(); for (i in 1:Ntimes) cov.list[[i]]<-matrix(covit[i,],p,p); } else cov.list<-NULL; schoen<- obs.testBeqC.is1<- obs.testBeqC.is2<- pval.testBeqC.is1<- pval.testBeqC.is2<- sim.testBeqC.is1<- sim.testBeqC.is2<-NULL; rvcu<-matrix(timeout[[26]],Ntimes,p+1); if (retur==1) { cumAi<-matrix(timeout[[20]],Ntimes,fdata$antpers*1); cumAiid<-matrix(timeout[[29]],Ntimes,fdata$antpers*1); cumAi<-list(time=times,dM=cumAi,dM.iid=cumAiid);} else cumAi<-NULL; if (sim>=1) { Ut<-matrix(timeout[[24]],Ntimes,(p+1)); Uit<-matrix(timeout[[25]],Ntimes,50*p); UIt<-list(); for (i in (0:49)*p) UIt[[i/p+1]]<-as.matrix(Uit[,i+(1:p)]); test<-matrix(timeout[[21]],antsim,5*p); test<-test[,1:(3*p)]; testOBS<-timeout[[23]]; for (i in 1:(3*p)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:p) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); pval.testBeq0<-as.vector(testval[1:p]); pval.testBeqC<-as.vector(testval[(p+1):(2*p)]); pval.testBeqC.is<-as.vector(testval[(2*p+1):(3*p)]); obs.testBeq0<-as.vector(testOBS[1:p]); obs.testBeqC<-as.vector(testOBS[(p+1):(2*p)]); obs.testBeqC.is<-as.vector(testOBS[(2*p+1):(3*p)]); sim.testBeq0<-as.matrix(test[,1:p]); sim.testBeqC<-as.matrix(test[,(p+1):(2*p)]); sim.testBeqC.is<-as.matrix(test[,(2*p+1):(3*p)]); } else { test<- unifCI<- Ut<- UIt<- pval.testBeq0<- obs.testBeq0<- sim.testBeq0<- pval.testBeqC<- obs.testBeqC<- sim.testBeqC<- obs.testBeqC.is<- pval.testBeqC.is<- sim.testBeqC.is<- test.procBeqC<- test.procBeqC.is<-NULL; } } else if (method=="breslow") { schoen<-matrix(0,Ntimes,p+1); cumlam<-cum<-Vcum<-rvcu<-matrix(0,Ntimes,p+2); timeout<-.C("OSbreslow", as.double(times),as.integer(Ntimes),as.double(designX), as.integer(nx),as.integer(p),as.integer(fdata$antpers), as.double(fdata$start),as.double(fdata$stop),as.integer(nb), as.double(bhat),as.double(cum),as.double(Vcum), as.integer(it),as.double(band),as.integer(degree), as.double(schoen),as.integer(sim),as.integer(antsim), as.double(test),as.integer(rani),as.double(testOBS), as.double(rvcu),as.double(cumlam),as.integer(nullresid), as.integer(status),as.integer(id),as.integer(sim2), as.double(Ut),as.double(simUt),as.integer(weighted.test), as.integer(robust), PACKAGE="timereg"); cov.list<-NULL; schoen<-matrix(timeout[[16]],Ntimes,p+1); rvcu<-matrix(timeout[[22]],Ntimes,p+2); if (sim2!=1) { obs.testBeqC.is1<- obs.testBeqC.is2<- pval.testBeqC.is1<- pval.testBeqC.is2<- sim.testBeqC.is1<- sim.testBeqC.is2<-NULL; } cumAi<-NULL; # calculated for time basic version if (sim>=1) { Ut<-matrix(timeout[[28]],Ntimes,(pdim+1)); Uit<-matrix(timeout[[29]],Ntimes,50*pdim); UIt<-list(); for (i in (0:49)*pdim) UIt[[i/pdim+1]]<-as.matrix(Uit[,i+(1:pdim)]); test<-matrix(timeout[[19]],antsim,5*pdim); testOBS<-timeout[[21]]; testval<-c(); unifCI<-c(); for (i in 1:(5*pdim)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:pdim) unifCI<-c(unifCI,percen(test[,i],0.95)); pval.testBeq0<-as.vector(testval[1:pdim]); pval.testBeqC<-as.vector(testval[(pdim+1):(2*pdim)]); pval.testBeqC.is<-as.vector(testval[(2*pdim+1):(3*pdim)]); obs.testBeq0<-as.vector(testOBS[1:pdim]); obs.testBeqC<-as.vector(testOBS[(pdim+1):(2*pdim)]); obs.testBeqC.is<-as.vector(testOBS[(2*pdim+1):(3*pdim)]); sim.testBeq0<-as.matrix(test[,1:pdim]); sim.testBeqC<-as.matrix(test[,(pdim+1):(2*pdim)]); sim.testBeqC.is<-as.matrix(test[,(2*pdim+1):(3*pdim)]); sim2<-0 if (sim2==1) { pval.testBeqC.is1<-as.vector(testval[(3*pdim+1):(4*pdim)]); pval.testBeqC.is2<-as.vector(testval[(4*pdim+1):(5*pdim)]); obs.testBeqC.is1<-as.vector(testOBS[(3*pdim+1):(4*pdim)]); obs.testBeqC.is2<-as.vector(testOBS[(4*pdim+1):(5*pdim)]); sim.testBeqC.is1<-as.matrix(test[,(3*pdim+1):(4*pdim)]); sim.testBeqC.is2<-as.matrix(test[,(3*pdim+1):(4*pdim)]); } } else {test<- unifCI<- Ut<- UIt<- pval.testBeq0<-pval.testBeqC<- obs.testBeq0<-obs.testBeqC<- sim.testBeq0<-sim.testBeqC<- sim.testBeqC.is<- sim.testBeqC.is1<- sim.testBeqC.is2<- pval.testBeqC.is<- pval.testBeqC.is1<- pval.testBeqC.is2<- obs.testBeqC.is<- obs.testBeqC.is1<- obs.testBeqC.is2<-NULL; } } else stop("Methods are : breslow and basic\n"); bhat<-matrix(timeout[[10]],nb,pdim+1); cum<-matrix(timeout[[11]],Ntimes,pdim+1); Vcum<-matrix(timeout[[12]],Ntimes,pdim+1); # additional output ? band=band,method=method,degree=degree,it=it, # beta.t=bhat, ud<-list(cum=cum,var.cum=Vcum,robvar.cum=rvcu, residuals=cumAi,schoenfeld.residuals=schoen, schoenfeld.residual=schoen, obs.testBeq0=obs.testBeq0, pval.testBeq0=pval.testBeq0, pval.testBeqC=pval.testBeqC, obs.testBeqC=obs.testBeqC, obs.testBeqC.is=obs.testBeqC.is, pval.testBeqC.is=pval.testBeqC.is, obs.testBeqC.is1=obs.testBeqC.is1,pval.testBeqC.is1=pval.testBeqC.is1, obs.testBeqC.is2=obs.testBeqC.is2,pval.testBeqC.is2=pval.testBeqC.is2, sim.testBeq0= sim.testBeq0,sim.testBeqC=sim.testBeqC, conf.band=unifCI,test.procBeqC=Ut,sim.test.procBeqC=UIt, sim.testBeqC.is=sim.testBeqC.is, sim.testBeqC.is=sim.testBeqC.is1, sim.testBeqC.is=sim.testBeqC.is2,covariance=cov.list) return(ud); } ## }}} semicox<-function(times,fdata,designX,designG,status,id,bhat,gamma=0, band=1,degree=1,it=10,method="basic",sim=0,retur=0,antsim=1000, robust=1,weighted.test=0,covariance=0) { ## {{{ Nalltimes <- length(times); Ntimes<-sum(status[(fdata$stop>times[1]) & (fdata$stop<=times[Nalltimes])])+1; designX<-as.matrix(designX); designG<-as.matrix(designG); if(is.matrix(designX) == TRUE) px <- as.integer(dim(designX)[2]) if(is.matrix(designX) == TRUE) nx <- as.integer(dim(designX)[1]) if(is.matrix(designG) == TRUE) pg <- as.integer(dim(designG)[2]) if(is.matrix(designG) == TRUE) ng <- as.integer(dim(designG)[1]) bhat<-as.matrix(bhat); nb<-as.integer(dim(bhat)[1]); band<-matrix(band,nb,as.integer(dim(bhat)[2])-1); if (method=="breslow") pdim<-px+1 else pdim<-px; if (covariance==1) covs<-matrix(0,Ntimes,px*px) else covs<-0; if (nx!=ng) print(" A design og B designs er ikke ens\n"); cum<-matrix(0,Ntimes,px+1); rvcu<-Vcum<-cum; if (sum(abs(gamma))==0) gamma<-rep(0,pg) else gamma<-gamma; RobVargam<-Vargam<-matrix(0,pg,pg); test<-matrix(0,antsim,3*pdim); testOBS<-rep(0,3*pdim); testval<-c(); rani<--round(runif(1)*10000); # 50 tilfaeldige score processer til test H: b(t)=b returneres if (sim>=1) simUt<-matrix(0,Ntimes,50*pdim) else simUt<-NULL; Ut<-matrix(0,Ntimes,pdim+1); if (retur==1) cumAi<-matrix(0,Ntimes,fdata$antpers) else cumAi<-0; sim.testBeqC.is1<- sim.testBeqC.is2<- obs.testBeqC.is1<- obs.testBeqC.is2<- pval.testBeqC.is1<- pval.testBeqC.is2<-NULL; # LOAD NECESSARY ROUTINES #if (method=="basic" && system=="unix") dyn.load("timecox.so") #if (method=="basic" && system=="linux") dyn.load("lintimecox.so") #else if (method=="breslow" && system=="unix") dyn.load("breslow.so") #else if (method=="breslow" && system=="linux") dyn.load("linbreslow.so") #else if (method=="breslow" && system=="windows") dyn.load("breslow.dll"); if (method=="basic") { semiout<-.C("OSsemicox", as.double(times),as.integer(Ntimes), as.double(designX), as.integer(nx),as.integer(px), as.double(designG), as.integer(ng),as.integer(pg),as.integer(fdata$antpers), as.double(fdata$start), as.double(fdata$stop),as.integer(nb), as.double(bhat),as.double(cum),as.double(Vcum), as.double(gamma),as.double(Vargam),as.double(band), as.integer(degree), as.integer(it), as.double(RobVargam), as.double(rvcu), as.integer(sim), as.integer(antsim), as.integer(retur), as.double(cumAi), as.double(test), as.integer(rani), as.double(testOBS), as.integer(status), as.double(Ut), as.double(simUt), as.integer(id), as.integer(weighted.test),as.integer(robust), as.integer(covariance),as.double(covs),PACKAGE="timereg"); if (covariance==1) { covit<-matrix(semiout[[37]],Ntimes,px*px); cov.list<-list(); for (i in 1:Ntimes) cov.list[[i]]<-matrix(covit[i,],px,px); } else cov.list<-NULL; bhat<-matrix(semiout[[13]],nb,px+1); cum<-matrix(semiout[[14]],Ntimes,px+1); Vcum<-matrix(semiout[[15]],Ntimes,px+1); rvcu<-matrix(semiout[[22]],Ntimes,px+1); gamma<-matrix(semiout[[16]],pg,1); Vargam<-matrix(semiout[[17]],pg,pg); RobVargam<-matrix(semiout[[21]],pg,pg); if (retur==1) { cumAi<-matrix(semiout[[26]],Ntimes,fdata$antpers); cumAi<-list(time=times,dM=cumAi); #cumAI<-list(); #for (i in (0:(fdata$antpers-1))*p) cumAI[[i/p+1]]<-cumAi[,i+(1:p)] } else cumAi<-NULL; unifCI<-c(); if (sim>=1) { test<-matrix(semiout[[27]],antsim,3*px); testOBS<-semiout[[29]]; for (i in 1:(3*px)) testval<-c(testval,pval(test[,i],testOBS[i])) Ut<-matrix(semiout[[31]],Ntimes,(px+1)); Uit<-matrix(semiout[[32]],Ntimes,50*px); UIt<-list(); for (i in (0:49)*px) UIt[[i/px+1]]<-as.matrix(Uit[,i+(1:px)]); for (i in 1:px) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); obs.testBeq0<-as.vector(testOBS[1:px]); pval.testBeq0<-as.vector(testval[1:px]); sim.testBeq0<-as.matrix(test[,1:px]); obs.testBeqC<-as.vector(testOBS[(px+1):(2*px)]); pval.testBeqC<-as.vector(testval[(px+1):(2*px)]); sim.testBeqC<-as.matrix(test[,(px+1):(2*px)]); pval.testBeqC.is<-as.vector(testval[(2*px+1):(3*px)]); obs.testBeqC.is<-as.vector(testOBS[(2*px+1):(3*px)]); sim.testBeqC.is<-as.matrix(test[,(2*px+1):(3*px)]); } else { test<- unifCI<-UIt<- Ut<- pval.testBeq0<-pval.testBeqC<- obs.testBeq0<- obs.testBeqC<- obs.testBeqC.is<- pval.testBeqC.is<- sim.testBeq0<- sim.testBeqC<- sim.testBeqC.is<-NULL; } } else if (method=="breslow") { schoen<-0; cum<-Vcum<-rvcu<-matrix(0,Ntimes,px+2); cumAi<-NULL; semiout<-.C("semibreslow", as.double(times),as.integer(Ntimes), as.double(designX), as.integer(nx),as.integer(px), as.double(designG), as.integer(ng),as.integer(pg),as.integer(fdata$antpers), as.double(fdata$start), as.double(fdata$stop),as.integer(nb), as.double(bhat),as.double(cum), as.double(Vcum), as.double(rvcu), as.double(gamma),as.double(Vargam), as.double(RobVargam),as.double(band), as.integer(degree), as.integer(it),as.integer(sim),as.integer(antsim), as.double(test), as.integer(rani), as.double(testOBS), as.integer(status),as.integer(id),as.double(schoen), as.double(simUt), as.double(Ut),as.integer(weighted.test),as.integer(robust),PACKAGE="timereg") bhat<-matrix(semiout[[13]],nb,px+2); cum <-matrix(semiout[[14]],Ntimes,px+2); Vcum <-matrix(semiout[[15]],Ntimes,px+2); rvcu<-matrix(semiout[[16]],Ntimes,px+2); gamma<-matrix(semiout[[17]],pg,1); Vargam<-matrix(semiout[[18]],pg,pg); RobVargam<-matrix(semiout[[19]],pg,pg); schoen<-NULL; sim.testBeqC.is1<- sim.testBeqC.is2<- obs.testBeqC.is1<- obs.testBeqC.is2<- pval.testBeqC.is1<- pval.testBeqC.is2<-NULL; if (sim>=1) { unifCI<-c(); test<-matrix(semiout[[25]],antsim,3*pdim); testOBS<-semiout[[27]]; for (i in 1:(3*pdim)) testval<-c(testval,pval(test[,i],testOBS[i])) Uit<-matrix(semiout[[31]],Ntimes,50*pdim); UIt<-list(); for (i in (0:49)*pdim) UIt[[i/pdim+1]]<-as.matrix(Uit[,i+(1:pdim)]); Ut<-matrix(semiout[[32]],Ntimes,(pdim+1)); for (i in 1:pdim) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); obs.testBeq0<-as.vector(testOBS[1:pdim]); pval.testBeq0<-as.vector(testval[1:pdim]); sim.testBeq0<-as.matrix(test[,1:pdim]); pval.testBeqC<-as.vector(testval[(pdim+1):(2*pdim)]); obs.testBeqC<-as.vector(testOBS[(pdim+1):(2*pdim)]); sim.testBeqC<-as.matrix(test[,(pdim+1):(2*pdim)]); pval.testBeqC.is<-as.vector(testval[(2*pdim+1):(3*pdim)]); obs.testBeqC.is<-as.vector(testOBS[(2*pdim+1):(3*pdim)]); sim.testBeqC.is<-as.matrix(test[,(2*pdim+1):(3*pdim)]); } else { test<-unifCI<-UIt<-Ut<-pval.testBeq0<-pval.testBeqC<- obs.testBeq0<-obs.testBeqC<-obs.testBeqC.is<-Fpval.testBeqC.is<- sim.testBeq0<-sim.testBeqC<-sim.testBeqC.is<-NULL; } cov.list<-NULL; } else stop("Methods are : breslow and basic\n"); # method=method ud<-list(cum=cum,var.cum=Vcum,robvar.cum=rvcu, gamma=gamma,var.gamma=Vargam,robvar.gamma=RobVargam, residuals=cumAi, pval.testBeq0=pval.testBeq0, obs.testBeq0=obs.testBeq0, pval.testBeqC=pval.testBeqC, obs.testBeqC=obs.testBeqC, pval.testBeqC.is=pval.testBeqC.is, obs.testBeqC.is=obs.testBeqC.is, sim.testBeq0= sim.testBeq0,sim.testBeqC=sim.testBeqC, sim.testBeqC.is=sim.testBeqC.is, conf.band=unifCI,test.procBeqC=Ut,sim.test.procBeqC=UIt, covariance=cov.list) return(ud); } ## }}} pval<-function(simt,Otest) { p<-sum(Otest= new.time)) cat("any(new.start>= new.time) is TRUE\n"); if ((name.id %in% names(data))) idl <- data[,name.id] else { idl <- 1:n data[,name.id] <- idl } ### if (newrow) new.row <- rep(0,nrow(data)) splits <- which(new.cuts=1) robust<-1; cumint<-matrix(0,Ntimes,p+1); Vcumint<-cumint; robVar<-Vcumint; cumAi<-0; if (retur==1) cumAi<-matrix(0,Ntimes,fdata$antpers) if (retur==2) cumAi<-rep(0,fdata$antpers); test<-matrix(0,antsim,3*p); testOBS<-rep(0,3*p); testval<-c(); unifCI<-c(); # 49 random score processes for testing H: b(t)=b returned if (sim>=1) simUt<-matrix(0,Ntimes,50*p) else simUt<-NULL; Ut<-matrix(0,Ntimes,p+1); if (covariance==1) covs<-matrix(0,Ntimes,p*p) else covs<-0; if (resample.iid==1) { B.iid<-matrix(0,Ntimes,fdata$antclust*p) } else B.iid<-NULL; if (sum(offsets)==0) mof <- 0 else mof <- 1; ## }}} icase <- 0 if (!is.null(caseweight)) {icase <- 1; } aalenout<- .C("robaalen", ## {{{ as.double(times), as.integer(Ntimes),as.double(designX), as.integer(nx),as.integer(p),as.integer(fdata$antpers), as.double(fdata$start),as.double(fdata$stop),as.double(cumint), # 3 as.double(Vcumint),as.double(robVar),as.integer(sim), as.integer(antsim),as.integer(retur),as.double(cumAi), as.double(test),as.double(testOBS),as.integer(status), # 6 as.double(Ut),as.double(simUt),as.integer(id), as.integer(weighted.test),as.integer(robust),as.integer(covariance), as.double(covs),as.integer(resample.iid),as.double(B.iid), # 9 as.integer(clusters),as.integer(fdata$antclust), as.integer(silent),as.double(weights),as.integer(entry), # 11 as.integer(mof),as.double(offsets),as.integer(stratum), #12 as.double(caseweight),as.integer(icase) ,PACKAGE="timereg") ## }}} ## {{{ handling output cumint <-matrix(aalenout[[9]],Ntimes,p+1); Vcumint<-matrix(aalenout[[10]],Ntimes,p+1); robVar<-matrix(aalenout[[11]],Ntimes,p+1); if (covariance==1) { covit<-matrix(aalenout[[25]],Ntimes,p*p); cov.list<-list(); for (i in 1:Ntimes) cov.list[[i]]<-matrix(covit[i,],p,p); } else cov.list<-NULL; if (resample.iid==1) { covit<-matrix(aalenout[[27]],Ntimes,fdata$antclust*p); B.iid<-list(); for (i in (0:(fdata$antclust-1))*p) { B.iid[[i/p+1]]<-as.matrix(covit[,i+(1:p)]); colnames(B.iid[[i/p+1]])<-namesX; } } cumAi<-NULL; if (retur==1) { cumAi<-matrix(aalenout[[15]],Ntimes,fdata$antpers*1); cumAi<-list(time=times,dM=cumAi,dM.iid=cumAi); } if (retur==2) {cumAi<-aalenout[[15]]; cumAi<-list(dM=cumAi); } if (sim>=1) { Uit<-matrix(aalenout[[20]],Ntimes,50*p); UIt<-list(); for (i in (0:49)*p) UIt[[i/p+1]]<-as.matrix(Uit[,i+(1:p)]); Ut<-matrix(aalenout[[19]],Ntimes,(p+1)); test<-matrix(aalenout[[16]],antsim,3*p); testOBS<-aalenout[[17]]; for (i in 1:(3*p)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:p) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); pval.testBeq0<-as.vector(testval[1:p]); pval.testBeqC<-as.vector(testval[(p+1):(2*p)]); pval.testBeqC.is<-as.vector(testval[(2*p+1):(3*p)]); obs.testBeq0<-as.vector(testOBS[1:p]); obs.testBeqC<-as.vector(testOBS[(p+1):(2*p)]); obs.testBeqC.is<-as.vector(testOBS[(2*p+1):(3*p)]); sim.testBeq0<-as.matrix(test[,1:p]); sim.testBeqC<-as.matrix(test[,(p+1):(2*p)]); sim.testBeqC.is<-as.matrix(test[,(2*p+1):(3*p)]); } else {test<-NULL; unifCI<-NULL; Ut<-NULL; UIt<-NULL; pval.testBeq0<-NULL;pval.testBeqC<-NULL; obs.testBeq0<-NULL;obs.testBeqC<-NULL; sim.testBeq0<-NULL;sim.testBeqC<-NULL; sim.testBeqC.is<-NULL; pval.testBeqC.is<-NULL; obs.testBeqC.is<-NULL; } ## }}} list(cum=cumint,var.cum=Vcumint,robvar.cum=robVar,residuals=cumAi, pval.testBeq0=pval.testBeq0, obs.testBeq0=obs.testBeq0, pval.testBeqC=pval.testBeqC, pval.testBeqC.is=pval.testBeqC.is, obs.testBeqC=obs.testBeqC,obs.testBeqC.is=obs.testBeqC.is, sim.testBeq0= sim.testBeq0, sim.testBeqC=sim.testBeqC,sim.testBeqC.is=sim.testBeqC.is, conf.band=unifCI,test.procBeqC=Ut,sim.test.procBeqC=UIt, covariance=cov.list,B.iid=B.iid,stratum=stratum) } #' Identifies parametric terms of model #' #' Specifies which of the regressors that have constant effect. #' #' @param x variable #' #' @author Thomas Scheike #' @keywords survival const <- function(x) x pval<-function(simt,Otest) { simt<-sort(simt); p<-sum(Otesttimes[1]) & (fdata$stop<=times[Nalltimes])])+1; #print(Ntimes); print(Nalltimes); #print(times); print(status); print(cbind(fdata$stop,fdata$start,status)) designX<-as.matrix(designX); designG<-as.matrix(designG); if(is.matrix(designX) == TRUE) px <- as.integer(dim(designX)[2]) if(is.matrix(designX) == TRUE) nx <- as.integer(dim(designX)[1]) if(is.matrix(designG) == TRUE) pg <- as.integer(dim(designG)[2]) if(is.matrix(designG) == TRUE) ng <- as.integer(dim(designG)[1]) nb<-1; if(is.matrix(bhat)==TRUE) nb<-as.integer(dim(bhat)[1]); if(is.matrix(bhat)==FALSE) bhat<-matrix(0,nb,px+1); if (is.diag( t(designX) %*% designX )==TRUE) stratum <- 1 else stratum <- 0 if (covariance==1) covs<-matrix(0,Ntimes,px*px) else covs<-0; if (resample.iid==1) { gamma.iid<-matrix(0,fdata$antclust,pg); B.iid<-matrix(0,Ntimes,fdata$antclust*px) } else { B.iid<-gamma.iid<-NULL; } if (retur==1) cumAi<-matrix(0,Ntimes,fdata$antpers) else cumAi<-0; if (nx!=ng) print(" A design og B designs er ikke ens\n"); cum<-matrix(0,Ntimes,px+1); Vcum<-cum; robVcum<-cum; Vargam2 <- Vargam<-matrix(0,pg,pg); RobVargam<-matrix(0,pg,pg); intZHZ<-matrix(0,pg,pg); gamma2 <- intZHdN<-rep(0,pg); test<-matrix(0,antsim,3*px); testOBS<-rep(0,3*px); testval<-c(); # 50 tilfaeldige score processer til test H: b(t)=b returneres if (sim==1) simUt<-matrix(0,Ntimes,50*px) else simUt<-NULL; Ut<-matrix(0,Ntimes,px+1); if (is.null(gamma)) fix.gamma <- 0 else fix.gamma <- 1; if (fix.gamma==1) { if (length(gamma)!=pg) gamma <- rep(gamma[1],pg); } else gamma <- rep(0,pg); if (sum(abs(gamma))==0) gamma<-rep(0,pg) else gamma<-gamma; if (sum(offsets)==0) mof<-0 else mof<-1; ## }}} icase <- 0 if (!is.null(caseweight)) {icase <- 1; } semiout<-.C("semiaalen", ## {{{ as.double(times),as.integer(Nalltimes),as.integer(Ntimes), # 1 as.double(designX),as.integer(nx),as.integer(px), # 2 as.double(designG),as.integer(ng),as.integer(pg), # 3 as.integer(fdata$antpers),as.double(fdata$start),as.double(fdata$stop), # 4 as.integer(nb),as.double(bhat), as.double(cum), # 5 as.double(Vcum),as.double(robVcum),as.double(gamma), # 6 as.double(Vargam),as.double(RobVargam), as.integer(sim), # 7 as.integer(antsim), as.double(test),as.double(testOBS), # 8 as.integer(robust), as.integer(status),as.double(Ut), # 9 as.double(simUt),as.integer(id), as.integer(weighted.test), # 10 as.double(cumAi),as.integer(retur),as.integer(covariance), # 11 as.double(covs), as.integer(resample.iid),as.double(gamma.iid), # 12 as.double(B.iid), as.integer(clusters),as.integer(fdata$antclust), # 13 as.double(intZHZ),as.double(intZHdN),as.integer(deltaweight), # 14 as.integer(silent),as.double(weights),as.integer(entry), as.integer(fix.gamma),as.integer(mof),as.double(offsets), as.double(gamma2),as.double(Vargam2), as.double(caseweight),as.integer(icase) ,PACKAGE="timereg"); ## }}} ## {{{ handling output if (resample.iid==1) { gamma.iid<-matrix(semiout[[36]],fdata$antclust,pg); covit<-matrix(semiout[[37]],Ntimes,fdata$antclust*px); B.iid<-list(); for (i in (0:(fdata$antclust-1))*px) { B.iid[[(i/px)+1]]<-as.matrix(covit[,i+(1:px)]); colnames(B.iid[[i/px+1]])<-namesX; } colnames(gamma.iid)<-namesZ } if (covariance==1) { covit<-matrix(semiout[[34]],Ntimes,px*px); cov.list<-list(); for (i in 1:Ntimes) cov.list[[i]]<-matrix(covit[i,],px,px); } else cov.list<-NULL; bhat<-matrix(semiout[[14]],nb,px+1); cum <-matrix(semiout[[15]],Ntimes,px+1); Vcum <-matrix(semiout[[16]],Ntimes,px+1); robVcum <-matrix(semiout[[17]],Ntimes,px+1); robVcum[,1] <-cum[,1]; if (fix.gamma==0) gamma<-matrix(semiout[[18]],pg,1); Vargam<-matrix(semiout[[19]],pg,pg); robVargam<-matrix(semiout[[20]],pg,pg); intZHZ<-matrix(semiout[[40]],pg,pg); intZHdN<-matrix(semiout[[41]],pg,1); Vargam2 <-matrix(semiout[[50]],pg,pg); gamma2<-matrix(semiout[[49]],pg,1); if (retur==1) { cumAi<-matrix(semiout[[31]],Ntimes,fdata$antpers*1); cumAi<-list(time=Vcum[,1],dM=cumAi); #cumAI<-list(); #for (i in (0:(fdata$antclust-1))*p) cumAI[[i/p+1]]<-cumAi[,i+(1:p)] } else cumAi<-NULL; unifCI<-c(); if (sim>=1) { test<-matrix(semiout[[23]],antsim,3*px); testOBS<-semiout[[24]]; for (i in 1:(3*px)) testval<-c(testval,pval(test[,i],testOBS[i])) Uit<-matrix(semiout[[28]],Ntimes,50*px); UIt<-list(); for (i in (0:49)*px) UIt[[i/px+1]]<-Uit[,i+(1:px)]; Ut<-matrix(semiout[[27]],Ntimes,(px+1)); for (i in 1:px) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); pval.testBeq0<-as.vector(testval[1:px]); pval.testBeqC<-as.vector(testval[(px+1):(2*px)]); pval.testBeqC.is<-as.vector(testval[(2*px+1):(3*px)]); obs.testBeq0<-as.vector(testOBS[1:px]); obs.testBeqC<-as.vector(testOBS[(px+1):(2*px)]); obs.testBeqC.is<-as.vector(testOBS[(2*px+1):(3*px)]); sim.testBeq0<-as.matrix(test[,1:px]); sim.testBeqC<-as.matrix(test[,(px+1):(2*px)]); sim.testBeqC.is<-as.matrix(test[,(2*px+1):(3*px)]); } else {test<-NULL; unifCI<-NULL;UIt<-NULL; Ut<-NULL; pval.testBeq0<-NULL;pval.testBeqC<-NULL; obs.testBeq0<-NULL;obs.testBeqC<-NULL; sim.testBeq0<-NULL; sim.testBeqC<-NULL; sim.testBeqC.is<-NULL; pval.testBeqC.is<-NULL; obs.testBeqC.is<-NULL; } tau=max(cum[,1]) ## }}} ud<-list(cum=cum,var.cum=Vcum,robvar.cum=robVcum, gamma=gamma,var.gamma=Vargam,robvar.gamma=robVargam,residuals=cumAi, pval.testBeq0=pval.testBeq0, obs.testBeq0=obs.testBeq0, pval.testBeqC=pval.testBeqC,pval.testBeqC.is=pval.testBeqC.is, obs.testBeqC=obs.testBeqC, obs.testBeqC.is=obs.testBeqC.is, sim.testBeq0= sim.testBeq0, sim.testBeqC=sim.testBeqC,sim.testBeqC.is=sim.testBeqC.is, conf.band=unifCI,test.procBeqC=Ut,sim.test.procBeqC=UIt, covariance=cov.list,B.iid=B.iid,gamma.iid=gamma.iid, intZHZ=intZHZ,intZHdN=intZHdN,stratum=stratum); ### ,gamma2=gamma2/tau,var.gamma2=Vargam2/tau^2) return(ud); } timereg/R/new.cox-aalen.r0000644000176200001440000005232614421510301014730 0ustar liggesusers#' Identifies the multiplicative terms in Cox-Aalen model and proportional #' excess risk model #' #' Specifies which of the regressors that belong to the multiplicative part of #' the Cox-Aalen model #' #' \deqn{ \lambda_{i}(t) = Y_i(t) ( X_{i}^T(t) \alpha(t) ) \exp(Z_{i}^T(t) #' \beta ) }{} for this model prop specified the covariates to be included in #' \eqn{Z_{i}(t)} #' @param x variable #' #' @author Thomas Scheike #' @keywords survival prop<-function(x) x #' Fit Cox-Aalen survival model #' #' Fits an Cox-Aalen survival model. Time dependent variables and counting #' process data (multiple events per subject) are possible. #' #' \deqn{ \lambda_{i}(t) = Y_i(t) ( X_{i}^T(t) \alpha(t) ) \exp(Z_{i}^T \beta ) }{} #' #' The model thus contains the Cox's regression model as special case. #' #' To fit a stratified Cox model it is important to parametrize the baseline #' apppropriately (see example below). #' #' Resampling is used for computing p-values for tests of time-varying effects. #' Test for proportionality is considered by considering the score processes #' for the proportional effects of model. #' #' The modelling formula uses the standard survival modelling given in the #' \bold{survival} package. #' #' The data for a subject is presented as multiple rows or 'observations', each #' of which applies to an interval of observation (start, stop]. For counting #' process data with the )start,stop] notation is used, the 'id' variable is #' needed to identify the records for each subject. The program assumes that #' there are no ties, and if such are present random noise is added to break #' the ties. #' #' @param formula a formula object with the response on the left of a '~' #' operator, and the independent terms on the right as regressors. The response #' must be a survival object as returned by the `Surv' function. Terms with a #' proportional effect are specified by the wrapper prop(), and cluster #' variables (for computing robust variances) by the wrapper cluster(). #' @param data a data.frame with the variables. #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. Default is max of data. #' @param robust to compute robust variances and construct processes for #' resampling. May be set to 0 to save memory and time, in particular for #' rate.sim=1. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param clusters cluster variable for computation of robust variances. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing time-varying effects. #' @param residuals to returns residuals that can be used for model validation #' in the function cum.residuals. Estimated martingale increments (dM) and #' corresponding time vector (time). When rate.sim=1 returns estimated #' martingales, dM_i(t) and if rate.sim=0, returns a matrix of dN_i(t). #' @param covariance to compute covariance estimates for nonparametric terms #' rather than just the variances. #' @param resample.iid to return i.i.d. representation for nonparametric and #' parametric terms. based on counting process or martingale resduals #' (rate.sim). #' @param beta starting value for relative risk estimates. #' @param Nit number of iterations for Newton-Raphson algorithm. #' @param detail if 0 no details is printed during iterations, if 1 details are #' given. #' @param weights weights for weighted analysis. #' @param rate.sim rate.sim=1 such that resampling of residuals is based on #' estimated martingales and thus valid in rate case, rate.sim=0 means that #' resampling is based on counting processes and thus only valid in intensity #' case. #' @param beta.fixed option for computing score process for fixed relative risk #' parameter #' @param max.clust sets the total number of i.i.d. terms in i.i.d. #' decompostition. This can limit the amount of memory used by coarsening the #' clusters. When NULL then all clusters are used. Default is 1000 to save #' memory and time. #' @param exact.deriv if 1 then uses exact derivative in last iteration, if 2 #' then uses exact derivate for all iterations, and if 0 then uses #' approximation for all computations and there may be a small bias in the #' variance estimates. For Cox model always exact and all options give same #' results. #' @param silent if 1 then opppresses some output. #' @param max.timepoint.sim considers only this resolution on the time scale #' for simulations, see time.sim.resolution argument #' @param basesim 1 to get simulations for cumulative baseline, including tests #' for contant effects. #' @param offsets offsets for analysis on log-scale. RR=exp(offsets+ x beta). #' @param strata future option for making strata in a different day than #' through X design in cox-aalen model (~-1+factor(strata)). #' @param propodds if 1 will fit the proportional odds model. Slightly less #' efficient than prop.odds() function but much quicker, for large data this #' also works. #' @param caseweight these weights have length equal to number of jump times, #' and are multiplied all jump times dN. Useful for getting the program to fit #' for example the proportional odds model or frailty models. #' @return returns an object of type "cox.aalen". With the following arguments: #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval. } \item{var.cum}{the martingale #' based pointwise variance estimates. } \item{robvar.cum}{robust pointwise #' variances estimates. } \item{gamma}{estimate of parametric components of #' model. } \item{var.gamma}{variance for gamma sandwhich estimator based on #' optional variation estimator of score and 2nd derivative.} #' \item{robvar.gamma}{robust variance for gamma. } \item{residuals}{list with #' residuals.} \item{obs.testBeq0}{observed absolute value of supremum of #' cumulative components scaled with the variance.} #' \item{pval.testBeq0}{p-value for covariate effects based on supremum test.} #' \item{sim.testBeq0}{resampled supremum values.} \item{obs.testBeqC}{observed #' absolute value of supremum of difference between observed cumulative process #' and estimate under null of constant effect.} \item{pval.testBeqC}{p-value #' based on resampling.} \item{sim.testBeqC}{resampled supremum values.} #' \item{obs.testBeqC.is}{observed integrated squared differences between #' observed cumulative and estimate under null of constant effect.} #' \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{sim.testBeqC.is}{resampled supremum values.} #' \item{conf.band}{resampling based constant to construct robust 95\% uniform #' confidence bands. } \item{test.procBeqC}{observed test-process of difference #' between observed cumulative process and estimate under null of constant #' effect over time. } \item{sim.test.procBeqC}{list of 50 random realizations #' of test-processes under null based on resampling.} #' \item{covariance}{covariances for nonparametric terms of model.} #' \item{B.iid}{Resample processes for nonparametric terms of model.} #' \item{gamma.iid}{Resample processes for parametric terms of model.} #' \item{loglike}{approximate log-likelihood for model, similar to Cox's #' partial likelihood. Only computed when robust=1.} \item{D2linv}{inverse of #' the derivative of the score function.} \item{score}{value of score for final #' estimates.} \item{test.procProp}{observed score process for proportional #' part of model.} \item{var.score}{variance of score process (optional #' variation estimator for beta.fixed=1 and robust estimator otherwise).} #' \item{pval.Prop}{p-value based on resampling.} \item{sim.supProp}{re-sampled #' absolute supremum values.} \item{sim.test.procProp}{list of 50 random #' realizations of test-processes for proportionality under the model based on #' resampling.} #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' library(timereg) #' data(sTRACE) #' # Fits Cox model #' out<-cox.aalen(Surv(time,status==9)~prop(age)+prop(sex)+ #' prop(vf)+prop(chf)+prop(diabetes),data=sTRACE) #' #' # makes Lin, Wei, Ying test for proportionality #' summary(out) #' par(mfrow=c(2,3)) #' plot(out,score=1) #' #' # Fits stratified Cox model #' out<-cox.aalen(Surv(time,status==9)~-1+factor(vf)+ prop(age)+prop(sex)+ #' prop(chf)+prop(diabetes),data=sTRACE,max.time=7,n.sim=100) #' summary(out) #' par(mfrow=c(1,2)); plot(out); #' # Same model, but needs to invert the entire marix for the aalen part: X(t) #' out<-cox.aalen(Surv(time,status==9)~factor(vf)+ prop(age)+prop(sex)+ #' prop(chf)+prop(diabetes),data=sTRACE,max.time=7,n.sim=100) #' summary(out) #' par(mfrow=c(1,2)); plot(out); #' #' #' # Fits Cox-Aalen model #' out<-cox.aalen(Surv(time,status==9)~prop(age)+prop(sex)+ #' vf+chf+prop(diabetes),data=sTRACE,max.time=7,n.sim=100) #' summary(out) #' par(mfrow=c(2,3)) #' plot(out) #' cox.aalen<-function(formula=formula(data),data=parent.frame(), beta=NULL,Nit=20,detail=0,start.time=0,max.time=NULL, id=NULL, clusters=NULL, n.sim=500, residuals=0,robust=1, weighted.test=0,covariance=0,resample.iid=1,weights=NULL, rate.sim=1,beta.fixed=0,max.clust=1000,exact.deriv=1,silent=1, max.timepoint.sim=100,basesim=0,offsets=NULL,strata=NULL,propodds=0,caseweight=NULL) { ## {{{ # {{{ set up variables if (n.sim == 0) sim <- 0 else sim <- 1 if (resample.iid==1 & robust==0) {resample.iid <- 0;} if (covariance==1 & robust==0) {covariance<-0;cat("Covariance of baseline only for robust=1\n"); } if (robust==0 ) { n.sim <- 0; sim<-0;} if (n.sim>0 & n.sim<50) {n.sim<-50 ; cat("Minimum 50 simulations\n");} if (beta.fixed==1) Nit<-1; call <- match.call() m <- match.call(expand.dots=FALSE) m$robust<-m$start.time<- m$scaleLWY<-m$weighted.test<-m$beta<-m$Nit<-m$detail<- m$max.time<-m$residuals<-m$n.sim<-m$id<-m$covariance<-m$resample.iid<- m$clusters<-m$rate.sim<-m$beta.fixed<- m$max.clust <- m$exact.deriv <- m$silent <- m$max.timepoint.sim <- m$silent <- m$basesim <- m$offsets <- m$strata <- m$propodds <- m$caseweight <- NULL special <- c("prop","cluster") Terms <- if(missing(data)) terms(formula, special) else terms(formula, special, data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) m <- na.omit(m) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") des<-read.design(m,Terms,model="cox.aalen") X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ pxz <- px + pz; ### if ( (nrow(Z)!=nrow(data)) && (!is.null(id))) stop("Missing values in design matrix not allowed with id\n"); ### if (nrow(Z)!=nrow(data)) stop("Missing values in design matrix not allowed\n"); if (!is.null(id)) { if (length(id)!=nrow(Z)) stop("id length and data not the same\n"); } ### if clusters=null perhaps given through cluster() special that can be NULL also if (is.null(clusters)) clusters <- des$clusters cluster.call<-clusters; survs<-read.surv(m,id,npar,clusters,start.time,max.time,model="cox.aalen",silent=silent) times<-survs$times; id<-id.call<-survs$id.cal; ### if no clusters then return "id" as cluster variable clusters<- gclusters <- survs$clusters; start.call <- start <- survs$start; stop.call <- time2 <- survs$stop; status<-survs$status; status.call <- status orig.max.clust <- survs$antclust nobs <- nrow(X); if (is.null(weights)) weights <- rep(1,nrow(X)); ### weights <- rep(1,nrow(X)); if (length(weights)!=nrow(X)) stop("Lengths of weights and data do not match\n"); if (is.null(offsets)) offsets <- rep(0,nrow(X)); offsets.call <- offsets; weights.call <- weights; if (length(offsets)!=nrow(X)) stop("Lengths of offsets and data do not match\n"); if (!is.null(strata)) { if (length(strata)!=nrow(X)) stop("Lengths of strata and data do not match\n"); iids <- unique(strata) antiid <- length(iids) if (is.numeric(strata)) strata <- sindex.prodlim(iids,strata)-1 else strata<- as.integer(factor(strata, labels = seq(antiid)))-1 } if (rate.sim==1 && robust==1) if ((!is.null(max.clust))) if (max.clust=2) {cat("starting values (coxph) \n"); print(beta);} } if ( (attr(m[, 1], "type") == "right" ) ) { ## {{{ # order in time, status=0 first for ties ot<-order(-time2,status==1); time2<-time2[ot]; status<-status[ot]; X<-as.matrix(X[ot,]) if (npar==FALSE) Z<-as.matrix(Z[ot,]) stop<-time2; clusters<-clusters[ot] id<-id[ot]; weights <- weights[ot] offsets <- offsets[ot] entry=rep(-1,nobs); if (!is.null(strata)) strata <- strata[ot] } else { eventtms <- c(survs$start,time2) status <- c(rep(0, nobs), status) ### order: strata , time, status=0 first for ties ### if (!is.null(strata)) ix<-order(strata,-eventtms,status==1) else ix <- order(-eventtms,status==1) etimes <- eventtms[ix] # Entry/exit times status <- status[ix] stop <- etimes; start <- rep(survs$start,2)[ix]; tdiff <- c(-diff(etimes),start.time) # Event time differences entry <- c(rep(c(1, -1), each = nobs))[ix] weights <- rep(weights, 2)[ix] X <- X[rep(1:nobs, 2)[ix],] if (npar==FALSE) Z <- Z[rep(1:nobs,2)[ix],] id <- rep(id,2)[ix] clusters <- rep(clusters,2)[ix] offsets <- rep(offsets,2)[ix] if (!is.null(strata)) strata <- rep(strata,2)[ix] } ## }}} ldata<-list(start=start,stop=stop,antpers=survs$antpers,antclust=survs$antclust); ## }}} ### if (npar==FALSE) covar<-data.matrix(cbind(X,Z)) else if (npar==TRUE) stop("Both multiplicative and additive model needed"); Ntimes <- sum(status); if (px==0) stop("No nonparametric terms (needs one!)"); ud<-cox.aalenBase(times,ldata,X,Z, status,id,clusters,Nit=Nit,detail=detail,beta=beta,weights=weights, sim=sim,antsim=n.sim,residuals=residuals,robust=robust, weighted.test=weighted.test,ratesim=rate.sim, covariance=covariance,resample.iid=resample.iid,namesX=covnamesX, namesZ=covnamesZ,beta.fixed=beta.fixed,entry=entry,basesim=basesim, offsets=offsets,exactderiv=exact.deriv,max.timepoint.sim=max.timepoint.sim,silent=silent, strata=strata,propodds=propodds,caseweight=caseweight) ## {{{ output handling colnames(ud$test.procProp)<-c("time",covnamesZ) if (beta.fixed==1) colnames(ud$var.score)<-c("time",covnamesZ) if (robust==1 & beta.fixed==0) colnames(ud$var.score)<-c("time",covnamesZ) if (px>0) { colnames(ud$cum)<-colnames(ud$var.cum)<- c("time",covnamesX) if (robust==1) colnames(ud$robvar.cum)<- c("time",covnamesX) if (sim==1) { names(ud$pval.Prop)<- covnamesZ if (basesim[1]>0) { names(ud$conf.band)<- names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<- names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<- colnames(ud$sim.testBeq0)<- covnamesX; } } } covariance<-ud$covariance rownames(ud$gamma)<-c(covnamesZ); colnames(ud$gamma)<-"estimate"; rownames(ud$score)<-c(covnamesZ); colnames(ud$score)<-"score"; namematrix(ud$var.gamma,covnamesZ); namematrix(ud$robvar.gamma,covnamesZ); if (beta.fixed==1) {ud$var.gamma<-matrix(0,pz,pz); ud$robvar.gamma<-matrix(0,pz,pz); } namematrix(ud$D2linv,covnamesZ); ud$prop.odds <- propodds class(ud)<-"cox.aalen" attr(ud,"Call")<-call; attr(ud,"stratum")<-ud$stratum; attr(ud,"Formula")<-formula; attr(ud,"formula")<-formula; attr(ud,"rate.sim")<-rate.sim; attr(ud,"id.call")<-id.call; attr(ud,"id")<-id.call; attr(ud,"cluster.call")<-cluster.call; attr(ud,"cluster")<-gclusters; attr(ud,"time2")<-time2; attr(ud,"start.time")<-start.time; attr(ud,"start")<-start.call; attr(ud,"stop")<-stop.call; attr(ud,"weights")<-weights.call; attr(ud,"offsets")<-offsets.call; attr(ud,"propodds")<-propodds attr(ud,"type")<-"survival" attr(ud,"beta.fixed")<-beta.fixed attr(ud,"status")<-status.call; attr(ud,"residuals")<-residuals; attr(ud,"max.clust")<-max.clust; attr(ud,"max.time")<-max.time; attr(ud,"n")<-ldata$antpers; attr(ud,"orig.max.clust")<- orig.max.clust attr(ud,"max.timepoint.sim")<-max.timepoint.sim; ud$call<-call ## }}} return(ud); } ## }}} "plot.cox.aalen" <- function (x,pointwise.ci=1, hw.ci=0, sim.ci=0, robust.ci=0, col=NULL, specific.comps=FALSE,level=0.05, start.time = 0, stop.time = 0, add.to.plot=FALSE,main=NULL,mains=TRUE,xlab="Time",score=FALSE, ylab="Cumulative coefficients",...) { ## {{{ object <- x; rm(x); if (!inherits(object,'cox.aalen') ) stop ("Must be output from Cox-Aalen function") if (ylab=="Cumulative coefficients" && (1*score)>=1) ylab <- "Cumulative MG-residuals" if (score==FALSE) plot.cums(object, pointwise.ci=pointwise.ci, hw.ci=hw.ci, sim.ci=sim.ci, robust.ci=robust.ci, col=col, specific.comps=specific.comps,level=level, start.time = start.time, stop.time = stop.time, add.to.plot=add.to.plot, main=main, mains=mains, xlab=xlab,ylab=ylab,...) else plotScore(object, specific.comps=specific.comps, mains=mains, main=main,xlab=xlab,ylab=ylab,...); } ## }}} "print.cox.aalen" <- function (x,...) { ## {{{ summary.cox.aalen(x,...) ### cox.aalen.object <- x; rm(x); ### if (!inherits(cox.aalen.object, 'cox.aalen')) ### stop ("Must be an aalen object") ###if (is.null(cox.aalen.object$prop.odds)==TRUE) p.o<-FALSE else p.o<-TRUE ###if (is.null(cox.aalen.object$gamma)==TRUE) prop<-FALSE else prop<-TRUE ### ### # We print information about object: ### cat("Cox-Aalen Model \n\n") ### cat("Additive Aalen terms : "); ### cat(colnames(cox.aalen.object$cum)[-1]); cat(" \n"); ### if (prop) { ### cat("Proportional Cox terms : "); ### cat(rownames(cox.aalen.object$gamma)); ### cat(" \n"); } ### cat(" \n"); ### ### cat(" Call: \n") ### dput(attr(cox.aalen.object,"Call")) ### cat("\n") } ## }}} "summary.cox.aalen" <- function (object,digits = 3,...) { ## {{{ cox.aalen.object <- object; rm(object); obj<-cox.aalen.object if (!inherits(cox.aalen.object, 'cox.aalen')) stop ("Must be a Cox-Aalen object") prop<-TRUE; if (is.null(cox.aalen.object$gamma)==TRUE) stop(" No regression terms"); if (cox.aalen.object$prop.odds==0) p.o<-FALSE else p.o<-TRUE if (p.o==FALSE) cat("Cox-Aalen Model \n\n") else cat("Proportional Odds model \n\n") if (sum(abs(cox.aalen.object$score)>0.000001)) cat("Did not converge, allow more iterations\n\n"); if (p.o==FALSE) cat("Test for Aalen terms \n") else cat("Test for baseline \n") if (is.null(obj$conf.band)==TRUE) mtest<-FALSE else mtest<-TRUE; if (mtest==FALSE) cat("Test not computed, sim=0 \n\n") if (mtest==TRUE) { timetest(obj,digits=digits) } if (prop) { if (p.o==FALSE) cat("Proportional Cox terms : \n") else cat("Covariate effects \n") out=coef.cox.aalen(obj); out=signif(out,digits=digits) print(out) if (p.o==FALSE) cat("Test of Proportionality \n") else cat("Test of Goodness-of-fit \n") if (is.null(obj$pval.Prop)==TRUE) ptest<-FALSE else ptest<-TRUE; if (ptest==FALSE) cat("Test not computed, sim=0 \n\n") if (ptest==TRUE) { testP<-cbind( apply(abs(as.matrix(obj$test.procProp[,-1])),2,max), obj$pval.Prop) testP<-as.matrix(testP); colnames(testP) <- c("sup| hat U(t) |","p-value H_0 ") prmatrix(signif(testP,digits)); cat("\n"); } } ### cat(" \n"); ### cat(" Call: \n") ### dput(attr(obj, "Call")) ### cat("\n") } ## }}} coef.cox.aalen<-function(object,digits=3,d2logl=1,...) { coefBase(object,digits=digits, d2logl=d2logl,...) } vcov.cox.aalen <- function(object,robust=0, ...) { if (robust==0) rv <- object$var.gamma else rv <- object$robvar.gamma if (!identical(rv, matrix(0, nrow = 1L, ncol = 1L))) rv # else return NULL } timereg/R/prop-odds.r0000644000176200001440000003406614421510301014201 0ustar liggesusers#' Fit Semiparametric Proportional 0dds Model #' #' Fits a semiparametric proportional odds model: \deqn{ logit(1-S_Z(t)) = #' log(G(t)) + \beta^T Z }{} where G(t) is increasing but otherwise unspecified. #' Model is fitted by maximising the modified partial likelihood. A #' goodness-of-fit test by considering the score functions is also computed by #' resampling methods. #' #' The modelling formula uses the standard survival modelling given in the #' \bold{survival} package. #' #' For large data sets use the divide.conquer.timereg of the mets package to #' run the model on splits of the data, or the alternative estimator by the #' cox.aalen function. #' #' The data for a subject is presented as multiple rows or "observations", each #' of which applies to an interval of observation (start, stop]. The program #' essentially assumes no ties, and if such are present a little random noise #' is added to break the ties. #' #' @param formula a formula object, with the response on the left of a '~' #' operator, and the terms on the right. The response must be a Event object #' as returned by the `Event' function. #' @param data a data.frame with the variables. #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. This is very useful to #' obtain stable estimates, especially for the baseline. Default is max of #' data. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing time-varying effects. #' @param beta starting value for relative risk estimates #' @param Nit number of iterations for Newton-Raphson algorithm. #' @param detail if 0 no details is printed during iterations, if 1 details are #' given. #' @param profile if profile is 1 then modified partial likelihood is used, #' profile=0 fits by simple estimating equation. The modified partial #' likelihood is recommended. #' @param sym to use symmetrized second derivative in the case of the #' estimating equation approach (profile=0). This may improve the numerical #' performance. #' @param baselinevar set to 0 to omit calculations of baseline variance. #' @param clusters to compute cluster based standard errors. #' @param max.clust number of maximum clusters to be used, to save time in iid #' decomposition. #' @param weights weights for score equations. #' @return returns an object of type 'cox.aalen'. With the following arguments: #' #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval.} \item{var.cum}{the martingale #' based pointwise variance estimates. } \item{robvar.cum}{robust pointwise #' variances estimates. } \item{gamma}{estimate of proportional odds #' parameters of model.} \item{var.gamma}{variance for gamma. } #' \item{robvar.gamma}{robust variance for gamma. } \item{residuals}{list with #' residuals. Estimated martingale increments (dM) and corresponding time #' vector (time).} \item{obs.testBeq0}{observed absolute value of supremum of #' cumulative components scaled with the variance.} #' \item{pval.testBeq0}{p-value for covariate effects based on supremum test.} #' \item{sim.testBeq0}{resampled supremum values.} \item{obs.testBeqC}{observed #' absolute value of supremum of difference between observed cumulative process #' and estimate under null of constant effect.} \item{pval.testBeqC}{p-value #' based on resampling.} \item{sim.testBeqC}{resampled supremum values.} #' \item{obs.testBeqC.is}{observed integrated squared differences between #' observed cumulative and estimate under null of constant effect.} #' \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{sim.testBeqC.is}{resampled supremum values.} #' \item{conf.band}{resampling based constant to construct robust 95\% uniform #' confidence bands. } \item{test.procBeqC}{observed test-process of difference #' between observed cumulative process and estimate under null of constant #' effect over time.} \item{loglike}{modified partial likelihood, pseudo #' profile likelihood for regression parameters.} \item{D2linv}{inverse of the #' derivative of the score function.} \item{score}{value of score for final #' estimates.} \item{test.procProp}{observed score process for proportional #' odds regression effects.} \item{pval.Prop}{p-value based on resampling.} #' \item{sim.supProp}{re-sampled supremum values.} #' \item{sim.test.procProp}{list of 50 random realizations of test-processes #' for constant proportional odds under the model based on resampling.} #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' data(sTRACE) #' # Fits Proportional odds model #' out<-prop.odds(Event(time,status==9)~age+diabetes+chf+vf+sex, #' sTRACE,max.time=7,n.sim=100) #' summary(out) #' #' par(mfrow=c(2,3)) #' plot(out,sim.ci=2) #' plot(out,score=1) #' #' pout <- predict(out,Z=c(70,0,0,0,0)) #' plot(pout) #' #' ### alternative estimator for large data sets #' form <- Surv(time,status==9)~age+diabetes+chf+vf+sex #' pform <- timereg.formula(form) #' out2<-cox.aalen(pform,data=sTRACE,max.time=7, #' propodds=1,n.sim=0,robust=0,detail=0,Nit=40) #' summary(out2) #' #' @export prop.odds<-function(formula,data=parent.frame(),beta=NULL, Nit=20,detail=0,start.time=0,max.time=NULL,id=NULL,n.sim=500,weighted.test=0, profile=1,sym=0,baselinevar=1,clusters=NULL,max.clust=1000,weights=NULL) { ## {{{ out <- prop.odds.subdist(formula,data=data,beta=beta,cause=1, Nit=Nit,detail=detail,start.time=start.time,max.time=max.time,id=id,n.sim=n.sim, weighted.test=weighted.test, profile=profile,sym=sym,cens.model="po",clusters=clusters,max.clust=max.clust,baselinevar=1,weights=weights) return(out); } ## }}} prop.odds.gam<-function(formula,data=parent.frame(),beta=NULL, Nit=10,detail=0,start.time=0,max.time=NULL,id=NULL,n.sim=500,weighted.test=0, profile=1,sym=0,baselinevar=1,clusters=NULL,max.clust=1000) { ## {{{ id.call<-id; call<-match.call(); residuals<-0; robust<-0; ratesim<-0; resample.iid <- 1 # profile<-0; m<-match.call(expand.dots = FALSE); m$sym<-m$profile<-m$max.time<-m$start.time<-m$weighted.test<-m$n.sim<- m$id<-m$Nit<-m$detail<-m$beta <- m$baselinevar<-m$clusters <- m$max.clust <- NULL if (n.sim==0) sim<-0 else sim<-1; antsim<-n.sim; 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()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") if (attr(m[, 1], "type") == "right") { time2 <- m[, 1][, "time"]; time <- rep(0,length(time2)); status <- m[, 1][, "status"] } else if (attr(m[, 1], "type") == "counting") { time <- m[, 1][,1]; time2 <- m[, 1][,2]; status <- m[, 1][,3]; } else { stop("only right-censored or counting processes data") } X <- model.matrix(Terms, m)[,-1,drop=FALSE]; covnamesX<-dimnames(X)[[2]]; desX<-as.matrix(X); if(is.matrix(desX) == TRUE) pg <- as.integer(dim(desX)[2]) if(is.matrix(desX) == TRUE) nx <- as.integer(dim(desX)[1]) px<-1; Ntimes <- sum(status); # adds random noise to make survival times unique if (sum(duplicated(time2[status==1]))>0) { #cat("Non unique survival times: break ties ! \n") #cat("Break ties yourself\n"); ties<-TRUE dtimes<-time2[status==1] index<-(1:length(time2))[status==1] ties<-duplicated(dtimes); nties<-sum(ties); index<-index[ties] dt<-diff(sort(time2)); dt<-min(dt[dt>0]); time2[index]<-time2[index]+runif(nties,0,min(0.001,dt/2)); } else ties<-FALSE; start<-time; stop<-time2; dtimes<-time2[status==1]; times<-c(start.time,dtimes[dtimes>start.time]); times<-sort(times); if (is.null(max.time)==TRUE) maxtimes<-max(times)+0.1 else maxtimes<-max.time; times<-times[times<=maxtimes] Ntimes <- length(times); if ((nrow(X)!=nrow(data)) && (!is.null(id))) stop("Missing values in design matrix not allowed with id\n"); ### if (nrow(X)!=nrow(data)) stop("Missing values in design matrix not allowed\n"); ######################################################################## if (is.null(id)==TRUE) {antpers<-length(time); id<-0:(antpers-1); } else { pers<-unique(id); antpers<-length(pers); id<-as.integer(factor(id,labels=1:(antpers)))-1; } cluster.call<-clusters; if (is.null(clusters)== TRUE) {clusters<-id; antclust<-antpers;} else { clus<-unique(clusters); antclust<-length(clus); clusters <- as.integer(factor(clusters, labels = 1:(antclust))) - 1; } if ((!is.null(max.clust))) if (max.clust0) { if (sim==1) { colnames(ud$test.procProp)<-c("time",covnamesX) names(ud$pval.Prop)<-covnamesX names(ud$conf.band)<-names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<-names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<-colnames(ud$sim.testBeq0)<-"Baseline"; } } rownames(ud$gamma)<-c(covnamesX); colnames(ud$gamma)<-"estimate"; rownames(ud$score)<-c(covnamesX); colnames(ud$score)<-"score"; namematrix(ud$var.gamma,covnamesX); namematrix(ud$robvar.gamma,covnamesX); namematrix(ud$D2linv,covnamesX); attr(ud,"Call")<-call; attr(ud,"Formula")<-formula; attr(ud,"id")<-id.call; attr(ud,"basesim") <- 1 attr(ud,"type") <- "survival" class(ud)<-"cox.aalen" return(ud); } ## }}} timereg/R/restricted.residual.mean.r0000644000176200001440000001321314421510301017157 0ustar liggesusers#' Estimates restricted residual mean for Cox or Aalen model #' #' The restricted means are the \deqn{ \int_0^\tau S(t) dt } the standard #' errors are computed using the i.i.d. decompositions from the cox.aalen (that #' must be called with the argument "max.timpoint.sim=NULL") or aalen function. #' #' must have computed iid decomposition of survival models for standard errors #' to be computed. Note that competing risks models can be fitted but then the #' interpretation is not clear. #' #' @param out an "cox.aalen" with a Cox model or an "aalen" model. #' @param x matrix with covariates for Cox model or additive hazards model #' (aalen). #' @param tau restricted residual mean. #' @param iid if iid=1 then uses iid decomposition for estimation of standard #' errors. #' @return Returns an object. With the following arguments: #' \item{mean}{restricted mean for different covariates.} #' \item{var.mean}{variance matrix.} \item{se}{standard errors.} #' \item{S0tau}{estimated survival functions on time-range [0,tau].} #' \item{timetau}{vector of time arguments for S0tau.} #' @author Thomas Scheike #' @references D. M. Zucker, Restricted mean life with covariates: Modification #' and extension of a useful survival analysis method, J. Amer. Statist. Assoc. #' vol. 93 pp. 702-709, 1998. #' #' Martinussen and Scheike, Dynamic Regression Models for Survival Data, #' Springer (2006). #' @keywords survival #' @examples #' #' \donttest{ #' ### this example runs slowly and is therefore donttest #' data(sTRACE) #' sTRACE$cage <- scale(sTRACE$age) #' # Fits Cox model and aalen model #' out<-cox.aalen(Surv(time,status>=1)~prop(sex)+prop(diabetes)+prop(chf)+ #' prop(vf),data=sTRACE,max.timepoint.sim=NULL,resample.iid=1) #' outa<-aalen(Surv(time,status>=1)~sex+diabetes+chf+vf, #' data=sTRACE,resample.iid=1) #' #' coxrm <- restricted.residual.mean(out,tau=7, #' x=rbind(c(0,0,0,0),c(0,0,1,0),c(0,0,1,1),c(0,0,0,1)),iid=1) #' plot(coxrm) #' summary(coxrm) #' #' ### aalen model not optimal here #' aalenrm <- restricted.residual.mean(outa,tau=7, #' x=rbind(c(1,0,0,0,0),c(1,0,0,1,0),c(1,0,0,1,1),c(1,0,0,0,1)),iid=1) #' with(aalenrm,matlines(timetau,S0tau,type="s",ylim=c(0,1))) #' legend("bottomleft",c("baseline","+chf","+chf+vf","+vf"),col=1:4,lty=1) #' summary(aalenrm) #' #' mm <-cbind(coxrm$mean,coxrm$se,aalenrm$mean,aalenrm$se) #' colnames(mm)<-c("cox-res-mean","se","aalen-res-mean","se") #' rownames(mm)<-c("baseline","+chf","+chf+vf","+vf") #' mm #' } #' #' @export restricted.residual.mean <- function(out,x=0,tau=10,iid=0) { ## {{{ if ((!inherits(out,c('cox.aalen',"aalen","survfit")))) stop ("Must be output from cox.aalen or aalen function\n") if (inherits(out,"survfit")) { ## {{{ fit.table <- as.matrix(summary(out, rmean=tau)$table) if (ncol(fit.table)==1) fit.table <- t(fit.table) ee <- fit.table[,"*rmean"] se <- fit.table[,"*se(rmean)"] variid <- diag(se^2) S0t <- NULL timetau <- NULL } ## }}} if (inherits(out,"cox.aalen")) { ## {{{ time <- out$cum[,1] cumhaz <- out$cum[,2] beta <- out$gamma if (is.matrix(x)!=TRUE) x <- matrix(x,nrow=1) timetau <- c(time[time0)~x1+x2,data=mydata,cause=mydata$cause,causeS=1) #' #' the new code is #' #' comp.risk(Event(time,cause)~x1+x2,data=mydata,cause=1) #' #' Also the argument cens.code is now obsolete since cens.code is an argument #' of \code{\link{Event}}. #' #' @param formula a formula object, with the response on the left of a '~' #' operator, and the terms on the right. The response must be a survival object #' as returned by the `Event' function. The status indicator is not important #' here. Time-invariant regressors are specified by the wrapper const(), and #' cluster variables (for computing robust variances) by the wrapper cluster(). #' @param data a data.frame with the variables. #' @param cause For competing risk models specificies which cause we consider. #' @param times specifies the times at which the estimator is considered. #' Defaults to all the times where an event of interest occurs, with the first #' 10 percent or max 20 jump points removed for numerical stability in #' simulations. #' @param Nit number of iterations for Newton-Raphson algorithm. #' @param clusters specifies cluster structure, for backwards compability. #' @param est possible starting value for nonparametric component of model. #' @param fix.gamma to keep gamma fixed, possibly at 0. #' @param gamma starting value for constant effects. #' @param n.sim number of simulations in resampling. #' @param weighted Not implemented. To compute a variance weighted version of #' the test-processes used for testing time-varying effects. #' @param model "additive", "prop"ortional, "rcif", or "logistic". #' @param detail if 0 no details are printed during iterations, if 1 details #' are given. #' @param interval specifies that we only consider timepoints where the #' Kaplan-Meier of the censoring distribution is larger than this value. #' @param resample.iid to return the iid decomposition, that can be used to #' construct confidence bands for predictions #' @param cens.model specified which model to use for the ICPW, KM is #' Kaplan-Meier alternatively it may be "cox" #' @param cens.formula specifies the regression terms used for the regression #' model for chosen regression model. When cens.model is specified, the default #' is to use the same design as specified for the competing risks model. #' @param time.pow specifies that the power at which the time-arguments is #' transformed, for each of the arguments of the const() terms, default is 1 #' for the additive model and 0 for the proportional model. #' @param time.pow.test specifies that the power the time-arguments is #' transformed for each of the arguments of the non-const() terms. This is #' relevant for testing if a coefficient function is consistent with the #' specified form A_l(t)=beta_l t^time.pow.test(l). Default is 1 for the #' additive model and 0 for the proportional model. #' @param silent if 0 information on convergence problems due to non-invertible #' derviates of scores are printed. #' @param conv gives convergence criterie in terms of sum of absolute change of #' parameters of model #' @param weights weights for estimating equations. #' @param max.clust sets the total number of i.i.d. terms in i.i.d. #' decompostition. This can limit the amount of memory used by coarsening the #' clusters. When NULL then all clusters are used. Default is 1000 to save #' memory and time. #' @param first.time.p first point for estimation is pth percentile of cause #' jump times. #' @param n.times only uses 50 points for estimation, if NULL then uses all #' points, subject to p.start condition. #' @param estimator default estimator is 1. #' @param trunc.p truncation weight for delayed entry, P(T > entry.time | Z_i), #' typically Cox model. #' @param cens.weights censoring weights can be given here rather than #' calculated using the KM, cox or aalen models. #' @param admin.cens censoring times for the administrative censoring #' @param conservative set to 0 to compute correct variances based on censoring #' weights, default is conservative estimates that are much quicker. #' @param monotone monotone=0, uses estimating equations \deqn{ (D_\beta P_1) w(t) ( Y(t)/G_c(t) - P_1(t,X))}{} montone=1 uses \deqn{ w(t) X ( Y(t)/G_c(t) - P_1(t,X)) }{} #' @param step step size for Fisher-Scoring algorithm. #' @return returns an object of type 'comprisk'. With the following arguments: #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval.} \item{var.cum}{pointwise variances #' estimates. } \item{gamma}{estimate of proportional odds parameters of #' model.} \item{var.gamma}{variance for gamma. } \item{score}{sum of absolute #' value of scores.} \item{gamma2}{estimate of constant effects based on the #' non-parametric estimate. Used for testing of constant effects.} #' \item{obs.testBeq0}{observed absolute value of supremum of cumulative #' components scaled with the variance.} \item{pval.testBeq0}{p-value for #' covariate effects based on supremum test.} \item{obs.testBeqC}{observed #' absolute value of supremum of difference between observed cumulative process #' and estimate under null of constant effect.} \item{pval.testBeqC}{p-value #' based on resampling.} \item{obs.testBeqC.is}{observed integrated squared #' differences between observed cumulative and estimate under null of constant #' effect.} \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{conf.band}{resampling based constant to construct 95\% uniform #' confidence bands.} \item{B.iid}{list of iid decomposition of non-parametric #' effects.} \item{gamma.iid}{matrix of iid decomposition of parametric #' effects.} \item{test.procBeqC}{observed test process for testing of #' time-varying effects} \item{sim.test.procBeqC}{50 resample processes for for #' testing of time-varying effects} \item{conv}{information on convergence for #' time points used for estimation.} #' @author Thomas Scheike #' @references Scheike, Zhang and Gerds (2008), Predicting cumulative incidence #' probability by direct binomial regression,Biometrika, 95, 205-220. #' #' Scheike and Zhang (2007), Flexible competing risks regression modelling and #' goodness of fit, LIDA, 14, 464-483. #' #' Martinussen and Scheike (2006), Dynamic regression models for survival data, #' Springer. #' @keywords survival #' @examples #' #' data(bmt); #' #' clust <- rep(1:204,each=2) #' addclust<-comp.risk(Event(time,cause)~platelet+age+tcell+cluster(clust),data=bmt, #' cause=1,resample.iid=1,n.sim=100,model="additive") #' ### #' #' addclust<-comp.risk(Event(time,cause)~+1+cluster(clust),data=bmt,cause=1, #' resample.iid=1,n.sim=100,model="additive") #' pad <- predict(addclust,X=1) #' plot(pad) #' #' add<-comp.risk(Event(time,cause)~platelet+age+tcell,data=bmt, #' cause=1,resample.iid=1,n.sim=100,model="additive") #' summary(add) #' #' par(mfrow=c(2,4)) #' plot(add); #' ### plot(add,score=1) ### to plot score functions for test #' #' ndata<-data.frame(platelet=c(1,0,0),age=c(0,1,0),tcell=c(0,0,1)) #' par(mfrow=c(2,3)) #' out<-predict(add,ndata,uniform=1,n.sim=100) #' par(mfrow=c(2,2)) #' plot(out,multiple=0,uniform=1,col=1:3,lty=1,se=1) #' #' ## fits additive model with some constant effects #' add.sem<-comp.risk(Event(time,cause)~ #' const(platelet)+const(age)+const(tcell),data=bmt, #' cause=1,resample.iid=1,n.sim=100,model="additive") #' summary(add.sem) #' #' out<-predict(add.sem,ndata,uniform=1,n.sim=100) #' par(mfrow=c(2,2)) #' plot(out,multiple=0,uniform=1,col=1:3,lty=1,se=0) #' #' ## Fine & Gray model #' fg<-comp.risk(Event(time,cause)~ #' const(platelet)+const(age)+const(tcell),data=bmt, #' cause=1,resample.iid=1,model="fg",n.sim=100) #' summary(fg) #' #' out<-predict(fg,ndata,uniform=1,n.sim=100) #' #' par(mfrow=c(2,2)) #' plot(out,multiple=1,uniform=0,col=1:3,lty=1,se=0) #' #' ## extended model with time-varying effects #' fg.npar<-comp.risk(Event(time,cause)~platelet+age+const(tcell), #' data=bmt,cause=1,resample.iid=1,model="prop",n.sim=100) #' summary(fg.npar); #' #' out<-predict(fg.npar,ndata,uniform=1,n.sim=100) #' head(out$P1[,1:5]); head(out$se.P1[,1:5]) #' #' par(mfrow=c(2,2)) #' plot(out,multiple=1,uniform=0,col=1:3,lty=1,se=0) #' #' ## Fine & Gray model with alternative parametrization for baseline #' fg2<-comp.risk(Event(time,cause)~const(platelet)+const(age)+const(tcell),data=bmt, #' cause=1,resample.iid=1,model="prop",n.sim=100) #' summary(fg2) #' #' ################################################################# #' ## Delayed entry models, #' ################################################################# #' nn <- nrow(bmt) #' entrytime <- rbinom(nn,1,0.5)*(bmt$time*runif(nn)) #' bmt$entrytime <- entrytime #' times <- seq(5,70,by=1) #' #' bmtw <- prep.comp.risk(bmt,times=times,time="time",entrytime="entrytime",cause="cause") #' #' ## non-parametric model #' outnp <- comp.risk(Event(time,cause)~tcell+platelet+const(age), #' data=bmtw,cause=1,fix.gamma=1,gamma=0, #' cens.weights=bmtw$cw,weights=bmtw$weights,times=times,n.sim=0) #' par(mfrow=c(2,2)) #' plot(outnp) #' #' outnp <- comp.risk(Event(time,cause)~tcell+platelet, #' data=bmtw,cause=1, #' cens.weights=bmtw$cw,weights=bmtw$weights,times=times,n.sim=0) #' par(mfrow=c(2,2)) #' plot(outnp) #' #' #' ## semiparametric model #' out <- comp.risk(Event(time,cause)~const(tcell)+const(platelet),data=bmtw,cause=1, #' cens.weights=bmtw$cw,weights=bmtw$weights,times=times,n.sim=0) #' summary(out) #' #' ##' @export comp.risk<-function(formula,data=parent.frame(),cause,times=NULL,Nit=50,clusters=NULL,est=NULL, fix.gamma=0,gamma=0,n.sim=0,weighted=0,model="fg",detail=0,interval=0.01,resample.iid=1, cens.model="KM",cens.formula=NULL,time.pow=NULL,time.pow.test=NULL,silent=1,conv=1e-6, weights=NULL,max.clust=1000,n.times=50,first.time.p=0.05,estimator=1, trunc.p=NULL,cens.weights=NULL,admin.cens=NULL,conservative=1,monotone=0,step=NULL) # {{{ { if (!missing(cause)){ if (length(cause)!=1) stop("Argument cause has new meaning since timereg version 1.8.4., it now specifies the cause of interest, see help(comp.risk) for details.") } ## {{{ # trans=1 P_1=1-exp( - ( x' b(b)+ z' gam t) ), # trans=2 P_1=1-exp(-exp(x a(t)+ z` b ) Fine-Gray model, with baseline exp(x a(t)) # trans=3 P_1= exp(x a(t)+ z` b)/( exp(x a(t) + z' b) +1 ); logistic # trans=4 P_1=exp( ( x' b(b)+ z' gam ) ), # trans=5 P_1= (x' b(t)) exp( z' gam ), # trans=6 P_1=1-exp(-(x a(t)) exp(z` b )) Fine-Gray model, with baseline x a(t) # trans=7 P_1= (x a(t)) exp( z` b)/( (x a(t) ) exp(z' b) +1 ); logistic2 trans <- switch(model,additive=1,prop=2,logistic=3,rcif=4,rcif2=5,fg=6,logistic2=7) ### if (model=="additive") trans<-1; if (model=="prop") trans<-2; if (model=="logistic") trans<-3; ### if (model=="rcif") trans<-4; if (model=="rcif2") trans<-5; if (model=="fg") trans<-6; ### if (model=="logistic2") trans<-7; line <- 0 cause.call <- causeS <- cause m <- match.call(expand.dots=FALSE); m$gamma<-m$times<-m$n.times<-m$cause<-m$Nit<-m$weighted<-m$n.sim<- m$model<-m$detail<- m$cens.model<-m$time.pow<-m$silent<- m$step <- m$cens.formula <- m$interval<- m$clusters<-m$resample.iid<- m$monotone <- m$time.pow.test<-m$conv<- m$weights <- m$max.clust <- m$first.time.p<- m$trunc.p <- m$cens.weights <- m$admin.cens <- m$fix.gamma <- m$est <- m$conservative <- m$estimator <- NULL if ((trans==2 || trans==3 || trans==7) && is.null(step)) step <- 0.5 if (is.null(step)) step <- 1 special <- c("const","cluster") if (missing(data)) { Terms <- terms(formula, special) } else { Terms <- terms(formula, special, data = data) } m$formula <- Terms if (substr(as.character(m$formula)[2],1,4)=="Hist") { stop("Since timereg version 1.8.6.: The left hand side of the formula must be specified as Event(time, event) or with non default censoring codes Event(time, event, cens.code=0).") } m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) if (NROW(m) == 0) stop("No (non-missing) observations") mt <- attr(m, "terms") intercept <- attr(mt, "intercept") event.history <- model.extract(m, "response") if (!inherits(event.history,"Event")){ stop("Since timereg version 1.8.6.: The left hand side of the formula must be specified as Event(time, event) or with non default censoring codes Event(time, event, cens.code=0).") } model.type <- "competing.risks" ## {{{ Event stuff cens.code <- attr(event.history,"cens.code") if (ncol(event.history)==2) { time2 <- eventtime <- event.history[,1] status <- delta <- event.history[,2] entrytime <- rep(0,length(time2)) left <- 0 } else { time2 <- eventtime <- event.history[,2] status <- delta <- event.history[,3] entrytime <- event.history[,1] left <- 1 if (max(entrytime)==0) left <- 0 } event <- (abs(status)==cause) if (sum(event)==0) stop("No events of interest in data\n"); ## }}} if (n.sim==0) sim<-0 else sim<-1; antsim<-n.sim; des<-read.design(m,Terms) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ; if (nrow(X)!=nrow(data)) stop("Missing values in design matrix not allowed\n"); if (is.diag(t(X) %*% X)==TRUE) stratum <- 1 else stratum <- 0; ## {{{ cluster set up if(is.null(clusters)){ clusters <- des$clusters} if(is.null(clusters)){ cluster.call<-clusters; clusters <- 0:(nrow(X) - 1) antclust <- nrow(X) } else { cluster.call<-clusters; antclust <- length(unique(clusters)) clusters <- as.integer(factor(clusters,labels=1:antclust))-1 } coarse.clust <- FALSE; if ((!is.null(max.clust))) if (max.clust< antclust) { coarse.clust <- TRUE qq <- unique(quantile(clusters, probs = seq(0, 1, by = 1/max.clust))) qqc <- cut(clusters, breaks = qq, include.lowest = TRUE) clusters <- as.integer(qqc)-1 max.clusters <- length(unique(clusters)) antclust <- max.clust } ## }}} pxz <-px+pz; if (is.null(times)) { timesc<-sort(unique(eventtime[event==1])); if (!is.null(n.times)) { if (length(timesc)> n.times) times <- quantile(timesc,prob=seq(first.time.p,1,length=n.times)) else times <- timesc } else {times<-timesc; times<-times[times> quantile(timesc,prob=first.time.p)]; } } else times <- sort(times); n<-nrow(X); ntimes<-length(times); if (npar==TRUE) {Z<-matrix(0,n,1); pg<-1; fixed<-0;} else {fixed<-1;pg<-pz;} if (is.null(weights)==TRUE) weights <- rep(1,n); ## }}} ## {{{ censoring and estimator if (!is.null(admin.cens)) estimator <- 3; Gcxe <- 1; ordertime <- order(eventtime); ###dcumhazcens <- rep(0,n); if (estimator==1 || estimator==2) { if (is.null(cens.weights)) { ## {{{ censoring model stuff with possible truncation if (cens.model=="KM") { ## {{{ if (left==1) ud.cens<-survfit(Surv(entrytime,eventtime,delta==cens.code)~+1) else ud.cens<-survfit(Surv(eventtime,delta==cens.code)~+1) Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); Gcx<-Cpred(Gfit,eventtime,strict=TRUE)[,2]; Gcxe<-Cpred(Gfit,entrytime,strict=TRUE)[,2]; ### strictly before, but starts in 1. Gcxe[Gcxe==0] <- 1 ### only conditional on L if trunc given if (!is.null(trunc.p)) Gcx <- Gcx/Gcxe; Gctimes<-Cpred(Gfit,times,strict=TRUE)[,2]; ## }}} } else if (cens.model=="stratKM") { ## {{{ XZ <- model.matrix(cens.formula,data=data); strata <- as.factor(XZ) Gcx <- pred.stratKM(data,time=eventtime,cause=delta,strata=strata) ### only conditional on L if trunc given if (!is.null(trunc.p)) Gcx <- Gcx/Gcxe; Gctimes<-Cpred(Gfit,times)[,2]; ## }}} } else if (cens.model=="cox") { ## {{{ stop("Disabbled \n"); ### if (!is.null(cens.formula)) { ### data$eventtime__ <- eventtime ### data$entrytime__ <- entrytime ### data$delta__C <- delta==cens.code ### if (left==1) ### formC <- update.formula(cens.formula,Surv(entrytime__,eventtime__,delta__C)~.) ### else formC <- update.formula(cens.formula,Surv(eventtime__,delta__C)~.) ### } else { ### } ### ud.cens<-coxph(formC,data=data) ### baseout <- basehaz(ud.cens,centered=FALSE); ### baseout <- cbind(baseout$time,baseout$hazard) ### Gcx<-Cpred(baseout,eventtime,strict=TRUE)[,2]; ### Gcxe<-Cpred(baseout,entrytime,strict=TRUE)[,2]; ### Gcxe[Gcxe==0] <- 1 ### RR<-exp(as.matrix(XZ) %*% coef(ud.cens)) ### Gcx<-exp(-Gcx*RR) ### Gcxe<-exp(-Gcxe*RR) ### Gfit<-rbind(c(0,1),cbind(eventtime,Gcx)); ### ### only conditional on L if trunc given ### if (!is.null(trunc.p)) Gcx <- Gcx/Gcxe; ### Gctimes<-Cpred(Gfit,times,strict=TRUE)[,2]; ## }}} } else if (cens.model=="aalen") { ## {{{ if (!is.null(cens.formula)) { XZ <- model.matrix(cens.formula,data=data); } else { if (npar==TRUE) XZ <-X else XZ <-cbind(X,Z); } if (left==1) ud.cens<-aalen(Surv(entrytime,eventtime,delta==cens.code)~-1+XZ+cluster(clusters), n.sim=0,residuals=0,robust=0,silent=1) else ud.cens<-aalen(Surv(eventtime,delta==cens.code)~-1+XZ+cluster(clusters), n.sim=0,residuals=0,robust=0,silent=1); Gcx <- Cpred(ud.cens$cum,eventtime,strict=TRUE)[,-1]; Gcx<-exp(-apply(Gcx*XZ,1,sum)) Gcx[Gcx>1]<-1; Gcx[Gcx<0]<-1 Gcxe <- Cpred(ud.cens$cum,entrytime,strict=TRUE)[,2]; Gcxe[Gcxe==0] <- 1 if (!is.null(trunc.p)) Gcx <- Gcx/Gcxe; Gfit<-rbind(c(0,1),cbind(eventtime,Gcx)); Gctimes<-Cpred(Gfit,times,strict=TRUE)[,2]; ## }}} } else stop('Unknown censoring model') cens.weights <- Gcx if ((min(Gcx[event==1])< 0.00001) && (silent==0)) { cat("Censoring dist. approx zero for some points, summary cens:\n"); print(summary(Gcx)) } ## }}} } else { if (length(cens.weights)!=n) stop("censoring weights must have length equal to nrow in data\n"); Gcx <- cens.weights ### for left truncation specification ord2 <- order(time2) Gctimes <- Cpred(cbind(time2[ord2],weights[ord2]),times) } } else { ## estimator==3 admin.cens if (length(admin.cens)!=n) stop("censoring weights must have length equal to nrow in data\n"); Gcx <- admin.cens Gctimes <- rep(1,length(times)); } if (left==1 & is.null(trunc.p) & is.null(cens.weights)) { ## {{{ ### geskus weights: from mstate crprep stop("For left-truncated data call prep.comp.risk\n call with weights and cens.weights\n"); n=length(time2) prec.factor <- 100 prec <- .Machine$double.eps * prec.factor surv.trunc <- survfit(Surv(-time2,-entrytime+prec,rep(1,n)) ~ 1) trunc.dist <- summary(surv.trunc) trunc.dist$time <- rev(-trunc.dist$time) trunc.dist$surv <- c(rev(trunc.dist$surv)[-1], 1) Lfit <-Cpred(cbind(trunc.dist$time,trunc.dist$surv),time2) Lw <- Lfit[,2] ### weights <- 1/Lw weights <- 1/((Lw)*Gcx); weights[delta==cens.code] <- 0 Gcx <- rep(1,n) } ## }}} if (is.null(trunc.p)) trunc.p <- rep(1,n); if (length(trunc.p)!=n) stop("truncation weights must have same length as data\n"); ## }}} ## {{{ setting up more variables if (resample.iid == 1) { biid <- double(ntimes* antclust * px); gamiid<- double(antclust *pg); } else { gamiid <- biid <- NULL; } ps<-px; betaS<-rep(0,ps); ## possible starting value for nonparametric components if (is.null(est)) { est<-matrix(0.0+0.1,ntimes,px+1); est[,1] <- times; } else { est <- as.matrix(est); } if (nrow(est)!=length(times)) est <- Cpred(est,times); hess<-matrix(0,ps,ps); var<-score<-matrix(0,ntimes,ps+1); if (sum(gamma)==0) gamma<-rep(0,pg); gamma2<-rep(0,ps); test<-matrix(0,antsim,3*ps); testOBS<-rep(0,3*ps); unifCI<-c(); testval<-c(); rani<--round(runif(1)*10000); Ut<-matrix(0,ntimes,ps+1); simUt<-matrix(0,ntimes,50*ps); var.gamma<-matrix(0,pg,pg); pred.covs.sem<-0 if (is.null(time.pow)==TRUE & model=="prop" ) time.pow<-rep(0,pg); if (is.null(time.pow)==TRUE & model=="fg" ) time.pow<-rep(0,pg); if (is.null(time.pow)==TRUE & model=="additive") time.pow<-rep(1,pg); if (is.null(time.pow)==TRUE & model=="rcif" ) time.pow<-rep(0,pg); if (is.null(time.pow)==TRUE & model=="rcif2" ) time.pow<-rep(0,pg); if (is.null(time.pow)==TRUE & model=="logistic" ) time.pow<-rep(0,pg); if (is.null(time.pow)==TRUE & model=="logistic2" )time.pow<-rep(0,pg); if (length(time.pow)!=pg) time.pow <- rep(time.pow[1],pg); if (is.null(time.pow.test)==TRUE & model=="prop" ) time.pow.test<-rep(0,px); if (is.null(time.pow.test)==TRUE & model=="fg" ) time.pow.test<-rep(0,px); if (is.null(time.pow.test)==TRUE & model=="additive") time.pow.test<-rep(1,px); if (is.null(time.pow.test)==TRUE & model=="rcif" ) time.pow.test<-rep(0,px); if (is.null(time.pow.test)==TRUE & model=="rcif2" ) time.pow.test<-rep(0,px); if (is.null(time.pow.test)==TRUE & model=="logistic" ) time.pow.test<-rep(0,px); if (is.null(time.pow.test)==TRUE & model=="logistic2" ) time.pow.test<-rep(0,px); if (length(time.pow.test)!=px) time.pow.test <- rep(time.pow.test[1],px); if (ntimes>1) silent <- c(silent,rep(0,ntimes-1)) ## }}} ### print(Gctimes); ### dyn.load("comprisk.so"0 ssf <- step; ## takes step size over out<-.C("itfit", ## {{{ as.double(times),as.integer(ntimes),as.double(eventtime), as.integer(cens.code), as.integer(status),as.double(Gcx), as.double(X),as.integer(n),as.integer(px), as.integer(Nit), as.double(betaS), as.double(score), as.double(hess), as.double(est), as.double(var), as.integer(sim),as.integer(antsim),as.integer(rani), as.double(test), as.double(testOBS), as.double(Ut), as.double(simUt),as.integer(weighted),as.double(gamma), as.double(var.gamma),as.integer(fixed),as.double(Z), as.integer(pg),as.integer(trans),as.double(gamma2), as.integer(cause),as.integer(line),as.integer(detail), as.double(biid),as.double(gamiid),as.integer(resample.iid), as.double(time.pow),as.integer(clusters),as.integer(antclust), as.double(time.pow.test),as.integer(silent), as.double(conv), as.double(weights),as.double(entrytime),as.double(trunc.p), as.integer(estimator),as.integer(fix.gamma), as.integer(stratum), as.integer(ordertime-1),as.integer(conservative), as.double(ssf), as.double(Gctimes),as.double(rep(0,pg)),as.double(matrix(0,pg,pg)), as.integer(monotone),PACKAGE="timereg") ## }}} ## {{{ handling output ssf <- out[[51]]; gamma<-matrix(out[[24]],pg,1); var.gamma<-matrix(out[[25]],pg,pg); Dscore.gamma<-matrix(out[[54]],pg,pg); gamma2<-matrix(out[[30]],ps,1); rownames(gamma2)<-covnamesX; conv <- list(convp=out[[41]],convd=out[[42]]); if (fixed==0) gamma<-NULL; if (resample.iid==1) { biid<-matrix(out[[34]],ntimes,antclust*px); if (fixed==1) gamiid<-matrix(out[[35]],antclust,pg) else gamiid<-NULL; B.iid<-list(); for (i in (0:(antclust-1))*px) { B.iid[[i/px+1]]<-matrix(biid[,i+(1:px)],ncol=px); colnames(B.iid[[i/px+1]])<-covnamesX; } if (fixed==1) colnames(gamiid)<-covnamesZ } else B.iid<-gamiid<-NULL; if (sim==1) { simUt<-matrix(out[[22]],ntimes,50*ps); UIt<-list(); for (i in (0:49)*ps) UIt[[i/ps+1]]<-as.matrix(simUt[,i+(1:ps)]); Ut<-matrix(out[[21]],ntimes,ps+1); test<-matrix(out[[19]],antsim,3*ps); testOBS<-out[[20]]; supUtOBS<-apply(abs(as.matrix(Ut[,-1])),2,max); p<-ps for (i in 1:(3*p)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:p) unifCI<-as.vector(c(unifCI,percen(test[,i],0.95))); pval.testBeq0<-as.vector(testval[1:p]); pval.testBeqC<-as.vector(testval[(p+1):(2*p)]); pval.testBeqC.is<-as.vector(testval[(2*p+1):(3*p)]); obs.testBeq0<-as.vector(testOBS[1:p]); obs.testBeqC<-as.vector(testOBS[(p+1):(2*p)]); obs.testBeqC.is<-as.vector(testOBS[(2*p+1):(3*p)]); sim.testBeq0<-as.matrix(test[,1:p]); sim.testBeqC<-as.matrix(test[,(p+1):(2*p)]); sim.testBeqC.is<-as.matrix(test[,(2*p+1):(3*p)]); } else {test<-unifCI<-Ut<-UIt<-pval.testBeq0<-pval.testBeqC<-obs.testBeq0<- obs.testBeqC<- sim.testBeq0<-sim.testBeqC<- sim.testBeqC.is<- pval.testBeqC.is<- obs.testBeqC.is<-NULL; } est<-matrix(out[[14]],ntimes,ps+1); ## in case of no convergence set estimates to NA est[conv$convp>0,-1] <- NA score<-matrix(out[[12]],ntimes,ps+1); gamscore <- matrix(out[[53]],pg,1) scores <- list(score=score,gamscore=gamscore) var<-matrix(out[[15]],ntimes,ps+1); ## in case of no convergence set var to NA var[conv$convp>0,-1] <- NA colnames(var)<-colnames(est)<-c("time",covnamesX); if (sim>=1) { colnames(Ut)<- c("time",covnamesX) names(unifCI)<-names(pval.testBeq0)<- names(pval.testBeqC)<- names(pval.testBeqC.is)<- names(obs.testBeq0)<- names(obs.testBeqC)<- names(obs.testBeqC.is)<- colnames(sim.testBeq0)<- colnames(sim.testBeqC)<- colnames(sim.testBeqC.is)<- covnamesX; } if (fixed==1) { rownames(gamma)<-c(covnamesZ); colnames(var.gamma)<- rownames(var.gamma)<-c(covnamesZ); } colnames(score)<-c("time",covnamesX); if (is.na(sum(score))==TRUE) score<-NA else if (sum(score[,-1])<0.00001) score<-sum(score[,-1]); ud<-list(cum=est,var.cum=var,gamma=gamma,score=score, gamma2=gamma2,var.gamma=var.gamma,robvar.gamma=var.gamma, pval.testBeq0=pval.testBeq0,pval.testBeqC=pval.testBeqC, obs.testBeq0=obs.testBeq0, obs.testBeqC.is=obs.testBeqC.is, obs.testBeqC=obs.testBeqC,pval.testBeqC.is=pval.testBeqC.is, conf.band=unifCI,B.iid=B.iid,gamma.iid=gamiid,ss=ssf, test.procBeqC=Ut,sim.test.procBeqC=UIt,conv=conv, weights=weights,cens.weights=cens.weights,scores=scores,Dscore.gamma=Dscore.gamma,step=step) ud$call<- match.call() ud$model<-model; ud$n<-n; ud$clusters <- clusters ud$formula<-formula; ud$response <- event.history ud$cause <- status class(ud)<-"comprisk"; attr(ud, "Call") <- match.call() attr(ud, "Formula") <- formula attr(ud, "time.pow") <- time.pow attr(ud, "causeS") <- causeS attr(ud, "cause") <- status attr(ud, "cluster.call") <- cluster.call attr(ud, "coarse.clust") <- coarse.clust attr(ud, "max.clust") <- max.clust attr(ud, "clusters") <- clusters attr(ud, "cens.code") <- cens.code attr(ud, "times") <- times return(ud); ## }}} } ## }}} ##' @export print.comprisk <- function (x,...) { ## {{{ object <- x; rm(x); if (!inherits(object, 'comprisk')) stop ("Must be an comprisk object") if (is.null(object$gamma)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: causeS <- attr(object,"causeS") print(causeS) cat(paste("\nAnalysed cause:",causeS,"\n")) cat(paste("\nLink _function:",object$model,"\n\n")) cat(" Nonparametric terms : "); cat(colnames(object$cum)[-1]); cat(" \n"); if (semi) { cat(" Parametric terms : "); cat(rownames(object$gamma)); cat(" \n"); } if (object$conv$convd>=1) { if (all(object$conv$convp==1)){ if (NROW(object$cum)>1){ cat("\nWarning: problem with convergence at all time points\n") } else{ cat("\nWarning: problem with convergence at the evaluation time.\n") } }else{ cat("Warning: problem with convergence at the following time points:\n") cat(object$cum[object$conv$convp>0,1]) cat("\nYou may try to readjust analyses by removing these time points\n") } } cat(" \n"); } ## }}} ##' @export coef.comprisk <- function(object, digits=3,...) { ## {{{ coefBase(object,digits=digits) } ## }}} ##' @export summary.comprisk <- function (object,digits = 3,...) { ## {{{ if (!inherits(object, 'comprisk')) stop ("Must be a comprisk object") if (is.null(object$gamma)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: cat("Competing risks Model \n\n") modelType<-object$model #if (modelType=="additive" || modelType=="rcif") if (sum(object$obs.testBeq0)==FALSE) cat("No test for non-parametric terms\n") else timetest(object,digits=digits); if (semi) { if (sum(abs(object$score)>0.000001)) cat("Did not converge, allow more iterations\n\n"); cat("Parametric terms : \n"); prmatrix(coef(object,digits=digits)) cat(" \n"); } if (object$conv$convd>=1) { cat("WARNING problem with convergence for time points:\n") cat(object$cum[object$conv$convp>0,1]) cat("\nReadjust analyses by removing points\n\n") } } ## }}} ##' @export vcov.comp.risk <- function(object, ...) { rv <- object$robvar.gamma if (!identical(rv, matrix(0, nrow = 1L, ncol = 1L))) rv # else return NULL } ##' @export plot.comprisk <- function (x, pointwise.ci=1, hw.ci=0, sim.ci=0, specific.comps=FALSE,level=0.05, start.time = 0, stop.time = 0, add.to.plot=FALSE, mains=TRUE, xlab="Time", ylab ="Coefficients",score=FALSE,...){ ## {{{ object <- x; rm(x); if (!inherits(object,'comprisk') ){ stop ("Must be output from comp.risk function") } if (score==FALSE) { B<-object$cum; V<-object$var.cum; p<-dim(B)[[2]]; if (sum(specific.comps)==FALSE){ comp<-2:p } else { comp<-specific.comps+1 } if (stop.time==0) { stop.time<-max(B[,1]); } med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; V<-V[med,]; c.alpha<- qnorm(1-level/2) for (v in comp) { c.alpha<- qnorm(1-level/2) est<-B[,v]; ul<-B[,v]+c.alpha*V[,v]^.5; nl<-B[,v]-c.alpha*V[,v]^.5; if (add.to.plot==FALSE) { plot(B[,1],est,ylim=1.05*range(ul,nl),type="s",xlab=xlab,ylab=ylab,...) if (mains==TRUE) title(main=colnames(B)[v]); } else { lines(B[,1],est,type="s"); } if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="s"); lines(B[,1],nl,lty=pointwise.ci,type="s"); } if (hw.ci>=1) { if (level!=0.05){ cat("Hall-Wellner bands only 95 % \n"); } tau<-length(B[,1]) nl<-B[,v]-1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) ul<-B[,v]+1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) lines(B[,1],ul,lty=hw.ci,type="s"); lines(B[,1],nl,lty=hw.ci,type="s"); } if (sim.ci>=1) { if (is.null(object$conf.band)==TRUE){ cat("Uniform simulation based bands only computed for n.sim> 0\n") } if (level!=0.05){ c.alpha<-percen(object$sim.testBeq0[,v-1],1-level) } else { c.alpha<-object$conf.band[v-1]; } nl<-B[,v]-c.alpha*V[,v]^.5; ul<-B[,v]+c.alpha*V[,v]^.5; lines(B[,1],ul,lty=sim.ci,type="s"); lines(B[,1],nl,lty=sim.ci,type="s"); } abline(h = 0) } } else { # plot score proces if (is.null(object$pval.testBeqC)==TRUE) { cat("Simulations not done \n"); cat("To construct p-values and score processes under null n.sim>0 \n"); } else { if (ylab=="Cumulative regression function"){ ylab<-"Test process"; } dim1<-ncol(object$test.procBeqC) if (sum(specific.comps)==FALSE){ comp<-2:dim1 } else { comp<-specific.comps+1 } for (i in comp){ ranyl<-range(object$test.procBeqC[,i]); for (j in 1:50){ ranyl<-range(c(ranyl,(object$sim.test.procBeqC[[j]])[,i-1])); } mr<-max(abs(ranyl)); plot(object$test.procBeqC[,1], object$test.procBeqC[,i], ylim=c(-mr,mr),lwd=2,xlab=xlab,ylab=ylab,type="s",...) if (mains==TRUE){ title(main=colnames(object$test.procBeqC)[i]); } for (j in 1:50){ lines(object$test.procBeqC[,1], as.matrix(object$sim.test.procBeqC[[j]])[,i-1],col="grey",lwd=1,lty=1,type="s") } lines(object$test.procBeqC[,1],object$test.procBeqC[,i],lwd=2,type="s") } } } } ## }}} #' Set up weights for delayed-entry competing risks data for comp.risk function #' #' Computes the weights of Geskus (2011) modified to the setting of the #' comp.risk function. The returned weights are #' \eqn{1/(H(T_i)*G_c(min(T_i,tau)))} and tau is the max of the times argument, #' here \eqn{H} is the estimator of the truncation distribution and \eqn{G_c} #' is the right censoring distribution. #' #' #' @param data data frame for comp.risk. #' @param times times for estimating equations. #' @param entrytime name of delayed entry variable, if not given computes #' right-censoring case. #' @param time name of survival time variable. #' @param cause name of cause indicator #' @param cname name of censoring weight. #' @param tname name of truncation weight. #' @param strata strata variable to obtain stratified weights. #' @param nocens.out returns only uncensored part of data-frame #' @param cens.formula censoring model formula for Cox models for the #' truncation and censoring model. #' @param cens.code code for censoring among causes. #' @param prec.factor precision factor, for ties between censoring/even times, #' truncation times/event times #' @param trunc.mintau specicies wether the truncation distribution is #' evaluated in death times or death times minimum max(times), FALSE makes the #' estimator equivalent to Kaplan-Meier (in the no covariate case). #' @return Returns an object. With the following arguments: \item{dataw}{a #' data.frame with weights.} #' #' The function wants to make two new variables "weights" and "cw" so if these #' already are in the data frame it tries to add an "_" in the names. #' @author Thomas Scheike #' @references Geskus (2011), Cause-Specific Cumulative Incidence Estimation #' and the Fine and Gray Model Under Both Left Truncation and Right Censoring, #' Biometrics (2011), pp 39-49. #' #' Shen (2011), Proportional subdistribution hazards regression for #' left-truncated competing risks data, Journal of Nonparametric Statistics #' (2011), 23, 885-895 #' @keywords survival #' @examples #' #' data(bmt) #' nn <- nrow(bmt) #' entrytime <- rbinom(nn,1,0.5)*(bmt$time*runif(nn)) #' bmt$entrytime <- entrytime #' times <- seq(5,70,by=1) #' #' ### adds weights to uncensored observations #' bmtw <- prep.comp.risk(bmt,times=times,time="time", #' entrytime="entrytime",cause="cause") #' #' ######################################### #' ### nonparametric estimates #' ######################################### #' ## {{{ #' ### nonparametric estimates, right-censoring only #' out <- comp.risk(Event(time,cause)~+1,data=bmt, #' cause=1,model="rcif2", #' times=c(5,30,70),n.sim=0) #' out$cum #' ### same as #' ###out <- prodlim(Hist(time,cause)~+1,data=bmt) #' ###summary(out,cause="1",times=c(5,30,70)) #' #' ### with truncation #' out <- comp.risk(Event(time,cause)~+1,data=bmtw,cause=1, #' model="rcif2", #' cens.weight=bmtw$cw,weights=bmtw$weights,times=c(5,30,70), #' n.sim=0) #' out$cum #' ### same as #' ###out <- prodlim(Hist(entry=entrytime,time,cause)~+1,data=bmt) #' ###summary(out,cause="1",times=c(5,30,70)) #' ## }}} #' #' ######################################### #' ### Regression #' ######################################### #' ## {{{ #' ### with truncation correction #' out <- comp.risk(Event(time,cause)~const(tcell)+const(platelet),data=bmtw, #' cause=1,cens.weight=bmtw$cw, #' weights=bmtw$weights,times=times,n.sim=0) #' summary(out) #' #' ### with only righ-censoring, standard call #' outn <- comp.risk(Event(time,cause)~const(tcell)+const(platelet),data=bmt, #' cause=1,times=times,n.sim=0) #' summary(outn) #' ## }}} #' #' ##' @export prep.comp.risk <- function(data,times=NULL,entrytime=NULL, time="time",cause="cause",cname="cweight",tname="tweight", strata=NULL,nocens.out=TRUE,cens.formula=NULL,cens.code=0, prec.factor=100,trunc.mintau=FALSE) { ## {{{ ## {{{ geskus weights, up to min(T_i,max(times)) if (is.null(times)) times <- max(data[,time]) if (is.null(entrytime)) entrytime <- rep(0,nrow(data)) else entrytime <- data[,entrytime] mtt <- max(times) prec.factor <- 100 prec <- .Machine$double.eps * prec.factor trunc.model <- cens.model <- NULL ## output of Cox models for entry cens if (is.null(cens.formula)) { if (is.null(strata)) { ## {{{ if (!is.null(entrytime)) { surv.trunc <- survfit(Surv(-data[,time],-entrytime+prec,rep(1,nrow(data))) ~ 1) trunc.dist <- summary(surv.trunc) trunc.dist$time <- rev(-trunc.dist$time) trunc.dist$surv <- c(rev(trunc.dist$surv)[-1], 1) if (trunc.mintau==TRUE) Lfit <-Cpred(cbind(trunc.dist$time,trunc.dist$surv),pmin(mtt,data[,time])) else Lfit <-Cpred(cbind(trunc.dist$time,trunc.dist$surv),data[,time]) Lw <- Lfit[,2] } else Lw <- 1 ud.cens<- survfit(Surv(entrytime,data[,time],data[,cause]==0)~+1) Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); Gcx<-Cpred(Gfit,pmin(mtt,data[,time]),strict=TRUE)[,2]; weights <- 1/(Lw*Gcx); cweights <- Gcx; tweights <- Lw; ### ## }}} } else { ## {{{ ### compute for each strata and combine vstrata <- as.numeric(data[,strata]) weights <- rep(1,nrow(data)) cweights <- rep(1,nrow(data)) tweights <- rep(1,nrow(data)) for (i in unique(vstrata)) { ## {{{ for each strata who <- (vstrata == i) if (sum(who) <= 1) stop(paste("strata",i,"less than 1 observation\n")); datas <- subset(data,who) if (!is.null(entrytime)) { entrytimes <- entrytime[who] surv.trunc <- survfit(Surv(-datas[,time],-entrytimes+prec,rep(1,nrow(datas))) ~ +1) trunc.dist <- summary(surv.trunc) trunc.dist$time <- rev(-trunc.dist$time) trunc.dist$surv <- c(rev(trunc.dist$surv)[-1], 1) if (trunc.mintau==TRUE) Lfit <-Cpred(cbind(trunc.dist$time,trunc.dist$surv),pmin(mtt,datas[,time])) else Lfit <-Cpred(cbind(trunc.dist$time,trunc.dist$surv),datas[,time]) Lw <- Lfit[,2] } else Lw <- 1 ud.cens<- survfit(Surv(entrytimes,datas[,time],datas[,cause]==0)~+1) Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); Gcx<-Cpred(Gfit,pmin(mtt,datas[,time]),strict=TRUE)[,2]; weights[who]<- 1/(Lw*Gcx); cweights[who]<- Gcx; tweights[who]<- Lw; } ## }}} } ## }}} } else { ### cens.formula Cox models ## {{{ X <- model.matrix(cens.formula,data=data)[,-1,drop=FALSE]; if (!is.null(entrytime)) { trunc.model <- coxph(Surv(-data[,time],-entrytime+prec,rep(1,nrow(data))) ~ X) baseout <- basehaz(trunc.model,centered=FALSE); baseout <- cbind(rev(-baseout$time),rev(baseout$hazard)) ### if (trunc.mintau==TRUE) Lfit <-Cpred(baseout,pmin(mtt,data[,time]))[,-1] else Lfit <-Cpred(baseout,data[,time])[,-1] RR<-exp(as.matrix(X) %*% coef(trunc.model)) Lfit<-exp(-Lfit*RR) Lw <- Lfit } else Lw <- 1 ### cens.model <- coxph(Surv(entrytime,data[,time],data[,cause]==0)~+X) ### baseout <- basehaz(cens.model,centered=FALSE); ### baseout <- cbind(baseout$time,baseout$hazard) sfit <- survfit(cens.model, se.fit=FALSE) zcoef <- ifelse(is.na(coef(cens.model)), 0, coef(cens.model)) offset <- sum(cens.model$means * zcoef) chaz <- sfit$cumhaz * exp(-offset) baseout <- cbind(sfit$time,chaz) Gfit<-Cpred(baseout,pmin(mtt,data[,time]),strict=TRUE)[,2]; RR<-exp(as.matrix(X) %*% coef(cens.model)) Gfit<-exp(-Gfit*RR) weights <- 1/(Lw*Gfit); cweights <- Gfit tweights <- Lw } ## }}} data[,cname] <- cweights data[,tname] <- tweights if (!is.null(entrytime)) { mint <- min(tweights); maxt <- min(tweights) if (mint<0 | mint>1) warning("min(truncation weights) strange, maybe prec.factor should be different\n") if (maxt<0 | maxt>1) warning("max(truncation weights) strange, maybe prec.factor should be different\n") } if ("weights" %in% names(data)) { warning("Weights in variable names 'weights_' \n") wname<- "weights_" data[,wname] <- weights } else data[,"weights"] <- weights ### if ("cw" %in% names(data)) { warning("cw weights in variable names 'cw_' \n") cwname<- "cw_" data[,cwname] <- 1 } else data[,"cw"] <- 1 ### if (nocens.out) { med <- ((data[,time]>mtt & data[,cause]==cens.code)) | (data[,cause]!=cens.code) data <- data[med,] } else { med <- ((data[,time]>mtt & data[,cause]==cens.code)) | (data[,cause]!=cens.code) data[!med,"weights"] <- 0; data[!med,"cw"] <- 0 } attr(data,"trunc.model") <- trunc.model attr(data,"cens.model") <- cens.model ## }}} return(data) } ## }}} ##' @export pred.stratKM <- function(data,entrytime=NULL,time="time",cause="cause",strata="strata",event.code=0) { ## {{{ if (is.numeric(time)) time <- time else { if (!is.null(data)) time <- data[,time] else stop("time not given\n"); } if (is.numeric(cause)) cause <- cause else { if (!is.null(data)) cause <- data[,cause] else stop("cause not given\n"); } if (is.numeric(strata)) strata <- strata else { if (!is.null(data)) strata <- data[,strata] else stop("strata not given\n"); } if (is.null(entrytime)) entrytime <- rep(0,nrow(data)) else { if (is.numeric(entrytime)) entrytime <- entrytime else { if (!is.null(data)) entrytime <- data[,entrytime] else stop("entrytime not given\n"); } } vstrata <- as.numeric(strata) weights <- rep(1,length((data))) for (i in unique(vstrata)) { ## {{{ for each strata who <- (vstrata == i) if (sum(who) <= 1) stop(paste("strata",i,"less than 1 observation\n")); times <- time[who] causes <- cause[who] entrytimes <- entrytime[who] ud.cens<- survfit(Surv(entrytimes,times,causes==event.code)~+1) Gfit<-cbind(ud.cens$time,ud.cens$surv) Gfit<-rbind(c(0,1),Gfit); Gcx<-Cpred(Gfit,times,strict=TRUE)[,2]; weights[who]<- Gcx; } ## }}} return(weights); } ## }}} timereg/R/event.r0000644000176200001440000000633114657077730013436 0ustar liggesusers## t1 <- 1:10 ## t2 <- t1+runif(10) ## ca <- rbinom(10,2,0.4) ## x <- Event(t1,t2,ca) ## h <- Hist(t2,ca) ## s <- Surv(t2,ca) #' Event history object #' #' Constructur for Event History objects #' #' ... content for details #' #' @aliases Event as.character.Event as.matrix.Event [.Event format.Event #' print.Event rbind.Event summary.Event #' @param time Time #' @param time2 Time 2 #' @param cause Cause #' @param cens.code Censoring code (default 0) #' @param ... Additional arguments #' @return Object of class Event (a matrix) #' @author Klaus K. Holst and Thomas Scheike #' @examples #' #' t1 <- 1:10 #' t2 <- t1+runif(10) #' ca <- rbinom(10,2,0.4) #' (x <- Event(t1,t2,ca)) #' #' @export Event <- function(time,time2=TRUE,cause=NULL,cens.code=0,...) { out <- cbind(time,time2,cause) if (!missing(cause)) { colnames(out) <- c("entry","exit","cause") tmp <- (out[,1]>out[,2]) if (any(tmp)) warning("entry time later than exit time\n") tmp <- (out[,2]<=0) ### if (any(tmp)) warning("exit times must be >0\n") } else { colnames(out) <- c("exit","cause") ### tmp <- (out[,1]<=0) ### if (any(tmp)) warning("exit times must be >0\n") ### if (any(tmp) & !is.na(tmp)) warning("exit times must be >0\n") } class(out) <- "Event" attr(out,"cens.code") <- cens.code return(out) } #' @export as.matrix.Event <- function(x,...) structure(x,class="matrix") #' @export as.character.Event <- function(x,...) { if (ncol(x)==3) { res <- paste("(",format(x[,1],...),";", format(x[,2],...),":", format(x[,3],...),"]",sep="") } else { res <- paste(format(x[,1],...),":",format(x[,2],...),sep="") } return(res) } #' @export format.Event <- function(x, ...) format(as.character.Event(x), ...) #' @export as.data.frame.Event <- as.data.frame.model.matrix #' @export print.Event <- function(x,...) { print(as.matrix(x),...,quote=FALSE) } #' @export summary.Event <- function(object,...) { cat(paste("cens.code=",attr(object,"cens.code"),"\n")) cat("causes:\n") print(table(object[,"cause"])) cat("exit:\n") print(summary(object[,"exit"])) if (ncol(object)==3) { cat("entry:\n") print(summary(object[,"entry"])) cat("exit-entry:\n") print(summary(object[,"exit"]- object[,"entry"])) } } #' @export "[.Event" <- function (x, i, j, drop = FALSE) { if (missing(j)) { atr <- attributes(x) class(x) <- "matrix" x <- x[i, , drop = FALSE] class(x) <- "Event" atr.keep <- c("cens.code","entry") ### atr.keep <- c("cens.code") attributes(x)[atr.keep] <- atr[atr.keep] x } else { class(x) <- "matrix" NextMethod("[") } } #' @export rbind.Event <- function(...) { dots <- list(...) cens.code <- attributes(dots[[1]])$cens.code type <- attributes(dots[[1]])$type ncol <- dim(dots[[1]])[2] nrow <- unlist(lapply(dots,nrow)) cnrow <- c(0,cumsum(nrow)) M <- matrix(ncol=ncol,nrow=sum(nrow)) for (i in 1:length(dots)) { M[(cnrow[i]+1):cnrow[i+1],] <- dots[[i]] } x <- c(); for (i in 1:ncol(M)) x <- c(x,list(M[,i])) x <- c(x,list(cens.code=cens.code)) do.call("Event",x) } timereg/R/new.prop-excess.r0000644000176200001440000003060014421510301015320 0ustar liggesusers#' Identifies proportional excess terms of model #' #' Specifies which of the regressors that lead to proportional excess hazard #' #' @param x variable #' #' @author Thomas Scheike #' @keywords survival cox<-function(x) x #' Fits Proportional excess hazards model #' #' Fits proportional excess hazards model. #' #' The models are written using the survival modelling given in the survival #' package. #' #' The program assumes that there are no ties, and if such are present random #' noise is added to break the ties. #' #' @param formula a formula object, with the response on the left of a `~' #' operator, and the terms on the right. The response must be a survival #' object as returned by the `Surv' function. #' @param data a data.frame with the variables. #' @param excess specifies for which of the subjects the excess term is #' present. Default is that the term is present for all subjects. #' @param tol tolerance for numerical procedure. #' @param max.time stopping considered time-period if different from 0. #' Estimates thus computed from [0,max.time] if max.time>0. Default is max of #' data. #' @param n.sim number of simulations in re-sampling. #' @param alpha tuning paramter in Newton-Raphson procedure. Value smaller than #' one may give more stable convergence. #' @param frac number between 0 and 1. Is used in supremum test where observed #' jump times t1, ..., tk is replaced by t1, ..., tl with l=round(frac*k). #' @return Returns an object of type "prop.excess". With the following #' arguments: \item{cum}{estimated cumulative regression functions. First #' column contains the jump times, then follows the estimated components of #' additive part of model and finally the excess cumulative baseline. } #' \item{var.cum}{robust pointwise variance estimates for estimated #' cumulatives. } \item{gamma}{estimate of parametric components of model. } #' \item{var.gamma}{robust variance estimate for gamma. } \item{pval}{p-value #' of Kolmogorov-Smirnov test (variance weighted) for excess baseline and Aalen #' terms, H: B(t)=0. } \item{pval.HW}{p-value of supremum test (corresponding #' to Hall-Wellner band) for excess baseline and Aalen terms, H: B(t)=0. #' Reported in summary. } \item{pval.CM}{p-value of Cramer von Mises test for #' excess baseline and Aalen terms, H: B(t)=0. } \item{quant}{95 percent #' quantile in distribution of resampled Kolmogorov-Smirnov test statistics for #' excess baseline and Aalen terms. Used to construct 95 percent simulation #' band. } \item{quant95HW}{95 percent quantile in distribution of resampled #' supremum test statistics corresponding to Hall-Wellner band for excess #' baseline and Aalen terms. Used to construct 95 percent Hall-Wellner band. } #' \item{simScoreProp}{observed scoreprocess and 50 resampled scoreprocesses #' (under model). List with 51 elements. } #' @author Torben Martinussen #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer Verlag (2006). #' @keywords survival #' @examples #' #' ###working on memory leak issue, 3/3-2015 #' ###data(melanoma) #' ###lt<-log(melanoma$thick) # log-thickness #' ###excess<-(melanoma$thick>=210) # excess risk for thick tumors #' ### #' #### Fits Proportional Excess hazards model #' ###fit<-prop.excess(Surv(days/365,status==1)~sex+ulc+cox(sex)+ #' ### cox(ulc)+cox(lt),melanoma,excess=excess,n.sim=100) #' ###summary(fit) #' ###par(mfrow=c(2,3)) #' ###plot(fit) #' #' @export prop.excess<-function(formula=formula(data),data=parent.frame(),excess=1, tol=0.0001,max.time=NULL,n.sim=1000,alpha=1,frac=1) { id<-NULL;detail<-0 robust<-0; call <- match.call() m <- match.call(expand.dots=FALSE) if (n.sim>0 & n.sim<50) {n.sim<-50 ; cat("Minimum 50 simulations\n");} m$detail<-m$excess<-m$alpha<-m$frac<-m$id<-m$tol<-m$max.time<- m$n.sim<-NULL special <- c("cox") Terms <- if(missing(data)) terms(formula, special) else terms(formula, special, data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m, "response") des<-read.design(m,Terms,model="prop.excess") X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ pxz <- px + pz; start.time<-0; clusters<-NULL; survs<-read.surv(m,id,npar,clusters,start.time,max.time,model="prop-exs") times<-survs$times;id<-id.call<-survs$id.cal; clusters<-cluster.call<-survs$clusters; time2<-survs$stop status<-survs$status; ldata<-list(start=survs$start,stop=survs$stop, antpers=survs$antpers,antclust=survs$antclust); if (npar==FALSE) {covar<-cbind(X,Z);} else {stop("Both multiplicative and additive model needed");} Ntimes <- sum(status); times<-c(0,time2[status==1]); times<-sort(times); if (is.null(max.time)==TRUE) maxtimes<-max(times)+0.1 else maxtimes<-max.time; times<-times[timesmaxtimes]<-0 #cat(" Proportional Excess Survival Model "); cat("\n") if (px==0) stop("No Aalen terms (need one!)"); ud<-prop.excessBase(time2,status,X,Z,excess,alpha=1,frac=1,no.sim=n.sim) colnames(ud$cum)<-colnames(ud$var.cum)<- c("time",covnamesX,"Excess baseline") rownames(ud$gamma)<-c(covnamesZ); colnames(ud$gamma)<-"estimate"; namematrix(ud$var.gamma,covnamesZ); #namematrix(ud$robvar.gamma,covnamesZ); #namematrix(ud$D2linv,covnamesZ); attr(ud,"Call")<-call; ud$call<-call class(ud)<-"prop.excess" return(ud); } #' @export "plot.prop.excess" <- function(x, pointwise.ci=1, hw.ci=0,sim.ci=0,specific.comps=FALSE,level=0.95,start.time = 0, stop.time = 0, add.to.plot=FALSE, mains=TRUE, xlab="Time", ylab ="Cumulative regression function",score=FALSE,...) { prop.excess.object <- x; rm(x); # pointwise.ci Pointwise confidence intervals # hw.ci Hall-Wellner confidence bands 95 \% # robust Robust variance used #not included here # specific.comps Plots specific components c(2,3,4), e.g. # signi Significance level signi<-1-level; if (!inherits(prop.excess.object,'prop.excess') ) stop ("Must be output from Proportional Excess Survival Model function") #if (score==TRUE) {cat("Do not plot score processes"); score<-FALSE;} if (score==FALSE) { B<-prop.excess.object$cum; V<-prop.excess.object$var.cum; p<-dim(B)[[2]]; # if (robust==1) V<-prop.excess.object$robvar.cum; if (sum(specific.comps)==FALSE) comp<-2:p else comp<-specific.comps+1 if (stop.time==0) stop.time<-max(B[,1]); med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; V<-V[med,] Bs<-B[1,]; Vs<-V[1,] B<-t(t(B)-Bs); V<-t( t(V)-Vs); B[,1]<-B[,1]+Bs[1] c.alpha<- qnorm(1-signi/2) for (v in comp) { ul<-B[,v]+c.alpha*V[,v]^.5; nl<-B[,v]-c.alpha*V[,v]^.5 est<-B[,v]; if (add.to.plot==FALSE) { plot(B[,1],est,ylim=range(ul,nl),type="s",xlab=xlab,ylab=ylab) if (mains==TRUE) title(main=colnames(B)[v]); } else lines(B[,1],B[,v],type="s"); if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="s"); lines(B[,1],nl,lty=pointwise.ci,type="s"); } #if (robust>=1) { #lines(B[,1],ul,lty=robust,type="s"); #lines(B[,1],nl,lty=robust,type="s"); } if (hw.ci>=1) { if (signi!=0.05) cat("Hall-Wellner band only 95% \n"); tau<-length(B[,1]) nl<-B[,v]-prop.excess.object$quant95HW[v-1]*V[tau,v]^.5*(1+V[,v]/V[tau,v]) ul<-B[,v]+prop.excess.object$quant95HW[v-1]*V[tau,v]^.5*(1+V[,v]/V[tau,v]) lines(B[,1],ul,lty=hw.ci,type="s"); lines(B[,1],nl,lty=hw.ci,type="s"); } if (sim.ci>=1) { if (signi!=0.05) cat("Simulation based band only 95% \n"); V<-prop.excess.object$var.cum; nl<-B[,v]-prop.excess.object$quant95[v-1]*V[,v]^.5; ul<-B[,v]+prop.excess.object$quant95[v-1]*V[,v]^.5; lines(B[,1],ul,lty=sim.ci); lines(B[,1],nl,lty=sim.ci,type="s"); } abline(h=0) } } else { # plot score process dim1<-ncol(prop.excess.object$simScoreProp[[1]]) if (sum(specific.comps)==FALSE) comp<-1:dim1 else comp<-specific.comps for (i in comp) { ranyl<-range(as.matrix(prop.excess.object$simScoreProp[[1]])[,i]); for (j in 2:51) ranyl<-range(c(ranyl, as.matrix(prop.excess.object$simScoreProp[[j]])[,i])); mr<-max(abs(ranyl)); plot(c(0,prop.excess.object$cum[,1]), c(0,as.matrix(prop.excess.object$simScoreProp[[1]])[,i]),type="s", ylim=c(-mr,mr),lwd=2,xlab=xlab,ylab="Scoreprocess") if (mains==TRUE) title(main=rownames(prop.excess.object$gamma)[i]); for (j in 2:51) lines(c(0,prop.excess.object$cum[,1]), c(0,as.matrix(prop.excess.object$simScoreProp[[j]])[,i]), col="grey",lwd=1,lty=1,type="s") lines(c(0,prop.excess.object$cum[,1]), c(0,as.matrix(prop.excess.object$simScoreProp[[1]])[,i]),lwd=2,type="s") } } } #' @export "print.prop.excess" <- function (x,...) { prop.excess.object <- x; rm(x); if (!inherits(prop.excess.object, 'prop.excess')) stop ("Must be a Proportional Excess Survival Model object") if (is.null(prop.excess.object$gamma)==TRUE) cox<-FALSE else cox<-TRUE # We print information about object: cat("Proportional Excess Survival Model \n\n") cat("Additive Aalen terms: "); cat(colnames(prop.excess.object$cum)[-1]); cat(" \n"); if (cox) { cat("Proportional terms: "); cat(rownames(prop.excess.object$gamma)); cat(" \n"); } cat(" \n"); cat(" Call: ") dput(attr(prop.excess.object, "Call")) cat("\n") } #' @export "summary.prop.excess" <- function (object,digits=3,...) { prop.excess.object <- object; rm(object); obj<-prop.excess.object if (!inherits(prop.excess.object, 'prop.excess')) stop ("Must be a Proportional Excess Survival Model object") cox<-TRUE; if (is.null(prop.excess.object$gamma)==TRUE) stop(" No proportional terms"); # We print information about object: cat("Proportional Excess Survival Model \n\n") #if (sum(obj$conf.band)==FALSE) mtest<-FALSE else mtest<-TRUE; #if (mtest==FALSE) cat("Test not computed, sim=0 \n\n") #if (mtest==TRUE) { test0<-cbind(obj$pval.HW,obj$pval.CM) # testC<-cbind(obj$obs.testBeqC,obj$pval.testBeqC) colnames(test0)<- c("KS-test pval", "CM-test pval") rownames(test0)<-colnames(prop.excess.object$cum)[-1] #rownames(test0)<- c("","p-value") #colnames(testC)<- c("sup| B(t) - (t/tau)B(tau)|","p-value H_0: B(t)=b t") cat("Test for non-significant effects \n");cat(" \n"); cat("Test for Aalen terms, H_0: B(t)=0 \n") prmatrix(signif(test0,digits));cat(" \n"); #cat("Test for time invariant effects \n") #prmatrix(signif(testC,digits)) #cat("\n") #} if (cox) { cat("Proportional terms: \n"); res <- cbind(obj$gamma, diag(obj$var.gamma)^.5) #,diag(obj$robvar.gamma)^.5,diag(obj$D2linv)^.5) z<-c((res[,1]/res[,2])) pval<-1-pchisq(z^2,1) res<-as.matrix(cbind(res,z,pval)); colnames(res) <- c("coef", "se(coef)","z","p") #,#Robust Std. Error","D2log(L)^-(1/2)") prmatrix(signif(res, digits)); cat(" \n"); } cat(" Call: ") dput(attr(obj, "Call")) cat("\n") } timereg/R/new.timecox.r0000644000176200001440000003751114421510301014530 0ustar liggesusers #' Fit Cox model with partly timevarying effects. #' #' Fits proportional hazards model with some effects time-varying and some #' effects constant. Time dependent variables and counting process data #' (multiple events per subject) are possible. #' #' Resampling is used for computing p-values for tests of timevarying effects. #' #' The modelling formula uses the standard survival modelling given in the #' \bold{survival} package. #' #' The data for a subject is presented as multiple rows or 'observations', each #' of which applies to an interval of observation (start, stop]. When counting #' process data with the )start,stop] notation is used, the 'id' variable is #' needed to identify the records for each subject. The program assumes that #' there are no ties, and if such are present random noise is added to break #' the ties. #' #' @param formula a formula object with the response on the left of a '~' #' operator, and the independent terms on the right as regressors. The response #' must be a survival object as returned by the `Surv' function. Time-invariant #' regressors are specified by the wrapper const(), and cluster variables (for #' computing robust variances) by the wrapper cluster(). #' @param data a data.frame with the variables. #' @param weights for analysis #' @param subset to subset #' @param na.action to have na.action #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. Default is max of data. #' @param robust to compute robust variances and construct processes for #' resampling. May be set to 0 to save memory. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param clusters cluster variable for computation of robust variances. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing time-varying effects. #' @param residuals to returns residuals that can be used for model validation #' in the function cum.residuals #' @param covariance to compute covariance estimates for nonparametric terms #' rather than just the variances. #' @param Nit number of iterations for score equations. #' @param bandwidth bandwidth for local iterations. Default is 50 \% of the #' range of the considered observation period. #' @param method Method for estimation. This refers to different #' parametrisations of the baseline of the model. Options are "basic" where the #' baseline is written as \eqn{\lambda_0(t) = \exp(\alpha_0(t))} or the #' "breslow" version where the baseline is parametrised as \eqn{\lambda_0(t)}. #' @param degree gives the degree of the local linear smoothing, that is local #' smoothing. Possible values are 1 or 2. #' @return Returns an object of type "timecox". With the following arguments: #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval.} \item{var.cum}{the martingale #' based pointwise variance estimates. } \item{robvar.cum}{robust pointwise #' variances estimates. } \item{gamma}{estimate of parametric components of #' model. } \item{var.gamma}{variance for gamma. } \item{robvar.gamma}{robust #' variance for gamma. } \item{residuals}{list with residuals. Estimated #' martingale increments (dM) and corresponding time vector (time).} #' \item{obs.testBeq0}{observed absolute value of supremum of cumulative #' components scaled with the variance.} \item{pval.testBeq0}{p-value for #' covariate effects based on supremum test.} \item{sim.testBeq0}{resampled #' supremum values.} \item{obs.testBeqC}{observed absolute value of supremum of #' difference between observed cumulative process and estimate under null of #' constant effect.} \item{pval.testBeqC}{p-value based on resampling.} #' \item{sim.testBeqC}{resampled supremum values.} #' \item{obs.testBeqC.is}{observed integrated squared differences between #' observed cumulative and estimate under null of constant effect.} #' \item{pval.testBeqC.is}{p-value based on resampling.} #' \item{sim.testBeqC.is}{resampled supremum values.} #' \item{conf.band}{resampling based constant to construct robust 95\% uniform #' confidence bands. } \item{test.procBeqC}{observed test-process of difference #' between observed cumulative process and estimate under null of constant #' effect over time. } \item{sim.test.procBeqC}{list of 50 random realizations #' of test-processes under null based on resampling.} #' \item{schoenfeld.residuals}{Schoenfeld residuals are returned for "breslow" #' parametrisation.} #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' data(sTRACE) #' # Fits time-varying Cox model #' out<-timecox(Surv(time/365,status==9)~age+sex+diabetes+chf+vf, #' data=sTRACE,max.time=7,n.sim=100) #' #' summary(out) #' par(mfrow=c(2,3)) #' plot(out) #' par(mfrow=c(2,3)) #' plot(out,score=TRUE) #' #' # Fits semi-parametric time-varying Cox model #' out<-timecox(Surv(time/365,status==9)~const(age)+const(sex)+ #' const(diabetes)+chf+vf,data=sTRACE,max.time=7,n.sim=100) #' #' summary(out) #' par(mfrow=c(2,3)) #' plot(out) #' ##' @export timecox<-function(formula=formula(data),data, weights, subset, na.action, start.time=0,max.time=NULL,id=NULL,clusters=NULL, n.sim=1000,residuals=0,robust=1,Nit=20,bandwidth=0.5, method="basic",weighted.test=0,degree=1,covariance=0) { sim2<-0; if (n.sim==0) sim<-0 else sim<-1; if (method!="basic") stop("Only runs the default method at the moment\n"); #if (resample.iid==1 & robust==0) { #cat("When robust=0 no iid representaion computed\n"); #resample.iid<-0;} if (covariance==1 & robust==0) { cat("When robust=0 no covariance computed \n"); cat("covariance set to 0\n"); covariance<-0;} if (sim==1 & robust==0) { cat("When robust=0, No simulations \n"); cat("n.sim set to 0\n"); n.sim<-0;} if (residuals==1 & robust==0) { cat("When robust=0, no martingale residuals \n"); cat("residuals set to 0\n"); residuals<-0;} if (n.sim>0 & n.sim<50) {n.sim<-50 ; cat("Minimum 50 simulations\n");} call <- match.call() # New code indx <- match(c("formula", "data", "weights", "subset", "na.action", "id"), names(call), nomatch=0) if (indx[1] ==0) stop ("a formula argument is required") temp <- call[c(1, indx)] # only keep the arguments we want temp[[1L]] <- quote(stats::model.frame) # change the function called special <- c("const","cluster") temp$formula <- if(missing(data)) terms(formula, special) else terms(formula, special, data=data) m <- eval(temp, parent.frame()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.response(m,) if (!inherits(Y, "Surv")) stop("Response must be a survival object") id <- model.extract(m, "(id)") weights <- model.weights(m) if (!is.null(weights)) stop("timecox does not support case weights") Terms <- terms(m) # end new code des<-read.design(m,Terms) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ if(is.null(clusters)) clusters <- des$clusters if (is.null(Z)==TRUE) XZ<-X else XZ<-cbind(X,Z); if (method=="breslow" && intercept==1) { covnamesX<-covnamesX[-1]; X<-as.matrix(X[,-1]); XZ<-as.matrix(XZ[,-1]); colnames(X)<-covnamesX; px<-px-1;} pxz <- px + pz; survs<-read.surv(m,id,npar,clusters,start.time,max.time,model="timecox") times<-survs$times;id<-id.call<-survs$id.cal; clusters<-cluster.call<-survs$clusters; time2<-survs$stop; time<-survs$start status<-survs$status; Ntimes<-sum(status); ldata<-list(start=survs$start,stop=survs$stop, antpers=survs$antpers,antclust=survs$antclust); times<-c(start.time,time2[status==1]); times<-sort(times); Ntimes <- Ntimes+1; if (is.null(max.time)==TRUE) maxtimes<-max(times)+0.1 else maxtimes<-max.time; times<-times[times0) stop("Delayed entry data not allowed for this function \n"); if (method=="breslow") beta<-coxph(Surv(time,time2,status)~XZ)$coef else if (method=="basic" && intercept==1) beta<-coxph(Surv(time,time2,status)~XZ[,-1])$coef else beta<-coxph(Surv(time,time2,status)~XZ)$coef; beta0<-c(0,0,beta) if (method=="basic" && intercept==0) beta0<-c(0,beta); bhat<-matrix(beta0,length(times),length(beta0),byrow=TRUE); timerange<-range(times); bhat[,1]<-times; if (method=="breslow" || intercept==1) { bhat[,2]<-sum(status)/sum(ldata$stop-ldata$start); if (method=="basic") bhat[,2]<-log(bhat[,2]); } if (npar==TRUE) { #cat("Nonparametric Multiplicative Hazard Model"); cat("\n"); ud<-timecoxBase(times,ldata,X,status,id,bhat, sim=sim,antsim=n.sim,degree=degree,robust=robust, band=bandwidth,it=Nit,method=method,retur=residuals,sim2=sim2, weighted.test=weighted.test,covariance=covariance); if (method=="breslow") covnamesX<-c("Cumulative Baseline",covnamesX); colnames(ud$cum)<-colnames(ud$var.cum)<-c("time",covnamesX) if (robust==1) colnames(ud$robvar.cum)<-c("time",covnamesX) if (sim==1) { #if (method=="breslow") covnamesX<-covnamesX[-1]; colnames(ud$test.procBeqC)<- c("time",covnamesX) names(ud$conf.band)<-names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<- names(ud$pval.testBeqC.is)<- names(ud$obs.testBeqC.is)<- names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<- covnamesX; colnames(ud$sim.testBeq0)<- colnames(ud$sim.testBeqC)<- colnames(ud$sim.testBeqC.is)<- covnamesX; ud$sim.testBeqC.is<-ud$sim.testBeqC<-NULL; if (method=="breslow" && sim2==1) names(ud$pval.testBeqC.is1)<-names(ud$pval.testBeqC.is2)<- names(ud$obs.testBeqC.is1)<-names(ud$obs.testBeqC.is2)<- covnamesX; } } else { #cat("Semiparametric Multiplicative Risk Model"); cat("\n"); if (px==0) { stop("No nonparametric terms (needs one!)"); } if (method=="breslow") { #print(c(px,pxz)); gamma<-bhat[1,(px+3):(pxz+2)]; bhat<-bhat[,1:(px+2)]; } else { gamma<-bhat[1,(px+2):(pxz+1)]; bhat<-bhat[,1:(px+1)] } #print(gamma); print(bhat) #print(X[1:5,]); print(Z[1:5,]); ud<-semicox(times,ldata,X,Z, status,id,bhat,gamma=gamma,sim=sim,antsim=n.sim, band=bandwidth,it=Nit,method=method,retur=residuals,robust=robust, degree=degree,weighted.test=weighted.test,covariance=covariance) if (px>0) { if (method=="breslow") colnames(ud$cum)<- colnames(ud$var.cum)<- c("time","Cumulative Baseline",covnamesX) else colnames(ud$cum)<- colnames(ud$var.cum)<- c("time",covnamesX) if (robust==1) { if (method=="breslow") colnames(ud$robvar.cum)<- c("time","Cumulative Baseline",covnamesX) else colnames(ud$robvar.cum)<-c("time",covnamesX); } if (sim>=1) { if (method=="breslow") name<- c("time","Cumulative Baseline",covnamesX) else name<-c("time",covnamesX) colnames(ud$test.procBeqC)<- name; names(ud$conf.band)<- names(ud$pval.testBeq0)<- names(ud$pval.testBeqC)<- names(ud$pval.testBeqC.is)<- names(ud$obs.testBeqC.is)<- names(ud$obs.testBeq0)<- names(ud$obs.testBeqC)<- colnames(ud$sim.testBeq0)<- colnames(ud$sim.testBeqC.is)<- colnames(ud$sim.testBeqC)<- name[-1]; ud$sim.testBeqC.is<-ud$sim.testBeqC<-NULL; } } rownames(ud$gamma)<-c(covnamesZ); colnames(ud$gamma)<-"estimate"; colnames(ud$var.gamma)<-c(covnamesZ); rownames(ud$var.gamma)<-c(covnamesZ); colnames(ud$robvar.gamma)<-c(covnamesZ); rownames(ud$var.gamma)<-c(covnamesZ); } ud$method<-method attr(ud,"Call")<-call; class(ud)<-"timecox" attr(ud,"Formula")<-formula; attr(ud,"id")<-id.call; attr(ud,"cluster")<-cluster.call; attr(ud,"start.time") <- start.time attr(ud,"start")<- time; attr(ud,"stop")<- time2; attr(ud,"status")<-status; attr(ud,"time2")<-time2; attr(ud,"residuals")<-residuals; attr(ud,"max.time")<-max.time; attr(ud,"stratum")<-0; ud$call<-call return(ud); } ##' @export "plot.timecox" <- function (x,..., pointwise.ci=1, hw.ci=0, sim.ci=0, robust.ci=0, col=NULL, specific.comps=FALSE,level=0.05, start.time = 0, stop.time = 0, add.to.plot=FALSE, mains=TRUE, xlab="Time", ylab ="Cumulative coefficients",score=FALSE) { object <- x; rm(x); if (!inherits(object,'timecox') ) stop ("Must be output from Cox-Aalen function") if (score==FALSE) plot.cums(object, pointwise.ci=pointwise.ci, hw.ci=hw.ci, sim.ci=sim.ci, robust.ci=robust.ci,col=col, specific.comps=specific.comps,level=level, start.time = start.time, stop.time = stop.time, add.to.plot=add.to.plot, mains=mains, xlab=xlab, ylab =ylab) else plotScore(object, specific.comps=specific.comps, mains=mains, xlab=xlab,ylab =ylab); } ##' @export "print.timecox"<- function (x,...) { timecox.object <- x; rm(x); if (!inherits(timecox.object, 'timecox')) stop ("Must be an timecox.object") if (is.null(timecox.object$gamma)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: cat("Multiplicative Hazard Model \n\n") cat(" Nonparametric terms : "); cat(colnames(timecox.object$cum)[-1]); cat(" \n"); if (semi) { cat(" Parametric terms : "); cat(rownames(timecox.object$gamma)); cat(" \n"); } cat(" \n"); cat(" Call: \n") dput(attr(timecox.object, "Call")) cat("\n") } ##' @export "summary.timecox" <- function (object,..., digits = 3) { timecox.object <- object; rm(object); obj<-timecox.object if (!inherits(timecox.object, 'timecox')) stop ("Must be an timecox.object") if (is.null(timecox.object$gamma)==TRUE) semi<-FALSE else semi<-TRUE # We print information about object: cat("Multiplicative Hazard Model \n\n") timetest(obj,digits=digits); if (obj$method=="breslow" && (!semi) && (obj$obs.testBeqC.is1!=FALSE)) { testsupBL<-cbind(obj$obs.testBeqC.is1,obj$pval.testBeqC.is1) testssBL<-cbind(obj$obs.testBeqC.is2,obj$pval.testBeqC.is2) cat("Tests without baseline correction\n") cat("BL(t) = int_0^t lambda_0(t) b(t) dt, L(t) = int_0^t lambda_0(t) dt \n") colnames(testsupBL)<-c("sup| BL(t) - (t/tau)B(tau) L(t)|","p-value H_0: B(t)=b t") colnames(testssBL)<-c("int (BL(t)-(t/tau)B(tau) L(t))^2dt","p-value H_0: B(t)=b t") prmatrix(signif(testsupBL,digits)) prmatrix(signif(testssBL,digits)) } if (semi) { cat("Parametric terms : "); #cat(rownames(timecox.object$gamma)); } cat(" \n"); if (semi) { out=coef.timecox(timecox.object,digits=digits); out=signif(out,digits=digits) print(out) } cat(" \n"); cat(" Call: \n") dput(attr(timecox.object, "Call")) cat("\n") } ##' @export coef.timecox<- function(object,..., digits=3) { coefBase(object,digits=digits) } timereg/R/read-design.r0000644000176200001440000001304514421510301014446 0ustar liggesusersread.design<-function(m,Terms,model="aalen"){ ## {{{ mt <- attr(m, "terms") intercept <- attr(mt, "intercept") XZ<-model.matrix(Terms,m)[, drop = FALSE] clusterTerms<- grep("^cluster[(][A-z0-9._:]*",colnames(XZ),perl=TRUE) if(length(clusterTerms) == 1){ l.cols<-length(attributes(XZ)$assign) - 1 clusters <- as.vector(XZ[,clusterTerms]); cols<-attributes(XZ)$assign cols <- cols[-clusterTerms] } else if(length(clusterTerms) == 0){ l.cols<-length(attributes(XZ)$assign) cols<-attributes(XZ)$assign clusters <- NULL; } else { stop("More than one cluster(-) term was included in the formula") } if (model=="aalen" || model=="comprisk") semicov <- grep("^const[(][A-z0-9._:]*",colnames(XZ),perl=TRUE) if (model=="prop.excess") semicov <- grep("^cox[(][A-z0-9._:]*",colnames(XZ),perl=TRUE) if (model=="cox.aalen") semicov <- grep("^prop[(][A-z0-9._:]*",colnames(XZ),perl=TRUE) ZtermsXZ<-semicov-1 if (length(semicov)) { npar<-FALSE; Zterms<-c(); for (i in ZtermsXZ) Zterms<-c(Zterms,(1:l.cols)[cols==i]); } else { npar<-TRUE; } Zterms<-semicov # ts 25-6-2008 if (length(semicov)>0) { covnamesX <- colnames(XZ)[-c(Zterms,clusterTerms)]; px <- length(covnamesX); X<-matrix(XZ[,-c(Zterms,clusterTerms)],ncol=px); if (px==length(colnames(X))) colnames(X)<-covnamesX; covnamesZ <- colnames(XZ)[Zterms]; pz <- length(covnamesZ); Z<-matrix(XZ[,Zterms],ncol=pz); if (pz==length(colnames(Z))) colnames(Z)<-covnamesX; } else if(length(clusterTerms)>0) { covnamesX <- colnames(XZ)[-clusterTerms] px <- length(covnamesX); X<-matrix(XZ[,-clusterTerms],ncol=px); if (px==length(colnames(X))) colnames(X)<-covnamesX; } else { covnamesX <- colnames(XZ) px <- length(covnamesX); X<-matrix(XZ,ncol=px); if (px==length(colnames(X))) colnames(X)<-covnamesX; } px <- ncol(X) if (npar == FALSE) pz <- ncol(Z) else pz <- 0 pxz <- px + pz X <- data.matrix(X) if (npar == FALSE){ Z <- data.matrix(Z) }else { Z <- NULL; covnamesZ<-NULL } if(length(clusterTerms) > 0){ clusters <- as.vector(clusters) } ud<-list(X=X,Z=Z,px=px,pz=pz,npar=npar, covnamesX=covnamesX,covnamesZ=covnamesZ, clusters=clusters) return(ud) } ## }}} read.surv<-function(m,id,npar,clusters,start.time,max.time,model="aalen",silent=0){ if (attr(m[, 1], "type") == "right") { time2 <- m[, 1][, "time"]; time <- rep(0, length(time2)) status <- m[, 1][, "status"] } else if (attr(m[, 1], "type") == "counting") { ### if ((is.null(id)==TRUE) && (silent==0)) ### cat("For counting process data, with multiple records the id variable must be set to get correct robust standard errors and simulations\n"); time <- m[, 1][, 1];time2 <- m[, 1][, 2];status <- m[, 1][, 3]; } else { stop("only right-censored or counting processes data") } if (sum(duplicated(time2[status==1]))>0) { # cat("Non unique survival times: break ties ! \n") # cat("Break ties yourself\n"); ties<-TRUE; dtimes<-time2[status==1] index<- which(status==1) ties<-duplicated(dtimes); nties<-sum(ties); index<-index[ties] dt<-abs(diff(time2)); dt<-min(dt[dt>0])*0.5; time2[index]<-time2[index]+runif(nties)*dt; } else ties<-FALSE; if ((model=="aalen") & (npar==FALSE)) times<-unique(time2) else times<-time2[status==1]; times <- c(start.time, times[times>start.time]); times <- sort(times) if (is.null(max.time) == TRUE) maxtimes <- max(times) else maxtimes <- max.time times<-times[times<=maxtimes]; if ((npar==FALSE) & (model!="cox.aalen")) times<-c(times,maxtimes) times<-unique(times); Ntimes <- length(times); if (is.null(id) == TRUE) {antpers <- length(time); id <- 0:(antpers - 1);} else {pers <- unique(id); antpers <- length(pers); id <- as.integer(factor(id, labels = 1:(antpers))) - 1; } if (is.null(clusters)== TRUE) {clusters<-id; antclust<-antpers;} else { clus<-unique(clusters); antclust<-length(clus); clusters <- as.integer(factor(clusters, labels = 1:(antclust))) - 1; } ud2<-list(status=status,start=time,stop=time2,antpers=antpers,antclust=antclust, times=times,id.call=id,clusters=clusters,cluster) return(ud2) } check.missing<-function(X,Z,time,time2,status,npar) { XZ<-cbind(X,Z) if ((prod(is.na(XZ) == FALSE) == 0) || (prod(is.na(time) == FALSE) == 0) || (prod(is.na(time2) == FALSE) == 0) || (prod(is.na(status) == FALSE) == 0)) cat("Missing values\n") } rm.missing<-function(X,Z,time,time2,status,npar,na.rm=TRUE) { if (is.null(Z)==TRUE) XZ<-cbind(X,Z) else XZ<-X; if ((prod(is.na(XZ) == FALSE) == 0) || (prod(is.na(time) == FALSE) == 0) || (prod(is.na(time2) == FALSE) == 0) || (prod(is.na(status) == FALSE) == 0)) { if (na.rm) { notmissing <- c(rep(1, times = dimcovar[1])) i <- 1 for (i in 1:dimcovar[1]) { notmissing[i] <- prod(is.na(XZ[i, ]) == FALSE) } notmissing <- notmissing * (is.na(time) == FALSE) * (is.na(time2) == FALSE) * (is.na(status) == FALSE) cat(dimcovar[1] - sum(notmissing), " observations ignored because of missing values\n") dimcovar[1] <- sum(notmissing) XZ<- XZ[notmissing == 1, ] X <- X[notmissing == 1, ] time <- time[notmissing == 1, ] time2 <- time2[notmissing == 1, ] if (npar== FALSE) Z <- Z[notmissing == 1, ] trisk <- trisk[notmissing == 1] status <- status[notmissing == 1] } else { stop("Missing not allowed unless na.rm=TRUE\n\n") } } return(list(X=X,Z=Z,time=time,time2=time2,status=status)) } timereg/R/residualsTimereg.r0000644000176200001440000000420614421510301015573 0ustar liggesusers #' @export residualsTimereg <- function(object,data=data) { ## {{{ ### computes residuals for data based on model given in object if (!inherits(object,c("cox.aalen","aalen"))) stop("Computes residuals for Aalen or Cox.aalen object") else { formula<-attr(object,"Formula"); beta.fixed <- attr(object,"beta.fixed") if (is.null(beta.fixed)) beta.fixed <- 1; model <- class(object); ldata<-aalen.des(formula,data=data,model=model); id <- attr(object,"id"); mclusters <- attr(object,"cluster") X<-ldata$X; time2<-ldata$time2; start<-ldata$time; Z<-ldata$Z; status<-ldata$status; otime2 <- attr(object,"stop"); ostart <- attr(object,"start"); ostatus <- attr(object,"status"); if (!is.null(attr(object,"max.time"))) status <- status*(time2< attr(object,"max.time")); antpers<-nrow(X); if (is.null(Z)==TRUE) {npar<-TRUE; semi<-0;} else { Z<-as.matrix(Z); npar<-FALSE; semi<-1;} if (npar==TRUE) {Z<-matrix(0,antpers,1); pz<-1; fixed<-0;} else {fixed<-1;pz<-ncol(Z);} px<-ncol(X); if (sum(abs(start))>0) lefttrunk <- 1 else lefttrunk <- 0; cumhazleft <- 0; nn <- nrow(object$cum) cum <- Cpred(object$cum,time2)[,-1] cumhaz0 <- apply(cum*X,1,sum) cumhazleft <- rep(0,antpers) RR <- rep(1,antpers); if (inherits(object,"cox.aalen")) { ## {{{ RR <- exp(Z %*% object$gamma); cumhaz <- cumhaz0 * RR; if (lefttrunk==1) { cum <- Cpred(object$cum,start)[,-1] cumhazleft <- apply(cum*X,1,sum) cumhazleft <- cumhazleft * RR; } } ## }}} if (inherits(object,"aalen")) {#{{{ if (npar==FALSE) { ## semi-parametric risk model ex.haz <- (Z %*% object$gamma) ; cumhaz <- cumhaz0+ex.haz*time2 if (lefttrunk==1) { cum <- Cpred(object$cum,start)[,-1] cumhazleft <- apply(cum*X,1,sum) cumhazleft <- cumhazleft+ex.haz*start } } else { ## Aalen model cumhaz <- cumhaz0 if (lefttrunk==1) { cum <- Cpred(object$cum,start)[,-1] cumhazleft <- apply(cum*X,1,sum) if (npar==TRUE) cumhazleft <- cumhazleft } } } #}}} } residuals <- status- cumhaz out <- list(residuals=c(residuals),status=c(status),cumhaz=c(cumhaz),cumhazleft=c(cumhazleft),RR=RR) } ## }}} timereg/R/aalenC.r0000644000176200001440000001251014421510276013456 0ustar liggesusersaalenBaseC <- function(times, fdata, designX, status, id, clusters, robust = 0, sim = 0, retur = 0, antsim = 1000, weighted.test = 1, covariance = 0, resample.iid = 0, namesX = NULL, silent = 0, scale = 1) { ## {{{ Ntimes <- length(times) designX <- as.matrix(designX) if (is.matrix(designX) == TRUE) p <- as.integer(dim(designX)[2]) if (is.matrix(designX) == TRUE) nx <- as.integer(dim(designX)[1]) if (robust == 0 & sim >= 1) robust <- 1 devi <- rep(0, 1) cumint <- matrix(0, Ntimes, p + 1) Vcumint <- cumint if (retur == 1) cumAi <- matrix(0, Ntimes, fdata$antpers) else cumAi <- 0 test <- matrix(0, antsim, 3 * p) testOBS <- rep(0, 3 * p) testval <- c() unifCI <- c() rani <- -round(runif(1) * 10000) if (sim >= 1) simUt <- matrix(0, Ntimes, 50 * p) else simUt <- NULL Ut <- matrix(0, Ntimes, p + 1) if (covariance == 1) covs <- matrix(0, Ntimes, p * p) else covs <- 0 if (resample.iid == 1) { B.iid <- matrix(0, Ntimes, fdata$antclust * p) } else B.iid <- NULL if (robust == 2) { aalenout <- .C("aalen", as.double(times), as.integer(Ntimes), as.double(designX), as.integer(nx), as.integer(p), as.integer(fdata$antpers), as.double(fdata$start), as.double(fdata$stop), as.double(cumint), as.double(Vcumint), as.integer(status), PACKAGE = "timereg") robV <- NULL cumAI <- NULL test <- NULL } else { robVar <- Vcumint aalenout <- .C("robaalenC", as.double(times), as.integer(Ntimes), as.double(designX), as.integer(nx), as.integer(p), as.integer(fdata$antpers), as.double(fdata$start), as.double(fdata$stop), as.double(cumint), as.double(Vcumint), as.double(robVar), as.integer(sim), as.integer(antsim), as.integer(retur), as.double(cumAi), as.double(test), as.integer(rani), as.double(testOBS), as.integer(status), as.double(Ut), as.double(simUt), as.integer(id), as.integer(weighted.test), as.integer(robust), as.integer(covariance), as.double(covs), as.integer(resample.iid), as.double(B.iid), as.integer(clusters), as.integer(fdata$antclust), as.double(devi), as.integer(silent), PACKAGE = "timereg") if (covariance == 1) { covit <- matrix(aalenout[[26]], Ntimes, p * p) cov.list <- list() for (i in 1:Ntimes) cov.list[[i]] <- matrix(covit[i, ], p, p) } else cov.list <- NULL if (resample.iid == 1) { covit <- matrix(aalenout[[28]], Ntimes, fdata$antclust * p) B.iid <- list() for (i in (0:(fdata$antclust - 1)) * p) { B.iid[[i/p + 1]] <- as.matrix(covit[, i + (1:p)]) colnames(B.iid[[i/p + 1]]) <- namesX } } robV <- matrix(aalenout[[11]], Ntimes, p + 1) if (retur == 1) { cumAi <- matrix(aalenout[[15]], Ntimes, fdata$antpers * 1) cumAi <- list(time = times, dM = cumAi, dM.iid = cumAi) } else cumAi <- NULL } if (sim >= 1) { Uit <- matrix(aalenout[[21]], Ntimes, 50 * p) UIt <- list() for (i in (0:49) * p) UIt[[i/p + 1]] <- as.matrix(Uit[, i + (1:p)]) Ut <- matrix(aalenout[[20]], Ntimes, (p + 1)) test <- matrix(aalenout[[16]], antsim, 3 * p) testOBS <- aalenout[[18]] for (i in 1:(3 * p)) testval <- c(testval, pval(test[, i], testOBS[i])) for (i in 1:p) unifCI <- as.vector(c(unifCI, percen(test[, i], 0.95))) pval.testBeq0 <- as.vector(testval[1:p]) pval.testBeqC <- as.vector(testval[(p + 1):(2 * p)]) pval.testBeqC.is <- as.vector(testval[(2 * p + 1):(3 * p)]) obs.testBeq0 <- as.vector(testOBS[1:p]) obs.testBeqC <- as.vector(testOBS[(p + 1):(2 * p)]) obs.testBeqC.is <- as.vector(testOBS[(2 * p + 1):(3 * p)]) sim.testBeq0 <- as.matrix(test[, 1:p]) sim.testBeqC <- as.matrix(test[, (p + 1):(2 * p)]) sim.testBeqC.is <- as.matrix(test[, (2 * p + 1):(3 * p)]) } else { test <- NULL unifCI <- NULL Ut <- NULL UIt <- NULL pval.testBeq0 <- NULL pval.testBeqC <- NULL obs.testBeq0 <- NULL obs.testBeqC <- NULL sim.testBeq0 <- NULL sim.testBeqC <- NULL sim.testBeqC.is <- NULL pval.testBeqC.is <- NULL obs.testBeqC.is <- NULL } cumint <- matrix(aalenout[[9]], Ntimes, p + 1) Vcumint <- matrix(aalenout[[10]], Ntimes, p + 1) devi <- aalenout[[31]] list(cum = cumint, var.cum = Vcumint, robvar.cum = robV, residuals = cumAi, pval.testBeq0 = pval.testBeq0, obs.testBeq0 = obs.testBeq0, pval.testBeqC = pval.testBeqC, pval.testBeqC.is = pval.testBeqC.is, obs.testBeqC = obs.testBeqC, obs.testBeqC.is = obs.testBeqC.is, sim.testBeq0 = sim.testBeq0, sim.testBeqC = sim.testBeqC, sim.testBeqC.is = sim.testBeqC.is, conf.band = unifCI, test.procBeqC = Ut, sim.test.procBeqC = UIt, covariance = cov.list, B.iid = B.iid, deviance = devi) } ## }}} timereg/R/glm-comprisk.r0000644000176200001440000000070514421510276014702 0ustar liggesusers #' @export prep.glm.comprisk <- function(out,time="time",cause="cause",times,censmod=0,cens.code=0,type=1) { ## {{{ ### out$id <- 1:nrow(out) mm <- c() for (h in times) { i2out <- prep.comp.risk(out,time=time,cause=cause,times=h,cens.code=cens.code) Nt <- (i2out[,time] < h)*(i2out[,cause]==type) nocens <- (i2out[,time] < h) mm <- rbind(mm,cbind(i2out,Nt,h,nocens)) } return(mm) } ## }}} timereg/R/recurrent.r0000644000176200001440000001304114421510301014271 0ustar liggesusers#' Estimates marginal mean of recurrent events #' #' Fitting two aalen models for death and recurent events these are #' combined to prducte the estimator #' \deqn{ \int_0^t S(u) dR(u) } the mean number of recurrent events, here #' \deqn{ S(u) } is the probability of survival, and #' \deqn{ dR(u) } is the probability of an event among survivors. #' #' IID versions used for Ghosh & Lin (2000) variance. See also mets package for #' quick version of this for large data mets:::recurrent.marginal, these two #' version should give the same when there are no ties. #' #' @param recurrent aalen model for recurrent events #' @param death aalen model for recurrent events #' @author Thomas Scheike #' @references #' Ghosh and Lin (2002) Nonparametric Analysis of Recurrent events and death, #' Biometrics, 554--562. #' @keywords survival #' @examples #' \donttest{ #' ### get some data using mets simulaitons, and avoid dependency, see mets #' # library(mets) #' # data(base1cumhaz) #' # data(base4cumhaz) #' # data(drcumhaz) #' # dr <- drcumhaz #' # base1 <- base1cumhaz #' # base4 <- base4cumhaz #' # rr <- simRecurrent(100,base1,death.cumhaz=dr) #' # rr$x <- rnorm(nrow(rr)) #' # rr$strata <- floor((rr$id-0.01)/50) #' # drename(rr) <- start+stop~entry+time #' # #' # ar <- aalen(Surv(start,stop,status)~+1+cluster(id),data=rr,resample.iid=1 #' # ,max.clust=NULL) #' # ad <- aalen(Surv(start,stop,death)~+1+cluster(id),data=rr,resample.iid=1, #' # ,max.clust=NULL) #' # mm <- recurrent.marginal.mean(ar,ad) #' # with(mm,plot(times,mu,type="s")) #' # with(mm,lines(times,mu+1.96*se.mu,type="s",lty=2)) #' # with(mm,lines(times,mu-1.96*se.mu,type="s",lty=2)) #' } ##' @export recurrent.marginal.mean <- function(recurrent,death) {# {{{ axr <- recurrent adr <- death St <- exp(-adr$cum[,2]) ### construct iid at same time points , combined jump-points timesr <- axr$cum[,1] timesd <- adr$cum[,1] times <- c(timesr[-1],timesd[-1]) or <- order(times) times <- times[or] keepr <- order(or)[1:length(timesr[-1])] rid <- sindex.prodlim(timesd,times,strict=FALSE) rir <- sindex.prodlim(timesr,times,strict=FALSE) Stt <- St[rid] ### ariid <- axr$cum[rir,2] mu <- cumsum(Stt*diff(c(0,ariid))) nc <- length(axr$B.iid) muiid <- matrix(0,length(times),nc) ### muiid1 <- matrix(0,length(times),nc) ### muiid2 <- matrix(0,length(times),nc) ### muiid3 <- matrix(0,length(times),nc) for (i in 1:nc) { mriid <- axr$B.iid[[i]] mdiid <- adr$B.iid[[i]] mriid <- mriid[rir] mdiid <- mdiid[rid] dmridd <- diff(c(0,mriid)) dmdidd <- diff(c(0,mdiid)) muiid[,i] <- cumsum(Stt*dmridd)-mu*cumsum(dmdidd)+cumsum(mu*dmdidd) ### muiid1[,i] <- cumsum(Stt*dmridd) ### muiid2[,i] <- -mu*cumsum(dmdidd) ### muiid3[,i] <- cumsum(mu*dmdidd) } var1 <- apply(muiid^2,1,sum) ### varl1 <- apply(muiid1^2,1,sum) ### varl2 <- apply(muiid2^2,1,sum) ### varl3 <- apply(muiid3^2,1,sum) ###### ### cov12 <- apply(muiid1*muiid2,1,sum) ### cov13 <- apply(muiid1*muiid3,1,sum) ### cov23 <- apply(muiid2*muiid3,1,sum) out=list(times=times[keepr],mu=mu[keepr],var.mu=var1[keepr],se.mu=var1[keepr]^.5, St=St,Stt=Stt[keepr]) ### covs=cbind(cov12,cov13,cov23)[keepr,], ### vari=cbind(varl1,varl2,varl3)[keepr,]) }# }}} #' Estimates marginal mean of recurrent events based on two cox models #' #' Fitting two Cox models for death and recurent events these are #' combined to prducte the estimator #' \deqn{ \int_0^t S(u|x=0) dR(u|x=0) }{} the mean number of recurrent events, here #' \deqn{ S(u|x=0) }{} is the probability of survival, and #' \deqn{ dR(u|x=0) }{} is the probability of an event among survivors. #' For now the estimator is based on the two-baselines so \deqn{x=0}{}, but covariates #' can be rescaled to look at different x's and extensions possible. #' #' IID versions along the lines of Ghosh & Lin (2000) variance. See also mets package for #' quick version of this for large data. #' IID versions used for Ghosh & Lin (2000) variance. See also mets package for #' quick version of this for large data mets:::recurrent.marginal, these two #' version should give the same when there are now ties. #' #' @param recurrent aalen model for recurrent events #' @param death cox.aalen (cox) model for death events #' @author Thomas Scheike #' @references #' Ghosh and Lin (2002) Nonparametric Analysis of Recurrent events and death, #' Biometrics, 554--562. #' @keywords survival #' @examples #' \donttest{ #' ### do not test because iid slow and uses data from mets #' library(mets) #' data(base1cumhaz) #' data(base4cumhaz) #' data(drcumhaz) #' dr <- drcumhaz #' base1 <- base1cumhaz #' base4 <- base4cumhaz #' rr <- simRecurrent(100,base1,death.cumhaz=dr) #' rr$x <- rnorm(nrow(rr)) #' rr$strata <- floor((rr$id-0.01)/50) #' drename(rr) <- start+stop~entry+time #' #' ar <- cox.aalen(Surv(start,stop,status)~+1+prop(x)+cluster(id),data=rr, #' resample.iid=1,,max.clust=NULL,max.timepoint.sim=NULL) #' ad <- cox.aalen(Surv(start,stop,death)~+1+prop(x)+cluster(id),data=rr, #' resample.iid=1,,max.clust=NULL,max.timepoint.sim=NULL) #' mm <- recurrent.marginal.coxmean(ar,ad) #' with(mm,plot(times,mu,type="s")) #' with(mm,lines(times,mu+1.96*se.mu,type="s",lty=2)) #' with(mm,lines(times,mu-1.96*se.mu,type="s",lty=2)) #' } ##' @export recurrent.marginal.coxmean <- function(recurrent,death) {# {{{ out <- recurrent.marginal.mean(recurrent,death) return(out) }# }}} timereg/R/aalen-des.r0000644000176200001440000000421214421510301014111 0ustar liggesusersdes.aalen<-function (formula = formula(data), data = parent.frame(), start.time = 0, max.time = NULL, id=NULL, clusters=NULL, deltaweight=1,approx="dt") { m <- match.call(expand.dots = FALSE) m$start.time <- m$max.time <-m$id <- m$clusters <- m$deltaweight<-m$approx<-NULL special <- c("const","cluster") Terms <- if (missing(data)) terms(formula, special) else terms(formula, special, data = data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, parent.frame()) mt <- attr(m, "terms") intercept <- attr(mt, "intercept") Y <- model.extract(m, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") des<-read.design(m,Terms) X<-des$X; Z<-des$Z; npar<-des$npar; px<-des$px; pz<-des$pz; covnamesX<-des$covnamesX; covnamesZ<-des$covnamesZ if(is.null(clusters)) clusters <- des$clusters pxz <- px + pz; if (approx=="death-times" & des$npar==FALSE) npar<-TRUE; survs<-read.surv(m,id,npar,clusters,start.time,max.time) times<-survs$times;id<-id.call<-survs$id.cal; if (approx=="death-times" & des$npar==FALSE) npar<-FALSE; id<-id.call<-survs$id; clusters<-cluster.call<-survs$clusters; time2 <- survs$stop; status <- survs$status; start = survs$start; stop = survs$stop; antpers = survs$antpers; antclust = survs$antclust; Ntimes<-length(times) NDtimes<-sum(status[(stop>times[1]) & (stop<=times[Ntimes])])+1; ng=nx=antpers; if (pz==0) Z=0; desret<-matrix(0,antpers*(Ntimes-1),(pz+4)); semiout<-.C("aalendesL", as.double(times),as.integer(Ntimes),as.integer(NDtimes), as.double(X),as.integer(nx),as.integer(px), as.double(Z),as.integer(ng),as.integer(pz), as.integer(antpers),as.double(start),as.double(stop), as.integer(status),as.integer(id),as.integer(clusters), as.integer(antclust),as.integer(deltaweight),as.double(desret), PACKAGE="timereg") desret<-matrix(semiout[[18]],antpers*(Ntimes-1),pz+4) ud<-apply(desret[,1:pz],1,sum)!=0 desret<-desret[ud,] colnames(desret)<-c(covnamesZ,"Y","dtime","id","time") return(data.frame(desret)) } timereg/R/cox.ipw.r0000644000176200001440000001065314421510301013655 0ustar liggesusers#' Missing data IPW Cox #' #' Fits an Cox-Aalen survival model with missing data, with glm specification #' of probability of missingness. #' #' Taylor expansion of Cox's partial likelihood in direction of glm parameters #' using num-deriv and iid expansion of Cox and glm paramters (lava). #' #' @aliases cox.ipw summary.cox.ipw print.cox.ipw coef.cox.ipw #' @param survformula a formula object with the response on the left of a '~' #' operator, and the independent terms on the right as regressors. The response #' must be a survival object as returned by the `Surv' function. #' #' Adds the prop() wrapper internally for using cox.aalen function for fitting #' Cox model. #' @param glmformula formula for "being" observed, that is not missing. #' @param d data frame. #' @param max.clust number of clusters in iid approximation. Default is all. #' @param ipw.se if TRUE computes standard errors based on iid decompositon of #' cox and glm model, thus should be asymptotically correct. #' @param tie.seed if there are ties these are broken, and to get same break #' the seed must be the same. Recommend to break them prior to entering the #' program. #' @return returns an object of type "cox.aalen". With the following arguments: #' \item{iid}{iid decomposition.} \item{coef}{missing data estiamtes for #' weighted cox. } \item{var}{robust pointwise variances estimates. } #' \item{se}{robust pointwise variances estimates. } \item{se.naive}{estimate #' of parametric components of model. } \item{ties}{list of ties and times #' with random noise to break ties.} \item{cox}{output from weighted cox #' model.} #' @author Thomas Scheike #' @references Paik et al. #' @keywords survival #' @examples #' #' #' ### fit <- cox.ipw(Surv(time,status)~X+Z,obs~Z+X+time+status,data=d,ipw.se=TRUE) #' ### summary(fit) #' #' ##' @export cox.ipw <- function(survformula,glmformula,d=parent.frame(),max.clust=NULL,ipw.se=FALSE,tie.seed=100) { ## {{{ ggl <- glm(glmformula,family='binomial',data=d) mat <- model.matrix(glmformula,data=d); glmcovs <- attr(ggl$terms,"term.labels") d$ppp <- predict(ggl,type='response') ### d1 <- d[,survcovs] ### dcc <- na.omit(d) ## {{{ checking and breaking ties ties <- FALSE survtimes <- all.vars(update(survformula,.~0)) if (length(survtimes)==2) {itime <- 1; time2 <- d[,survtimes[1]]; status <- d[,survtimes[2]]; } if (length(survtimes)==3) {itime <- 2; time2 <- d[,survtimes[2]]; status <- d[,survtimes[3]]; } jtimes <- time2[status==1]; dupli <- duplicated(jtimes) if (sum(dupli)>0) { set.seed(tie.seed) jtimes[dupli] <- jtimes[dupli]+runif(sum(dupli))*0.01 time2[status==1] <- jtimes d[,survtimes[itime]] <- time2 ties <- TRUE } ## }}} dcc <- d[ggl$y==1,] ppp <- dcc$ppp timeregsurvformula <- timereg.formula(survformula) udca <- cox.aalen(timeregsurvformula,data=dcc,weights=1/ppp,n.sim=0,max.clust=max.clust) ### iid of beta for Cox model coxiid <- udca$gamma.iid if (ipw.se==TRUE) { ## {{{ ###requireNamespace("lava"); requireNamespace("NumDeriv"); glmiid <- lava::iid(ggl) mat <- mat[ggl$y==1,] par <- coef(ggl) coxalpha <- function(par) { ## {{{ rr <- mat %*% par pw <- c(exp(rr)/(1+exp(rr))) assign("pw",pw,envir=environment(survformula)) ### if (coxph==FALSE) ud <- cox.aalen(timeregsurvformula,data=dcc,weights=1/pw,beta=udca$gamma,Nit=1,n.sim=0,robust=0) ### else { ud <- coxph(survformula,data=dcc,weights=1/pw,iter.max=1,init=udca$gamma) ### ud <- coxph.detail(ud,data=dcc) ### } ud$score } ## }}} DU <- numDeriv::jacobian(coxalpha,par,) IDU <- udca$D2linv %*% DU alphaiid <-t( IDU %*% t(glmiid)) ### iidfull <- alphaiid ### iidfull[ggl$y==1,] <- coxiid + alphaiid[ggl$y==1,] ### var2 <- t(iidfull) %*% iidfull se <- cbind(diag(var2)^.5); colnames(se) <- "se" } else { iidfull <- NULL; var2 <- NULL; se <- NULL} ## }}} se.naive=coef(udca)[,3,drop=FALSE]; colnames(se.naive) <- "se.naive" res <- list(iid=iidfull,coef=udca$gamma,var=var2,se=se,se.naive=se.naive,ties=list(ties=ties,time2=time2,cox=udca)) class(res) <- "cox.ipw" return(res) } ## }}} ##' @export summary.cox.ipw <- function(object,digits=3,...) { tval <- object$coef/object$se pval <- 2*(1-pnorm(abs(tval))) res <- cbind(object$coef,object$se,object$se.naive,pval) colnames(res) <- c("coef","se","se.naive","pval") return(res) } ##' @export coef.cox.ipw<- function(object,digits=3,...) { summary.cox.ipw(object) } ##' @export print.cox.ipw <- function(x,...) { summary.cox.ipw(x) } timereg/R/mgresid.r0000644000176200001440000006135214421510301013722 0ustar liggesusers#' Model validation based on cumulative residuals #' #' Computes cumulative residuals and approximative p-values based on resampling #' techniques. #' #' #' @param object an object of class 'aalen', 'timecox', 'cox.aalen' where the #' residuals are returned ('residuals=1') #' @param data data frame based on which residuals are computed. #' @param modelmatrix specifies a grouping of the data that is used for #' cumulating residuals. Must have same size as data and be ordered in the same #' way. #' @param n.sim number of simulations in resampling. #' @param weighted.test to compute a variance weighted version of the #' test-processes used for testing constant effects of covariates. #' @param cum.resid to compute residuals versus each of the continuous #' covariates in the model. #' @param max.point.func limits the amount of computations, only considers a #' max of 50 points on the covariate scales. #' @param weights weights for sum of martingale residuals, now for cum.resid=1. #' @return returns an object of type "cum.residuals" with the following #' arguments: \item{cum}{cumulative residuals versus time for the groups #' specified by modelmatrix. } \item{var.cum}{the martingale based pointwise #' variance estimates.} \item{robvar.cum}{robust pointwise variances estimates #' of cumulatives.} \item{obs.testBeq0}{observed absolute value of supremum of #' cumulative components scaled with the variance.} #' \item{pval.testBeq0}{p-value covariate effects based on supremum test.} #' \item{sim.testBeq0}{resampled supremum value.} \item{conf.band}{resampling #' based constant to construct robust 95\% uniform confidence bands for #' cumulative residuals.} \item{obs.test}{absolute value of supremum of #' observed test-process.} \item{pval.test}{p-value for supremum test #' statistic.} \item{sim.test}{resampled absolute value of supremum cumulative #' residuals.} \item{proc.cumz}{observed cumulative residuals versus all #' continuous covariates of model.} \item{sim.test.proccumz}{list of 50 random #' realizations of test-processes under model for all continuous covariates.} #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' data(sTRACE) #' # Fits Aalen model and returns residuals #' fit<-aalen(Surv(time,status==9)~age+sex+diabetes+chf+vf, #' data=sTRACE,max.time=7,n.sim=0,residuals=1) #' #' # constructs and simulates cumulative residuals versus age groups #' fit.mg<-cum.residuals(fit,data=sTRACE,n.sim=100, #' modelmatrix=model.matrix(~-1+factor(cut(age,4)),sTRACE)) #' #' par(mfrow=c(1,4)) #' # cumulative residuals with confidence intervals #' plot(fit.mg); #' # cumulative residuals versus processes under model #' plot(fit.mg,score=1); #' summary(fit.mg) #' #' # cumulative residuals vs. covariates Lin, Wei, Ying style #' fit.mg<-cum.residuals(fit,data=sTRACE,cum.resid=1,n.sim=100) #' #' par(mfrow=c(2,4)) #' plot(fit.mg,score=2) #' summary(fit.mg) #' #' @export cum.residuals<-function(object,data=parent.frame(),modelmatrix=0,cum.resid=1,n.sim=500, weighted.test=0,max.point.func=50,weights=NULL) { ## {{{ ## {{{ setting up start.design<-1; silent <- 1; offsets <- NULL; if (!inherits(object,c("aalen","timecox","cox.aalen" ))) stop ("Must be output from aalen() timecox() or cox.aalen() functions\n") if (inherits(object,"timecox")) if (object$method!="basic") stop("Residuals available only for method=basic\n") if (inherits(object,"timecox")) if (is.null(object$gamma)==FALSE) stop("Residuals available only for timecox model with no const terms\n") if (inherits(object,"aalen")) if (is.null(object$gamma)==FALSE) stop("Residuals available only for Aalen model with no const terms\n") if (is.null(object$residuals$dM)==TRUE) stop("Residuals not computed, add option residuals=1\n"); if (sum(modelmatrix)==0 && cum.resid==0) stop("No modelmatrix or continous covariates given to cumulate residuals\n"); stratum <- attr(object,"stratum"); rate.sim <- 1; weights1 <- NULL if (inherits(object,"cox.aalen")) { dcum<-apply(as.matrix(object$cum[,-1]),2,diff); beta<-object$gamma; coxaalen<-1; weights1 <- attr(object,"weights") offsets <- attr(object,"offsets"); rate.sim <- attr(object,"rate.sim"); } else { dcum<-0; beta<-0; coxaalen<-0; pg<-0;Z<-0; } id<-attr(object,"id"); cluster<-attr(object,"cluster"); formula<-attr(object,"Formula"); start.time<-attr(object,"start.time"); pers<-unique(id); antpers<-length(pers); clust<-unique(cluster); antclust<-length(clust); if (inherits(object,"cox.aalen")) ldata<-aalen.des(formula,data,model="cox.aalen") else ldata<-aalen.des(formula,data) X<-ldata$X; covar<-X; px<-ldata$px; time<-attr(object,"start"); time2<-attr(object,"stop"); if (sum(time)==0) type <- "right" else type <- "counting" status<-attr(object,"status"); if (is.null(weights)) weights <- rep(1,nrow(X)); if (is.null(weights1)) weights1 <- rep(1,nrow(X)); if (is.null(offsets)) offsets <- rep(0,nrow(X)); if (length(weights)!=nrow(X)) stop("Lengths of weights and data do not match\n"); if (length(weights1)!=nrow(X)) stop("Lengths of weights from aalen/cox.aalen and data do not match\n"); if (coxaalen==1) { Z<-ldata$Z; covnamesZ<-ldata$covnamesZ; pg<-ncol(Z); } else Z <- 0 Ntimes <- sum(status); if (sum(modelmatrix)==0) {modelmatrix<-0;model<-0;pm<-1;} else {model<-1; modelmatrix<-as.matrix(modelmatrix); pm<-ncol(modelmatrix); test<-matrix(0,n.sim,3*pm); testOBS<-rep(0,2*pm); covnames<-colnames(modelmatrix); } ### print(id); print(cluster) times<-c(start.time,time2[status==1]); times<-sort(times); antpers=length(unique(id)); ntot<-nrow(X); lmgresids<-length(object$residuals$time); ###if ( type == "right" ) { ## {{{ ot<-order(-time2,status==1); # order in time, status=0 first for ties time2<-time2[ot]; status<-status[ot]; X<-as.matrix(X[ot,]) if (coxaalen==1) Z<-as.matrix(Z[ot,]) if (model==1) modelmatrix<-as.matrix(modelmatrix[ot,]) start <- time[ot] ### fra call stop<-time2; ### fra call cluster<-cluster[ot] id<-id[ot]; weightsmg <- weights[ot] weights <- weights1[ot] offsets <- offsets[ot] entry=rep(-1,ntot); ### } else { ### eventtms <- c(time,time2) ### status <- c(rep(0, ntot), status) ### ix <- order(-eventtms,status==1) ### etimes <- eventtms[ix] # Entry/exit times ### status <- status[ix] ### stop <- etimes; ### start <- c(time,time)[ix]; ### tdiff <- c(-diff(etimes),start.time) # Event time differences ### entry <- c(rep(c(1, -1), each = ntot))[ix] ### X <- as.matrix(X[rep(1:ntot, 2)[ix],]) ### if (coxaalen==1) Z <- as.matrix(Z[rep(1:ntot,2)[ix],]) ### if (model==1) modelmatrix<-as.matrix(modelmatrix[rep(1:ntot,2)[ix],]) ### id <- rep(id,2)[ix] ### cluster <- rep(cluster,2)[ix] ### weights <- rep(weights, 2)[ix] ### offsets <- rep(offsets,2)[ix] ### } ## }}} ntot <- nrow(X); if (coxaalen==1) { gamma.iid<-object$gamma.iid covar<-cbind(X,Z); cnames<- c(ldata$covnamesX,ldata$covnamesZ) if (ncol(covar)==length(cnames)) colnames(covar)<-cnames ptot<-px+pg; } else { covar<-covar; ptot<-px; gamma.iid<-0; } covnames0<-colnames(covar); if (is.null(covnames0)) covnames0 <- rep("",ptot); antal<-0; maxval<-0; intercept<-0; antal2<-0; maxval2<-0; xvals<-list(); ant<-rep(0,ptot); for (i in 1:ptot) xvals[[i]]<-c(); rani<-round(runif(1)*10000); keepcumz<-c(); k<-0 for (j in 1:ptot) { z<-unique(covar[,j]); z<-sort(z); if (length(z)> max.point.func) z <- quantile(z,probs=seq(0,1,length=max.point.func)) antal<-antal+1; ant[j]<-length(z); if (ant[j]>2) { k<-k+1; keepcumz<-c(keepcumz,j); xvals[[k]]<-z; maxval<-max(maxval,length(z)); } } if (sum(keepcumz)==0 && cum.resid==1) stop(" No continous covariates given to cumulate residuals \n"); pcumz<-length(keepcumz); uni.test<-matrix(0,n.sim,pcumz); univar.proc<-matrix(0,maxval,pcumz); robvarcumz<-matrix(0,maxval,pcumz); sim.univar.proc<-matrix(0,maxval,50*pcumz); time.proc<-matrix(0,lmgresids,2); sim.time.proc<-matrix(0,lmgresids,50); simcumz<-matrix(0,n.sim,pcumz); xval<-matrix(0,maxval,pcumz); k<-1; for (i in keepcumz) {xval[1:ant[i],k]<-xvals[[k]]; k<-k+1;} # testOBS size and location of supremum, test simulated sup's unitime.test<-time.test<-mult.test<-multtime.test<- matrix(0,n.sim,2*pcumz); unitime.testOBS<-uni.testOBS<-time.testOBS<-mult.testOBS<- multtime.testOBS<-rep(0,pcumz); inXorZ<-rep(0,pcumz); if (pcumz>0) { antX<-(sum(ant[1:px]>2)) if (antX>0) {inX<-(1:px)[(ant[1:px]>2)]; inXorZ[1:antX]<-1} else {inX<-c();} if (coxaalen==1) {inZ<-(1:pg)[(ant[(px+1):(px+pg)]>2)]; } else inZ<-c() inXZ<-c(inX,inZ); inXZ<-inXZ-1 } else {inXZ<-0; inXorZ<-0} ant<-ant[keepcumz]; Ut<- cummgt<- robvarcum <- matrix(0,lmgresids,pm+1); simUt<-matrix(0,lmgresids,pm*50); test<-matrix(0,n.sim,3*pm); testOBS <- rep(0,3*pm); ## }}} ###dyn.load("mgresid.so"); dNit <- 0 if (coxaalen==1) dNit <- object$residuals$dNit mgout<- .C("mgresid", ## {{{ as.double(X),as.integer(ntot),as.integer(px), as.integer(antpers),as.double(start),as.double(stop), as.integer(status),as.integer(id),as.double(object$residuals$time), as.integer(lmgresids),as.double(object$residuals$dM),as.integer(n.sim), as.double(xval), as.integer(ant), as.double(univar.proc), as.double(time.proc),as.double(sim.univar.proc), as.double(sim.time.proc), as.double(uni.test),as.double(uni.testOBS), as.double(time.test), as.double(time.testOBS),as.double(unitime.test), as.double(unitime.testOBS), as.double(modelmatrix),as.integer(model), as.integer(pm), as.double(cummgt),as.double(dNit), as.double(robvarcum), # 10 as.double(testOBS),as.double(test), as.double(simUt), as.double(Ut),as.integer(cum.resid), as.integer(maxval), as.integer(start.design),as.integer(coxaalen), as.double(dcum), as.double(beta),as.double(Z), as.integer(pg), as.double(gamma.iid),as.integer(cluster), as.integer(antclust), as.double(robvarcumz), as.double(simcumz), as.integer(inXZ), as.integer(inXorZ),as.integer(pcumz), as.integer(entry), as.integer(stratum),as.integer(silent),as.double(weights1), as.double(offsets),as.integer(rate.sim),as.double(weights), as.integer(weighted.test)) ### , PACKAGE="timereg") ## }}} ## {{{ handling output from C if (model==1) { cum<-matrix(mgout[[28]],lmgresids,pm+1); robvar.cum<-matrix(mgout[[30]],lmgresids,pm+1); var.cum<-robvar.cum; Ut<-matrix(mgout[[34]],lmgresids,pm+1); colnames(Ut)<-colnames(cum)<-colnames(var.cum)<- colnames(robvar.cum)<- c("time",covnames) test.procBeq0<-Ut; simUt<-matrix(mgout[[33]],lmgresids,50*pm); UIt<-list(); for (i in (0:49)*pm) { UIt[[i/pm+1]]<-as.matrix(simUt[,i+(1:pm)]); } testOBS<-mgout[[31]]; test<-matrix(mgout[[32]],n.sim,3*pm); testval<-c(); unifCI<-c(); for (i in 1:(2*pm)) testval<-c(testval,pval(test[,i],testOBS[i])) for (i in 1:pm) unifCI<-as.vector(c(unifCI,percen(test[,2*pm+i],0.95))); obs.testBeq0<-as.vector(testOBS[1:pm]); obs.testBeq0.is<-as.vector(testOBS[(pm+1):(2*pm)]); pval.testBeq0<-as.vector(testval[1:pm]); pval.testBeq0.is<-as.vector(testval[(pm+1):(2*pm)]); sim.testBeq0<-test[,(2*pm+1):(3*pm)]; sim.test.procBeq0<-UIt; names(unifCI)<- names(pval.testBeq0)<- names(obs.testBeq0)<- names(pval.testBeq0.is)<- names(obs.testBeq0.is)<- covnames } else { cum<-robvar.cum<-test<-unifCI<-Ut<-UIt<-pval.testBeq0<- pval.testBeq0.is<-obs.testBeq0<-obs.testBeq0.is<-sim.testBeq0<-NULL; } if (cum.resid>=1) { univar.p<-matrix(mgout[[15]],maxval,pcumz) robvarcumz<-matrix(mgout[[46]],maxval,pcumz) simcumz<-matrix(mgout[[47]],n.sim,pcumz) univar.proc<-list(); for (i in 1:pcumz) { univar.proc[[i]]<-cbind(xvals[[i]],univar.p[1:ant[i],i]); colnames(univar.proc[[i]])<-c(covnames0[keepcumz[i]],"cum. martingale residual"); } Uiz<-matrix(mgout[[17]],maxval,50*pcumz); UIz<-list(); k<-1; for (i in 1:pcumz) { UIz[[i]]<-matrix(Uiz[1:ant[i],i+(0:49)*pcumz],ncol=50); k<-k+1;} uni.test<-matrix(mgout[[19]],n.sim,pcumz) uni.test<-as.matrix(uni.test); uni.testOBS<-mgout[[24]][1:pcumz]; testval<-c(); for (i in 1:pcumz) testval<-c(testval,pval(uni.test[,i],uni.testOBS[i])) unifCIz<-c() for (i in 1:pcumz) unifCIz<-c(unifCIz,percen(simcumz[,i],0.95)) uni.pval<-testval names(uni.testOBS)<-names(uni.pval)<-colnames(uni.test)<-covnames0[keepcumz]; #uni.testOBS<-uni.testOBS[keepcumz]; uni.pval<-uni.pval[keepcumz] #uni.test<-uni.test[,keepcumz]; } else { unifCIz<-uni.testOBS<-uni.pval<-proc.cumz<-UIz<- unitime.pval<-unitime.testOBS<-NULL;} ## }}} ud<-list(cum=cum,robvar.cum=robvar.cum,robvar.cumz=robvarcumz, pval.testBeq0=pval.testBeq0, obs.testBeq0=obs.testBeq0, pval.testBeq0.is=pval.testBeq0.is, obs.testBeq0.is=obs.testBeq0.is, sim.testBeq0=sim.testBeq0, procBeq0=Ut,sim.test.procBeq0=UIt, conf.band=unifCI, conf.band.cumz=unifCIz, obs.test=uni.testOBS,pval.test=uni.pval, sim.test=uni.test, proc.cumz=univar.proc,sim.test.proccumz=UIz) attr(ud,"Call")<-call; class(ud)<-"cum.residuals" return(ud); } ## }}} #' @export "print.cum.residuals"<- function (x,...) { ## {{{ object <- x; rm(x); if (!inherits(object, 'cum.residuals')) stop ("Must be an MG resid object") cat(" Call: \n") dput(attr(object, "Call")) cat("\n") } ## }}} #' Plots cumulative residuals #' #' This function plots the output from the cumulative residuals function #' "cum.residuals". The cumulative residuals are compared with the performance #' of similar processes under the model. #' #' #' @param x the output from the "cum.residuals" function. #' @param pointwise.ci if >1 pointwise confidence intervals are plotted with #' lty=pointwise.ci #' @param hw.ci if >1 Hall-Wellner confidence bands are plotted with lty=hw.ci. #' Only 95\% bands can be constructed. #' @param sim.ci if >1 simulation based confidence bands are plotted with #' lty=sim.ci. These confidence bands are robust to non-martingale behaviour. #' @param robust if "1" robust standard errors are used to estimate standard #' error of estimate, otherwise martingale based estimate are used. #' @param specific.comps all components of the model is plotted by default, but #' a list of components may be specified, for example first and third "c(1,3)". #' @param level gives the significance level. Default is 0.05. #' @param start.time start of observation period where estimates are plotted. #' Default is 0. #' @param stop.time end of period where estimates are plotted. Estimates thus #' plotted from [start.time, max.time]. #' @param add.to.plot to add to an already existing plot. Default is "FALSE". #' @param mains add names of covariates as titles to plots. #' @param main vector of names for titles in plots. #' @param xlab label for x-axis. NULL is default which leads to "Time" or "". #' Can also give a character vector. #' @param ylab label for y-axis. Default is "Cumulative MG-residuals". #' @param ylim limits for y-axis. #' @param score if '0' plots related to modelmatrix are specified, thus #' resulting in grouped residuals, if '1' plots for modelmatrix but with random #' realizations under model, if '2' plots residuals versus continuous #' covariates of model with random realizations under the model. #' @param conf.band makes simulation based confidence bands for the test #' processes under the 0 based on variance of these processes limits for #' y-axis. These will give additional information of whether the observed #' cumulative residuals are extreme or not when based on a variance weighted #' test. #' @param ... unused arguments - for S3 compatibility #' @author Thomas Scheike #' @references Martinussen and Scheike, Dynamic Regression Models for Survival #' Data, Springer (2006). #' @keywords survival #' @examples #' #' # see cum.residuals for examples #' #' @export "plot.cum.residuals" <- function (x,pointwise.ci=1,hw.ci=0,sim.ci=0, robust=1, specific.comps=FALSE,level=0.05, start.time = 0, stop.time = 0, add.to.plot=FALSE, mains=TRUE, main=NULL, xlab=NULL,ylab ="Cumulative MG-residuals",ylim=NULL, score=0,conf.band=FALSE,...) {## {{{ object <- x; rm(x); if (!inherits(object,'cum.residuals') ) stop ("Must be output from cum.residuals()") if (score <2) { B<-object$cum; if (sum(B)==0) { stop("To compute cumulative residuals provide model matrix \n"); } } if (score==2) ## {{{ { if (sum(object$obs.test)==0) stop("To plot cumulative residuals vs. covariates, cum.resid=1"); } if (score==0) ## {{{ { B<-object$cum; if (robust>=1) V<-object$robvar.cum else V<-object$var.cum p <- ncol(B); if (!is.null(main)) { if (length(main)!=p) main <- rep(main,length(comp)); mains <- FALSE; } if (!is.null(xlab)) { if (length(xlab)!=p) xlab <- rep(xlab,length(comp)); } if (specific.comps==FALSE) comp<-(2:p) else comp<-specific.comps+1 if (stop.time==0) stop.time<-max(B[,1]); med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; Bs<-B[1,]; B<-t(t(B)-Bs); B[,1]<-B[,1]+Bs[1]; V<-V[med,]; Vs<-V[1,]; V<-t( t(V)-Vs); Vrob<-object$robvar.cum; Vrob<-Vrob[med,]; Vrobs<-Vrob[1,]; Vrob<-t( t(Vrob)-Vrobs); c.alpha<- qnorm(1-level/2) for (v in comp) ## {{{ { c.alpha<- qnorm(1-level/2) est<-B[,v];ul<-B[,v]+c.alpha*V[,v]^.5;nl<-B[,v]-c.alpha*V[,v]^.5; if (add.to.plot==FALSE) { if (is.null(xlab)) xlabl <- "Time" else xlabl <- xlab[v] if (is.null(ylim)) plot(B[,1],est,ylim=1.05*range(ul,nl),type="s",xlab=xlabl,ylab=ylab,...) else plot(B[,1],est,ylim=ylim,type="s",xlab=xlabl,ylab=ylab) if (!is.null(main)) title(main=main[i]); if (mains==TRUE) title(main=colnames(B)[v]); } else lines(B[,1],est,type="s"); if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="s"); lines(B[,1],nl,lty=pointwise.ci,type="s"); } if (robust>=1) { lines(B[,1],ul,lty=robust,type="s"); lines(B[,1],nl,lty=robust,type="s"); } if (hw.ci>=1) { if (level!=0.05) cat("Hall-Wellner bands only 95 % \n"); tau<-length(B[,1]) nl<-B[,v]-1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) ul<-B[,v]+1.27*V[tau,v]^.5*(1+V[,v]/V[tau,v]) lines(B[,1],ul,lty=hw.ci,type="s"); lines(B[,1],nl,lty=hw.ci,type="s"); } if (sim.ci>=1) { if (level!=0.05) c.alpha<-percen(object$sim.testBeq0[,v-1],1-level) else c.alpha<-object$conf.band[v-1]; nl<-B[,v]-c.alpha*Vrob[,v]^.5; ul<-B[,v]+c.alpha*Vrob[,v]^.5; lines(B[,1],ul,lty=sim.ci,type="s"); lines(B[,1],nl,lty=sim.ci,type="s"); } abline(h=0) } ## }}} } ## }}} else if (score==1) ## {{{ { dim1<-ncol(object$procBeq0) if (sum(specific.comps)==FALSE) comp<-2:dim1 else comp<-specific.comps+1 if (!is.null(main)) { if (length(main)==1) main <- rep(main,length(comp)); mains <- FALSE; } if (!is.null(xlab)) { if (length(xlab)==1) xlab <- c("time",rep(xlab,length(comp))); } for (i in comp) ## {{{ { ranyl<-range(object$procBeq0[,i]); for (j in 1:50) ranyl<-range(c(ranyl,(object$sim.test.procBeq0[[j]])[,i-1])); mr<-max(abs(ranyl)); if (add.to.plot==FALSE) { if (is.null(xlab)) xlabl <- "Time" else xlabl <- xlab[i] if (!is.null(ylim)) plot(object$procBeq0[,1],object$procBeq0[,i],type="s", ylim=ylim,lwd=2,xlab=xlabl,ylab=ylab,...) else plot(object$procBeq0[,1],object$procBeq0[,i],type="s", ylim=c(-mr,mr),lwd=2,xlab=xlabl,ylab=ylab,...) if (!is.null(main)) title(main=main[i]); if (mains==TRUE) title(main=colnames(B)[i]); } else lines(object$procBeq0[,1],object$procBeq0[,i],type="s") for (j in 1:50) lines(object$procBeq0[,1],as.matrix(object$sim.test.procBeq0[[j]])[,i-1], col="grey",lwd=1,lty=1,type="s") lines(object$procBeq0[,1],object$procBeq0[,i],lwd=2,type="s") } ## }}} } ## }}} else if (score==2) ## {{{ plot score proces { dim1<-length(object$obs.test) if (sum(specific.comps)==FALSE) comp<-1:dim1 else comp<-specific.comps if (!is.null(xlab)) { if (length(xlab)==1) xlab <- rep(xlab,length(comp)); } if (!is.null(main)) { if (length(main)==1) main <- rep(main,length(comp)); mains <- FALSE; } v <- 0 for (i in comp) ## {{{ { v <- v+1 if (nrow(object$proc.cumz[[i]])==1) TYPE<-"p" else TYPE<-"l"; if (is.null(xlab)) xlabl <- colnames(object$proc.cumz[[v]])[1] else xlabl <- xlab[i] ### print(colnames(object$proc.cumz[[v]])); print(xlabl) if (TYPE=="l") { ranyl<-range(object$proc.cumz[[i]][,2]); for (j in 1:50) ranyl<-range(c(ranyl,(object$sim.test.proccumz[[i]])[,j])); mr<-max(abs(ranyl)); if (add.to.plot==FALSE) { if (!is.null(ylim)) plot(object$proc.cumz[[i]][,1],object$proc.cumz[[i]][,2],type=TYPE, ylim=ylim,lwd=2,xlab=xlabl,ylab=ylab,...) else plot(object$proc.cumz[[i]][,1],object$proc.cumz[[i]][,2],type=TYPE, ylim=c(-mr,mr),lwd=2,xlab=xlabl,ylab=ylab,...) } else lines(object$proc.cumz[[i]][,1],object$proc.cumz[[i]][,2],type="l") if (!is.null(main)) title(main=main[i]); if (mains==TRUE) title(main=colnames(object$proc.cumz[[i]])[1]); if (TYPE=="l") for (j in 1:50) lines(object$proc.cumz[[i]][,1],object$sim.test.proccumz[[i]][,j], col="grey",lwd=1,lty=1,type="l") if (TYPE=="p") for (j in 1:50) points(object$proc.cumz[[i]][,1],object$sim.test.proccumz[[i]][,j],pch=".") lines(object$proc.cumz[[i]][,1],object$proc.cumz[[i]][,2],lwd=2); } ## Prediction bandds ## {{{ if (conf.band==TRUE) { col.alpha<-0.2 col.ci<-"darkblue" lty.ci<-2 if (col.alpha==0) col.trans <- col.ci else col.trans <- sapply(col.ci, FUN=function(x) do.call(rgb,as.list(c(col2rgb(x)/255,col.alpha)))) if (level!=0.05) c.alpha<-percen(object$sim.test[,i],1-level) else c.alpha<-object$conf.band.cumz[i]; t<-object$proc.cumz[[i]][,1] ci<-c.alpha*object$robvar.cumz[1:length(t),i]^.5 #print(t); print(ci) lines(t,ci , lwd=1, col=col.ci, lty=lty.ci) lines(t,-ci , lwd=1, col=col.ci, lty=lty.ci) tt <- c(t, rev(t)) yy <- c(ci, rev(-ci)) polygon(tt,yy, col=col.trans, lty=0) } ## }}} } ## }}} } ## }}} } ## }}} #' Prints summary statistics for goodness-of-fit tests based on cumulative #' residuals #' #' Computes p-values for extreme behaviour relative to the model of various #' cumulative residual processes. #' #' #' @param object output from the cum.residuals() function. #' @param digits number of digits in printouts. #' @param ... unused arguments - for S3 compatibility #' @author Thomas Scheike #' @keywords survival #' @examples #' #' # see cum.residuals for examples #' "summary.cum.residuals" <- function (object,digits=3,...) {## {{{ if (!inherits(object,'cum.residuals')) stop ("Must be an cum.residuals object") # We print information about object: cat("Test for cumulative MG-residuals \n\n") mtest<-(sum(object$conf.band)>0) if (mtest==FALSE) { cat("Grouped cumulative residuals not computed, you must provide\n") cat("modelmatrix to get these (see help) \n\n") } if (mtest==TRUE) { test0<-cbind(object$obs.testBeq0,object$pval.testBeq0) test0.is<-cbind(object$obs.testBeq0.is,object$pval.testBeq0.is) colnames(test0)<- c("sup| hat B(t) |","p-value H_0: B(t)=0") colnames(test0.is)<- c("int ( B(t) )^2 dt","p-value H_0: B(t)=0") cat("Grouped Residuals consistent with model \n\n") prmatrix(round(test0,digits)) cat("\n") prmatrix(round(test0.is,digits)) cat("\n") } cumtest<-!is.null(object$obs.test) if (cumtest==FALSE) { cat("Cumulative tests versus covariates not computed \n\n") cat("cum.resid=1 to compute these \n\n"); } if (cumtest==TRUE) { test0<-cbind(object$obs.test,object$pval.test) colnames(test0)<- c("sup| hat B(t) |","p-value H_0: B(t)=0") cat("Residual versus covariates consistent with model \n\n") prmatrix(round(test0,digits)) } ### cat(" \n");cat(" Call: \n");dput(attr(object, "Call")); cat("\n"); } ## }}} timereg/R/clusterindex-reshape.r0000644000176200001440000000731014421510276016433 0ustar liggesuserscluster.index.timereg <- function(clusters,index.type=FALSE,num=NULL,Rindex=0) { ## {{{ antpers <- length(clusters) if (index.type==FALSE) { if (is.numeric(clusters)) clusters <- sindex.prodlim(unique(clusters),clusters)-1 else { max.clust <- length(unique(clusters)) clusters <- as.integer(factor(clusters, labels = 1:max.clust))-1 } } nclust <- .C("nclusters", as.integer(antpers), as.integer(clusters), as.integer(rep(0,antpers)), as.integer(0), as.integer(0), PACKAGE="timereg") maxclust <- nclust[[5]] antclust <- nclust[[4]] cluster.size <- nclust[[3]][1:antclust] if ((!is.null(num))) { ### different types in different columns mednum <- 1 if (is.numeric(num)) numnum <- sindex.prodlim(unique(num),num)-1 else numnum <- as.integer(factor(num, labels = 1:maxclust)) -1 maxclust <- max(numnum)+1; } else { numnum <- 0; mednum <- 0; } init <- -1*Rindex clustud <- .C("clusterindex", as.integer(clusters), as.integer(antclust), as.integer(antpers), as.integer(rep(init,antclust*maxclust)), as.integer(rep(0,antclust)), as.integer(mednum), as.integer(numnum),as.integer(rep(0,antclust)), PACKAGE="timereg") if (Rindex==1) idclust <- matrix(clustud[[4]],antclust,maxclust)+1 else idclust <- matrix(clustud[[4]],antclust,maxclust) if(Rindex==1) idclust[idclust==0] <- NA if (Rindex==1) firstclustid <- clustud[[8]]+1 else firstclustid <- clustud[[8]] out <- list(clusters=clusters,maxclust=maxclust,antclust=antclust,idclust=idclust, cluster.size=cluster.size,firstclustid=firstclustid) } ## }}} ###faster.reshape <- function(data,clusters,index.type=FALSE,num=NULL,Rindex=1) ###{ ## {{{ ###data <- as.matrix(data) ###if (NCOL(data)==1) data <- cbind(data) ### ###antpers <- length(clusters) ###if (index.type==FALSE) { ### max.clust <- length(unique(clusters)) ### clusters <- as.integer(factor(clusters, labels = 1:max.clust))-1 ###} ### ### nclust <- .C("nclusters", ### as.integer(antpers), as.integer(clusters), as.integer(rep(0,antpers)), ### as.integer(0), as.integer(0), PACKAGE="timereg") ### maxclust <- nclust[[5]] ### antclust <- nclust[[4]] ### cluster.size <- nclust[[3]][1:antclust] ### ###if ((!is.null(num)) && (Rindex==1)) { ### different types in different columns ### mednum <- 1 ### numnum <- as.integer(factor(num, labels = 1:maxclust)) -1 ###} else { numnum <- 0; mednum <- 0; } ### ###data[is.na(data)] <- nan ###p <- ncol(data); ###init <- -1*Rindex; ###clustud <- .C("clusterindexdata", ### as.integer(clusters), as.integer(antclust),as.integer(antpers), ### as.integer(rep(init,antclust*maxclust)),as.integer(rep(0,antclust)), as.integer(mednum), ### as.integer(numnum), as.double(c(data)), ### as.integer(p), as.double(rep(init*1.0,antclust*maxclust*p)), PACKAGE="timereg") ###idclust <- matrix(clustud[[4]],antclust,maxclust) ###xny <- matrix(clustud[[10]],antclust,maxclust*p) ###if(Rindex==1) xny[idclust==-1] <- NA ###if(Rindex==1) xny[idclust==-1] <- NA ###if(Rindex==1) idclust[idclust==-1] <- NA ### mnames <- c() ###print(maxclust) ### for (i in 1:maxclust) { ### mnames <- c(mnames,paste(names(data),".",i,sep="")) ### } ### xny <- data.frame(xny) ### names(xny) <- mnames ###out <- xny; ###} ## }}} ### ###fast.reshape <- function(data,id=id,num=NULL) { ## {{{ ### if (NCOL(data)==1) data <- cbind(data) ### cud <- cluster.index(id,num=num,Rindex=1) ## NA for index not there, index starts at 0 for use in C ### dataw <- c() ### mnames <- c() ### for (i in 1:cud$maxclust) { ### if (i==1) dataw <- data[cud$idclust[,i]+1,] ### else dataw <- cbind(dataw,data[cud$idclust[,i]+1,]) ### mnames <- c(mnames,paste(names(data),".",i,sep="")) ### } ### names(dataw) <- mnames ### return(dataw) ###} ## }}} timereg/R/two-stage-reg.r0000644000176200001440000005656714421510301014771 0ustar liggesusers #' Fit Clayton-Oakes-Glidden Two-Stage model #' #' Fit Clayton-Oakes-Glidden Two-Stage model with Cox-Aalen marginals and #' regression on the variance parameters. #' #' The model specifikatin allows a regression structure on the variance of the #' random effects, such it is allowed to depend on covariates fixed within #' clusters \deqn{ \theta_{k} = Q_{k}^T \nu }{}. This is particularly useful to #' model jointly different groups and to compare their variances. #' #' Fits an Cox-Aalen survival model. Time dependent variables and counting #' process data (multiple events per subject) are not possible ! #' #' The marginal baselines are on the Cox-Aalen form \deqn{ \lambda_{ki}(t) = #' Y_{ki}(t) ( X_{ki}^T(t) \alpha(t) ) \exp(Z_{ki}^T \beta ) }{} #' #' The model thus contains the Cox's regression model and the additive hazards #' model as special cases. (see cox.aalen function for more on this). #' #' The modelling formula uses the standard survival modelling given in the #' \bold{survival} package. Only for right censored survival data. #' #' The data for a subject is presented as multiple rows or 'observations', each #' of which applies to an interval of observation (start, stop]. For counting #' process data with the )start,stop] notation is used the 'id' variable is #' needed to identify the records for each subject. Only one record per subject #' is allowed in the current implementation for the estimation of theta. The #' program assumes that there are no ties, and if such are present random noise #' is added to break the ties. #' #' Left truncation is dealt with. Here the key assumption is that the maginals #' are correctly estimated and that we have a common truncation time within #' each cluster. #' #' @param margsurv fit of marginal survival cox.aalen model with residuals=2, #' and resample.iid=1 to get fully correct standard errors. See notaylor below. #' @param data a data.frame with the variables. #' @param start.time start of observation period where estimates are computed. #' @param max.time end of observation period where estimates are computed. #' Estimates thus computed from [start.time, max.time]. Default is max of data. #' @param id For timevarying covariates the variable must associate each record #' with the id of a subject. #' @param clusters cluster variable for computation of robust variances. #' @param robust if 0 then totally omits computation of standard errors. #' @param Nit number of iterations for Newton-Raphson algorithm. #' @param detail if 0 no details is printed during iterations, if 1 details are #' given. #' @param theta starting values for the frailty variance (default=0.1). #' @param theta.des design for regression for variances. The defauls is NULL #' that is equivalent to just one theta and the design with only a baseline. #' @param var.link default "0" is that the regression design on the variances #' is without a link, and "1" uses the link function exp. #' @param step step size for Newton-Raphson. #' @param notaylor if 1 then ignores variation due to survival model, this is #' quicker and then resample.iid=0 and residuals=0 is ok for marginal survival #' model that then is much quicker. #' @param se.clusters cluster variable for sandwich estimator of variance. #' @return returns an object of type "two.stage". With the following arguments: #' \item{cum}{cumulative timevarying regression coefficient estimates are #' computed within the estimation interval.} \item{var.cum}{the martingale #' based pointwise variance estimates.} \item{robvar.cum}{robust pointwise #' variances estimates.} \item{gamma}{estimate of parametric components of #' model.} \item{var.gamma}{variance for gamma.} \item{robvar.gamma}{robust #' variance for gamma.} \item{D2linv}{inverse of the derivative of the score #' function from marginal model.} \item{score}{value of score for final #' estimates.} \item{theta}{estimate of Gamma variance for frailty.} #' \item{var.theta}{estimate of variance of theta.} \item{SthetaInv}{inverse of #' derivative of score of theta.} \item{theta.score}{score for theta #' parameters.} #' @author Thomas Scheike #' @references Glidden (2000), A Two-Stage estimator of the dependence #' parameter for the Clayton Oakes model. #' #' Martinussen and Scheike, Dynamic Regression Models for Survival Data, #' Springer (2006). #' @keywords survival #' @examples #' #' library(timereg) #' data(diabetes) #' # Marginal Cox model with treat as covariate #' marg <- cox.aalen(Surv(time,status)~prop(treat)+prop(adult)+ #' cluster(id),data=diabetes,resample.iid=1) #' fit<-two.stage(marg,data=diabetes,theta=1.0,Nit=40) #' summary(fit) #' #' # using coxph and giving clusters, but SE wittout cox uncetainty #' margph <- coxph(Surv(time,status)~treat,data=diabetes) #' fit<-two.stage(margph,data=diabetes,theta=1.0,Nit=40,clusters=diabetes$id) #' #' #' # Stratification after adult #' theta.des<-model.matrix(~-1+factor(adult),diabetes); #' des.t<-model.matrix(~-1+factor(treat),diabetes); #' design.treat<-cbind(des.t[,-1]*(diabetes$adult==1), #' des.t[,-1]*(diabetes$adult==2)) #' #' # test for common baselines included here #' marg1<-cox.aalen(Surv(time,status)~-1+factor(adult)+prop(design.treat)+cluster(id), #' data=diabetes,resample.iid=1,Nit=50) #' #' fit.s<-two.stage(marg1,data=diabetes,Nit=40,theta=1,theta.des=theta.des) #' summary(fit.s) #' #' # with common baselines and common treatment effect (although test reject this) #' fit.s2<-two.stage(marg,data=diabetes,Nit=40,theta=1,theta.des=theta.des) #' summary(fit.s2) #' #' # test for same variance among the two strata #' theta.des<-model.matrix(~factor(adult),diabetes); #' fit.s3<-two.stage(marg,data=diabetes,Nit=40,theta=1,theta.des=theta.des) #' summary(fit.s3) #' #' # to fit model without covariates, use beta.fixed=1 and prop or aalen function #' marg <- aalen(Surv(time,status)~+1+cluster(id), #' data=diabetes,resample.iid=1,n.sim=0) #' fita<-two.stage(marg,data=diabetes,theta=0.95,detail=0) #' summary(fita) #' #' # same model but se's without variation from marginal model to speed up computations #' marg <- aalen(Surv(time,status) ~+1+cluster(id),data=diabetes, #' resample.iid=0,n.sim=0) #' fit<-two.stage(marg,data=diabetes,theta=0.95,detail=0) #' summary(fit) #' #' # same model but se's now with fewer time-points for approx of iid decomp of marginal #' # model to speed up computations #' marg <- cox.aalen(Surv(time,status) ~+prop(treat)+cluster(id),data=diabetes, #' resample.iid=1,n.sim=0,max.timepoint.sim=5,beta.fixed=1,beta=0) #' fit<-two.stage(marg,data=diabetes,theta=0.95,detail=0) #' summary(fit) #' ##' @export two.stage<-function(margsurv,data=parent.frame(), Nit=60,detail=0,start.time=0,max.time=NULL,id=NULL,clusters=NULL, robust=1,theta=NULL,theta.des=NULL,var.link=0,step=0.5,notaylor=0,se.clusters=NULL) { ## {{{ ## {{{ seting up design and variables rate.sim <- 1; secluster <- NULL if (!inherits(margsurv,"coxph")) { ## {{{ formula<-attr(margsurv,"Formula"); beta.fixed <- attr(margsurv,"beta.fixed") if (is.null(beta.fixed)) beta.fixed <- 1; ldata<-aalen.des(formula,data=data,model="cox.aalen"); id <- attr(margsurv,"id"); mclusters <- attr(margsurv,"cluster") mclustind <- attr(margsurv,"cluster") cluster.call <- attr(margsurv,"cluster.call") X<-ldata$X; time<-ldata$time2; Z<-ldata$Z; status<-ldata$status; time2 <- attr(margsurv,"stop"); start <- attr(margsurv,"start") antpers<-nrow(X); if (beta.fixed==1) Z <- NULL; if (is.null(Z)==TRUE) {npar<-TRUE; semi<-0;} else { Z<-as.matrix(Z); npar<-FALSE; semi<-1;} if (npar==TRUE) {Z<-matrix(0,antpers,1); pz<-1; fixed<-0;} else {fixed<-1;pz<-ncol(Z);} px<-ncol(X); if (is.null(clusters) && is.null(mclusters)) stop("No cluster variabel specified in marginal or twostage call \n"); if (is.null(clusters)) { clusters <- mclusters; cluster.call <- cluster.call} else {cluster.call <- clusters;} if (is.null(se.clusters)) secluster <- clusters; antsecluster <- length(unique(secluster)) if (is.numeric(secluster)) secluster <- sindex.prodlim(unique(secluster),secluster)-1 else { seclusters <- as.integer(factor(clusters, labels = 1:antsecluster))-1 } ### print("two-stage"); print(head(cluster.call)) if (is.null(cluster.call)) notaylor <- 1 if (is.null(margsurv$gamma.iid)) notaylor <- 1 ## }}} } else { ## coxph ## {{{ notaylor <- 1 antpers <- margsurv$n id <- 0:(antpers-1) mt <- model.frame(margsurv) Y <- model.extract(mt, "response") if (!inherits(Y, "Surv")) stop("Response must be a survival object") if (attr(Y, "type") == "right") { time2 <- Y[, "time"]; status <- Y[, "status"] start <- rep(0,antpers); } else { start <- Y[, 1]; time2 <- Y[, 2];status <- Y[, 3]; } Z <- matrix(1,antpers,length(coef(margsurv))); if (is.null(clusters)) stop("must give clusters for coxph\n"); cluster.call <- clusters X <- matrix(1,antpers,1); ### Z <- matrix(0,antpers,1); ### no use for these px <- 1; pz <- ncol(Z); beta.fixed <- 0 semi <- 1 start.time <- 0 } ## }}} if (any(is.na(clusters))) stop("Missing values in cluster varaibles\n"); out.clust <- cluster.index.timereg(clusters); clusters <- out.clust$clusters maxclust <- out.clust$maxclust antclust <- out.clust$antclust idiclust <- out.clust$idclust cluster.size <- out.clust$cluster.size ### if (anyNA(idiclust)) idiclust[is.na(idiclust)] <- 0 ### setting secluster after cluster.index call to deal with characters if (inherits(margsurv,"coxph")) { if (is.null(se.clusters) & is.null(secluster) ) secluster <- clusters; antsecluster <- length(unique(secluster)) if (is.numeric(secluster)) secluster <- sindex.prodlim(unique(secluster),secluster)-1 else { clusters <- as.integer(factor(clusters, labels = 1:antsecluster))-1 } } if (length(clusters)!=length(secluster)) stop("length of se.clusters not consistent with cluster length\n"); if (sum(abs(start))>0) lefttrunk <- 1 else lefttrunk <- 0; cumhazleft <- 0; RR <- rep(1,antpers); update <- 1; if (update==0) { ## {{{ if ((attr(margsurv,"residuals")!=2) || (lefttrunk==1)) { ### compute cum hazards in time point infty; nn <- nrow(margsurv$cum) cum <- Cpred(margsurv$cum,time2)[,-1] if (npar==TRUE) cumhaz <- apply(cum*X,1,sum) if (npar==FALSE) cumhaz <- apply(cum*X,1,sum)*exp( Z %*% margsurv$gamma) if (lefttrunk==1) { cum <- Cpred(margsurv$cum,start)[,-1] cumhazleft <- apply(cum*X,1,sum) if (npar==TRUE) cumhazleft <- cumhazleft if (npar==FALSE) cumhazleft <- cumhazleft * exp( Z %*% margsurv$gamma) } } else { residuals<-margsurv$residuals$dM; cumhaz<-status-residuals; } } ## }}} if (update==1) if (inherits(margsurv,c("aalen","cox.aalen"))) { ## {{{ if ((attr(margsurv,"residuals")!=2) || (lefttrunk==1)) { resi <- residualsTimereg(margsurv,data=data) residuals <- resi$residuals; cumhaz <- resi$cumhaz; cumhazleft <- resi$cumhazleft; RR <- resi$RR } else { residuals <- margsurv$residuals$dM; cumhaz <- status-residuals; if (inherits(margsurv,"cox.aalen")) RR <- exp( Z %*% margsurv$gamma) } } else if (inherits(margsurv,"coxph")) { notaylor <- 1 residuals <- residuals(margsurv) cumhaz <- status-residuals cumhazleft <- rep(0,antpers) RR<- exp(margsurv$linear.predictors-sum(margsurv$means*coef(margsurv))) if ((lefttrunk==1)) { ### baseout <- basehaz(margsurv,centered=FALSE); sfit <- survfit(margsurv, se.fit=FALSE) zcoef <- ifelse(is.na(coef(margsurv)), 0, coef(margsurv)) offset <- sum(margsurv$means * zcoef) chaz <- sfit$cumhaz * exp(-offset) cum <- cbind(sfit$time,chaz) cum <- Cpred(cum,start)[,2] cumhazleft <- cum * RR } } ## }}} ### print(head(cbind(residuals,cumhaz,RR,time2,status))) ratesim<-rate.sim; inverse<-var.link pxz <- px + pz; times<-c(start.time,time2[status==1]); times<-sort(times); if (is.null(max.time)==TRUE) maxtimes<-max(times)+0.1 else maxtimes<-max.time; times<-times[times1) { rownames(ud$theta)<-colnames(theta.des); names(ud$theta.score)<-colnames(theta.des); } else { names(ud$theta.score)<- rownames(ud$theta)<-"intercept" } attr(ud,"Call")<- match.call(); class(ud)<-"two.stage" attr(ud,"Formula")<-formula; attr(ud,"id")<-id; attr(ud,"cluster")<-clusters; attr(ud,"cluster.call")<-cluster.call; attr(ud,"secluster")<-secluster; attr(ud,"start")<-start; attr(ud,"time2")<-time2; attr(ud,"var.link")<-var.link attr(ud,"beta.fixed")<-beta.fixed attr(ud,"marg.model")<-class(margsurv) ### attr(ud,"DUbeta")<-DUbeta return(ud) ## }}} } ## }}} ##' @export summary.two.stage<-function (object,digits=3,...) { ## {{{ if (!(inherits(object, 'two.stage') )) stop("Must be a Two-Stage object") prop<-TRUE; if (is.null(object$prop.odds)==TRUE) p.o<-FALSE else p.o<-TRUE var.link<-attr(object,"var.link"); cat("Dependence parameter for Clayton-Oakes-Glidden model\n"); if (sum(abs(object$theta.score)>0.000001) ) cat("Variance parameters did not converge, allow more iterations\n\n"); resdep <- coef.two.stage(object,...) prmatrix(resdep[,1:6,drop=FALSE]); cat(" \n"); prmatrix(resdep[,7:9,drop=FALSE]); cat(" \n"); if (attr(object,"marg.model")!="coxph") if (attr(object,"beta.fixed")==0) { ## {{{ ### cat("Marginal Cox-Aalen model fit\n\n"); if (sum(abs(object$score)>0.000001) && sum(object$gamma)!=0) cat("Marginal model did not converge, allow more iterations\n\n"); ### if (prop) { ### if (p.o==FALSE) cat("Proportional Cox terms : \n") else cat("Covariate effects \n") ### ### out=coef.two.stage(object,digits=digits); ### out=signif(out,digits=digits) ### print(out) ### ### } } ## }}} ### cat(" \n"); cat(" Call: \n"); dput(attr(object, "Call")); cat("\n"); } ## }}} ##' @export print.two.stage <- function (x,digits = 3,...) { ## {{{ summary.two.stage(x,digits=digits,...) ### if (!(inherits(x, 'two.stage') )) stop("Must be a Two-Stage object") ### cat(" Two-stage estimation for Clayton-Oakes-Glidden model\n"); ### cat(" Marginals of Cox-Aalen form, dependence by variance of Gamma distribution\n\n"); ### object <- x; rm(x); ### ### cat(" Nonparametric components : "); ### cat(colnames(object$cum)[-1]); cat(" \n"); ### if (!is.null(object$gamma)) { ### cat(" Parametric components : "); cat(rownames(object$gamma)); ### cat(" \n"); ### } ### cat(" \n"); ### ### cat(" Call: \n"); ### print(attr(object,'Call')) } ## }}} ##' @export vcov.two.stage <- function(object, ...) { rv <- object$robvar.gamma if (!identical(rv, matrix(0, nrow = 1L, ncol = 1L))) rv # else return NULL } ##' @export coef.two.stage<-function(object,digits=3,d2logl=1,alpha=0.05,...) { ## {{{ if (!(inherits(object, 'two.stage') )) stop("Must be a Two-Stage object") var.link <- attr(object,"var.link") ptheta<-nrow(object$theta) sdtheta<-diag(object$var.theta)^.5 if (var.link==0) { vari<-object$theta sdvar<-diag(object$var.theta)^.5 upper <- object$theta-qnorm(alpha/2)*sdvar lower <- object$theta+qnorm(alpha/2)*sdvar } else { vari<-exp(object$theta) sdvar<-vari*diag(object$var.theta)^.5 upper <- exp(object$theta-qnorm(alpha/2)*sdtheta) lower <- exp(object$theta+qnorm(alpha/2)*sdtheta) } dep<-cbind(object$theta[,1],sdtheta) walddep<-object$theta[,1]/sdtheta; waldpdep<-(1-pnorm(abs(walddep)))*2 kendall<-1/(1+2/vari) kendall.ll<-1/(1+2/(object$theta+qnorm(alpha/2)*sdvar)) kendall.ul<-1/(1+2/(object$theta-qnorm(alpha/2)*sdvar)) if (var.link==0) resdep<-signif(as.matrix(cbind(dep,lower,upper,walddep,waldpdep,kendall,kendall.ll,kendall.ul)),digits) else resdep<-signif(as.matrix(cbind(dep,lower,upper,walddep,waldpdep,vari,sdvar,kendall,kendall.ll,kendall.ul)),digits); slower <- paste("lower",signif(100*alpha/2,2),"%",sep="") supper <- paste("upper",signif(100*(1-alpha/2),3),"%",sep="") if (var.link==0) colnames(resdep) <- c("Variance","SE",slower,supper,"z","P-val","Kendall's tau",slower,supper) else colnames(resdep)<-c("log(Variance)","SE",slower,supper,"z","P-val","Variance","SE Var.","Kendall's tau",slower,supper) ### prmatrix(resdep); cat(" \n"); return(resdep) } ## }}} ##' @export plot.two.stage<-function(x,pointwise.ci=1,robust=0,specific.comps=FALSE, level=0.05, start.time=0,stop.time=0,add.to.plot=FALSE,mains=TRUE, xlab="Time",ylab ="Cumulative regression function",...) { ## {{{ if (!(inherits(x, 'two.stage'))) stop("Must be a Two-Stage object") object <- x; rm(x); B<-object$cum; V<-object$var.cum; p<-dim(B)[[2]]; if (robust>=1) V<-object$robvar.cum; if (sum(specific.comps)==FALSE) comp<-2:p else comp<-specific.comps+1 if (stop.time==0) stop.time<-max(B[,1]); med<-B[,1]<=stop.time & B[,1]>=start.time B<-B[med,]; Bs<-B[1,]; B<-t(t(B)-Bs); B[,1]<-B[,1]+Bs[1]; V<-V[med,]; Vs<-V[1,]; V<-t( t(V)-Vs); Vrob<-object$robvar.cum; Vrob<-Vrob[med,]; Vrobs<-Vrob[1,]; Vrob<-t( t(Vrob)-Vrobs); c.alpha<- qnorm(1-level/2) for (v in comp) { c.alpha<- qnorm(1-level/2) est<-B[,v];ul<-B[,v]+c.alpha*V[,v]^.5;nl<-B[,v]-c.alpha*V[,v]^.5; if (add.to.plot==FALSE) { plot(B[,1],est,ylim=1.05*range(ul,nl),type="s",xlab=xlab,ylab=ylab) if (mains==TRUE) title(main=colnames(B)[v]); } else lines(B[,1],est,type="s"); if (pointwise.ci>=1) { lines(B[,1],ul,lty=pointwise.ci,type="s"); lines(B[,1],nl,lty=pointwise.ci,type="s"); } if (robust>=1) { lines(B[,1],ul,lty=robust,type="s"); lines(B[,1],nl,lty=robust,type="s"); } abline(h=0); } } ## }}} ##' @export predict.two.stage <- function(object,X=NULL,Z=NULL,times=NULL,times2=NULL,X2=NULL,Z2=NULL, theta=NULL,theta.des=NULL,diag=TRUE,...) { ## {{{ time.coef <- data.frame(object$cum) if (!is.null(times)) cum <- Cpred(object$cum,times) else cum <- object$cum; if (!is.null(times2)) cum2 <- Cpred(object$cum,times2) else cum2 <- object$cum; if (is.null(Z) & (!is.null(object$gamma))) Z <- matrix(0,1,nrow(object$gamma)); if (is.null(X) & (!is.null(Z))) { Z <- as.matrix(Z); X <- matrix(1,nrow(Z),1)} if (is.null(Z) & (!is.null(X))) {X <- as.matrix(X); Z <- matrix(0,nrow(X),1); gamma <- 0} if (is.null(X)) X <- 1; X2 <- X; Z2 <- Z2; if (diag==FALSE) { time.part <- X %*% t(cum[,-1]) time.part2 <- X2 %*% t(cum2[,-1]) if (!is.null(object$gamma)) { gamma <- object$gamma RR <- exp( Z %*% gamma ); RR2 <- exp( Z2 %*% gamma ); cumhaz <- t( t(time.part) * RR ); cumhaz2 <- t( t(time.part2) * RR2 )} else { cumhaz <- time.part; cumhaz2 <- time.part2; } } else { time.part <- apply(as.matrix(X*cum[,-1]),1,sum) time.part2 <- apply(as.matrix(X2*cum2[,-1]),1,sum) } if (!is.null(object$gamma)) { RR<- exp(Z%*%object$gamma); RR2 <- exp(Z2 %*%object$gamma); cumhaz <- c((time.part) * RR) ; cumhaz2 <- c((time.part2) * RR2); } else { cumhaz <- c(time.part); cumhaz2 <- c(time.part2); } S1 <- pmin(1,exp(-cumhaz)); S2 <- pmin(1,exp(-cumhaz2)) ###print(length(S1)) ###print(length(S2)) if (is.null(theta)) theta <- object$theta if (!is.null(theta.des)) theta <- c(theta.des %*% theta) if (attr(object,"var.link")==1) theta <- exp(theta) ### theta is variance if (diag==FALSE) St1t2<- (outer(c(S1)^{-(theta)},c(S2)^{-(theta)},FUN="+") - 1)^(-(1/theta)) else St1t2<- ((S1^{-(theta)}+S2^{-(theta)})-1)^(-(1/theta)) ###St1t2<- ((S1^{-(1/theta)}+S2^{-(1/theta)})-1)^(-(theta)) out=list(St1t2=St1t2,S1=S1,S2=S2,times=times,times2=times2,theta=theta) return(out) } ## }}} timereg/R/predict-timereg.r0000644000176200001440000007155014421510301015355 0ustar liggesusersslaaop<-function(z,time,cum) {x<-time; y<-cum; index<-sum(x<=z);if (index==0) index<-1; retur<-y[index]; return(retur); } pred.cum<-function(x,time,cum) {ud<-sapply(x,slaaop,time,cum); return(ud)} pred.des<-function(formula,data=parent.frame()) { ## {{{ call <- match.call(); m <- match.call(expand.dots=FALSE); special <- c("const") Terms <- if(missing(data)) terms(formula, special) else terms(formula, special,data=data) m$formula <- Terms m[[1]] <- as.name("model.frame") m <- eval(m, data) mt <- attr(m, "terms") XZ<-model.matrix(Terms,m)[,drop = FALSE] cols<-attributes(XZ)$assign l.cols<-length(cols) semicov <- attr(Terms, "specials")$const ZtermsXZ<-semicov-1 if (length(semicov)) {renaalen<-FALSE; Zterms<-c(); for (i in ZtermsXZ) Zterms<-c(Zterms,(1:l.cols)[cols==i]); } else {renaalen<-TRUE;} if (length(semicov)) { X<-as.matrix(XZ[,-Zterms]); #covnamesX <- dimnames(XZ)[[2]][-Zterms]; dimnames(X)[[2]]<-covnamesX; Z<-as.matrix(XZ[,Zterms]); #covnamesZ <- dimnames(XZ)[[2]][Zterms];dimnames(Z)[[2]]<-covnamesZ; } else {X<-as.matrix(XZ); #covnamesX <- dimnames(XZ)[[2]]; Z<-FALSE; #dimnames(X)[[2]]<-covnamesX; } X <- data.matrix(X); return(list(covarX=X,covarZ=Z)) } ## }}} aalen.des2 <- function(formula,data=parent.frame(),model=NULL,...){ ## {{{ call <- match.call() m <- match.call(expand.dots=FALSE) m$model <- NULL 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()) mt <- attr(m, "terms") intercept<-attr(mt, "intercept") Y <- model.extract(m, "response") if (model=="cox.aalen") modela <- "cox.aalen" else modela <- "aalen" des<-read.design(m,Terms,model=modela) return(des) } ## }}} ##' @export predict.cox.aalen <- function(object,...) predict.timereg(object,...) ##' @export predict.aalen <- function(object,...) predict.timereg(object,...) ##' @export predict.comprisk <- function(object,...) predict.timereg(object,...) #' Predictions for Survival and Competings Risks Regression for timereg #' #' Make predictions based on the survival models (Aalen and Cox-Aalen) and the #' competing risks models for the cumulative incidence function (comp.risk). #' Computes confidence intervals and confidence bands based on resampling. #' #' #' @aliases predict.timereg predict.aalen predict.comprisk predict.cox.aalen #' @param object an object belonging to one of the following classes: comprisk, #' aalen or cox.aalen #' @param newdata specifies the data at which the predictions are wanted. #' @param X alternative to newdata, specifies the nonparametric components for #' predictions. #' @param Z alternative to newdata, specifies the parametric components of the #' model for predictions. #' @param times times in which predictions are computed, default is all #' time-points for baseline #' @param n.sim number of simulations in resampling. #' @param uniform computes resampling based uniform confidence bands. #' @param se computes pointwise standard errors #' @param alpha specificies the significance levelwhich cause we consider. #' @param resample.iid set to 1 to return iid decomposition of estimates, 3-dim #' matrix (predictions x times x subjects) #' @param ... unused arguments - for S3 compatability #' @return \item{time}{vector of time points where the predictions are #' computed.} \item{unif.band}{resampling based constant to construct 95\% #' uniform confidence bands.} \item{model}{specifies what model that was #' fitted.} \item{alpha}{specifies the significance level for the confidence #' intervals. This relates directly to the constant given in unif.band.} #' \item{newdata}{specifies the newdata given in the call.} \item{RR}{gives #' relative risk terms for Cox-type models.} \item{call}{gives call for predict #' funtion.} \item{initial.call}{gives call for underlying object used for #' predictions.} \item{P1}{gives cumulative inicidence predictions for #' competing risks models. Predictions given in matrix form with different #' subjects in different rows.} \item{S0}{gives survival predictions for #' survival models. Predictions given in matrix form with different subjects #' in different rows.} \item{se.P1}{pointwise standard errors for predictions #' of P1.} \item{se.S0}{pointwise standard errors for predictions of S0.} #' @author Thomas Scheike, Jeremy Silver #' @references Scheike, Zhang and Gerds (2008), Predicting cumulative incidence #' probability by direct binomial regression, Biometrika, 95, 205-220. #' #' Scheike and Zhang (2007), Flexible competing risks regression modelling and #' goodness of fit, LIDA, 14, 464-483 . #' #' Martinussen and Scheike (2006), Dynamic regression models for survival data, #' Springer. #' @keywords survival #' @examples #' #' data(bmt); #' #' ## competing risks #' add<-comp.risk(Event(time,cause)~platelet+age+tcell,data=bmt,cause=1) #' #' ndata<-data.frame(platelet=c(1,0,0),age=c(0,1,0),tcell=c(0,0,1)) #' out<-predict(add,newdata=ndata,uniform=1,n.sim=1000) #' par(mfrow=c(2,2)) #' plot(out,multiple=0,uniform=1,col=1:3,lty=1,se=1) #' # see comp.risk for further examples. #' #' add<-comp.risk(Event(time,cause)~factor(tcell),data=bmt,cause=1) #' summary(add) #' out<-predict(add,newdata=ndata,uniform=1,n.sim=1000) #' plot(out,multiple=1,uniform=1,col=1:3,lty=1,se=1) #' #' add<-prop.odds.subdist(Event(time,cause)~factor(tcell), #' data=bmt,cause=1) #' out <- predict(add,X=1,Z=1) #' plot(out,multiple=1,uniform=1,col=1:3,lty=1,se=1) #' #' #' ## SURVIVAL predictions aalen function #' data(sTRACE) #' out<-aalen(Surv(time,status==9)~sex+ diabetes+chf+vf, #' data=sTRACE,max.time=7,n.sim=0,resample.iid=1) #' #' pout<-predict(out,X=rbind(c(1,0,0,0,0),rep(1,5))) #' head(pout$S0[,1:5]); head(pout$se.S0[,1:5]) #' par(mfrow=c(2,2)) #' plot(pout,multiple=1,se=0,uniform=0,col=1:2,lty=1:2) #' plot(pout,multiple=0,se=1,uniform=1,col=1:2) #' #' out<-aalen(Surv(time,status==9)~const(age)+const(sex)+ #' const(diabetes)+chf+vf, #' data=sTRACE,max.time=7,n.sim=0,resample.iid=1) #' #' pout<-predict(out,X=rbind(c(1,0,0),c(1,1,0)), #' Z=rbind(c(55,0,1),c(60,1,1))) #' head(pout$S0[,1:5]); head(pout$se.S0[,1:5]) #' par(mfrow=c(2,2)) #' plot(pout,multiple=1,se=0,uniform=0,col=1:2,lty=1:2) #' plot(pout,multiple=0,se=1,uniform=1,col=1:2) #' #' pout<-predict(out,uniform=0,se=0,newdata=sTRACE[1:10,]) #' plot(pout,multiple=1,se=0,uniform=0) #' #' #### cox.aalen #' out<-cox.aalen(Surv(time,status==9)~prop(age)+prop(sex)+ #' prop(diabetes)+chf+vf, #' data=sTRACE,max.time=7,n.sim=0,resample.iid=1) #' #' pout<-predict(out,X=rbind(c(1,0,0),c(1,1,0)),Z=rbind(c(55,0,1),c(60,1,1))) #' head(pout$S0[,1:5]); head(pout$se.S0[,1:5]) #' par(mfrow=c(2,2)) #' plot(pout,multiple=1,se=0,uniform=0,col=1:2,lty=1:2) #' plot(pout,multiple=0,se=1,uniform=1,col=1:2) #' #' pout<-predict(out,uniform=0,se=0,newdata=sTRACE[1:10,]) #' plot(pout,multiple=1,se=0,uniform=0) #' #' #### prop.odds model #' add<-prop.odds(Event(time,cause!=0)~factor(tcell),data=bmt) #' out <- predict(add,X=1,Z=0) #' plot(out,multiple=1,uniform=1,col=1:3,lty=1,se=1) #' ##' @export predict.timereg <-function(object,newdata=NULL,X=NULL,times=NULL, Z=NULL,n.sim=500, uniform=TRUE, se=TRUE,alpha=0.05,resample.iid=0,...) { ## {{{ ### if (object$conv$convd>=1) stop("Model did not converge.") ### {{{ reading designs and models if (!(inherits(object,'comprisk') || inherits(object,'aalen') || inherits(object,'cox.aalen'))) stop ("Must be output from comp.risk, aalen, cox.aalen, prop.odds function") if(inherits(object,'aalen')) { modelType <- 'aalen'; } else if(inherits(object,'comprisk')) { modelType <- object$model; } else if(inherits(object,'cox.aalen')) { if (object$prop.odds==0) modelType <- 'cox.aalen' else modelType <- 'prop.odds'; } type <- "na" if (modelType=="prop.odds") type <- attr(object,'type') n <- length(object$B.iid) ## Number of clusters (or number of individuals ## if no cluster structure is specified) if (se==FALSE) uniform <- FALSE if (is.null(object$B.iid)==TRUE & (se==TRUE | uniform==TRUE)) { stop("resample processes necessary for these computations, set resample.iid=1"); } if (is.null(object$gamma)==TRUE) { semi<-FALSE } else { semi<-TRUE } ## }}} ## {{{ extracts design based on the different specifications ## cox.aalen uses prop(...), while aalen and comp.risk use const(...) ## this accounts for the different number of characters if(inherits(object,'cox.aalen')){ indexOfFirstChar <- 6; } else { indexOfFirstChar <- 7; } ### whether or not iid time coarsening is used (only for cox-aalen) ### or whether time is changed due to times argument, then also changing times for iid and cum iidtimechange <- 0; iidtime <- 0 if (!is.null(newdata)) { ## {{{ newdata given ## The time-constant effects first formulao <- attr(object,"Formula") des <- aalen.des2(formula(delete.response(terms(formulao))),data=newdata,model=modelType) time.vars <- des$X if (semi==TRUE) { constant.covs <- des$Z; const <- c(object$gamma) names(const) <-substr(dimnames(object$gamma)[[1]],indexOfFirstChar, nchar(dimnames(object$gamma)[[1]])-1) } else constant.covs <- NULL ## Then extract the time-varying effects ### time.coef <- data.frame(object$cum) time.coef <- as.matrix(object$cum) if (!is.null(times)) {time.coef<-Cpred(time.coef,times,strict=FALSE); iidtimechange <- 1; iidtime <- object$cum[,1];} ### SE based on iid decomposition so uses time-resolution for cox.aalen model if (modelType=="cox.aalen" && (!is.null(object$time.sim.resolution)) && (se==TRUE)) { iidtime <- object$time.sim.resolution; iidtimechange <- 1} nobs <- nrow(newdata) ## }}} } else if ((is.null(Z)==FALSE) || (is.null(X)==FALSE)){ ## {{{ X, Z specified if (semi) zcol <- length(c(object$gamma)) else zcol <- NULL if (!is.null(Z)) { prow <- nrow(Z); } if (!is.null(Z)) Z <- matrix(Z,ncol=zcol) if (semi & is.null(Z)) Z <- matrix(0,nrow=nrow(X),ncol=zcol); xcol<-ncol(object$cum)-1 if (!is.null(X)) X <- matrix(X,ncol=xcol) else { X <- matrix(0,nrow(Z),xcol) X[,1] <- 1 } if (semi & is.null(Z)) Z <- matrix(0,nrow=nrow(X),ncol=zcol); time.vars <- X if (semi) constant.covs <- Z else constant.covs <- NULL nobs<-nrow(X); ## Then extract the time-varying effects time.coef <- as.matrix(object$cum) if (!is.null(times)) {time.coef<-Cpred(time.coef,times,strict=FALSE); iidtimechange <- 1; iidtime <- object$cum[,1];} ### SE based on iid decomposition so uses time-resolution for cox.aalen model if (modelType=="cox.aalen" && (!is.null(object$time.sim.resolution)) && (se==TRUE)) { iidtime <- object$time.sim.resolution; iidtimechange <- 1} ## prop.odds via cox.aalen if (modelType=="prop.odds" && (!is.null(object$time.sim.resolution)) && (se==TRUE)) { iidtime <- object$time.sim.resolution; iidtimechange <- 1} ## }}} } else { ## {{{ stop("Must specify either newdata or X, Z\n"); } ## }}} ## }}} ## {{{ predictions for competing risks and survival data cumhaz<-as.matrix(time.vars) %*% t(matrix(time.coef[,-1],ncol=(ncol(time.coef)-1))) times <- time<-time.coef[,1]; if (semi==TRUE) pg <- nrow(object$gamma); nt<-length(time); ### set up articial time.pow for aalen and cox.aalen to make unified code for ### comp.risk and survival if(inherits(object,'aalen') & semi==TRUE) timepow <- rep(1,pg) if(inherits(object,'cox.aalen')) timepow <- rep(0,pg) if(inherits(object,'comprisk')) timepow <- attr(object,"time.pow") if (semi==TRUE) constant.part <- constant.covs %*% ((matrix(rep(c(time),pg),pg,nt,byrow=TRUE)^timepow)*c(object$gamma)) if (inherits(object,'comprisk')) { ## {{{ competing models if (modelType == "additive") { if (semi==FALSE){ P1=1-exp(-cumhaz); } else { P1=1-exp(-cumhaz-constant.part ) } RR<-1; } else if (modelType == 'rcif') { # P1=exp(x^T b(t) + z^t t^p gamma) if (semi==FALSE){ P1=exp(cumhaz); } else { P1<-exp(cumhaz+constant.part); } RR<-1; } else if (modelType == 'rcif2') { # P1=x^T b(t) exp( z^t t^p gamma) if (semi==FALSE){ P1=cumhaz; RR<-1; } else { P1<-cumhaz*exp(constant.part); RR<-exp(constant.part); } } else if (modelType == 'prop') {# model proportional , Fine Gray extension if (semi==FALSE){ RR<-exp(cumhaz); } else { RR<-exp(cumhaz+constant.part); } P1<-1-exp(-RR); } else if (modelType == 'fg') {# model proportional, Fine-Gray parametrization if (semi==FALSE){ RR<-cumhaz; } else { RR<-cumhaz*exp(constant.part); } P1<-1-exp(-RR); } else if (modelType == 'logistic') { #model logistic if (semi==FALSE){ RR<-exp(cumhaz); } else { RR<-exp(cumhaz+constant.part); } P1<-RR/(1+RR); } else if (modelType == 'logistic2') { #model logistic, baseline-par if (semi==FALSE){ RR<-1; } else { RR<-exp(constant.part); } P1<-RR*cumhaz/(1+RR*cumhaz); } ## }}} } else if (modelType=="prop.odds") { RR <- exp(constant.part) HRR <- cumhaz* RR P1 <- HRR/(1+HRR) S0 <- 1/(1+HRR) } else { # aalen or cox.aalen survival model ## {{{ if (modelType == "aalen") { #Aalen model if (semi==FALSE){ S0=exp(-cumhaz); } else { S0=exp(-cumhaz-constant.part) } RR<-NULL; } else if(modelType == 'cox.aalen'){ #Cox-Aalen model if(semi == FALSE){ RR <- NULL; S0 <- exp(-cumhaz); } else { RR <- exp(constant.part); S0 <- exp(-cumhaz * RR); } } else stop("model class not supported by predict\n") } ## }}} ## }}} se.P1 <- NULL se.S0 <- NULL P1.iid <- NULL S0.iid <- NULL uband <- NULL ## i.i.d decomposition for computation of standard errors ## {{{ if (se==1) { pg<-length(object$gamma); delta<-c(); for (i in 1:n) { if (iidtimechange==1) tmptiid<- t(Cpred(cbind(iidtime,object$B.iid[[i]]),times,strict=FALSE)[,-1,drop=FALSE]) else tmptiid <- t(object$B.iid[[i]]) tmp<- as.matrix(time.vars) %*% tmptiid if (semi==TRUE) { gammai <- matrix(object$gamma.iid[i,],pg,1); tmp.const<-constant.covs %*% ((matrix(rep(c(time),pg),pg,nt,byrow=TRUE)^timepow)*c(gammai)) } if (i==0) { ## {{{ test print stuff print(tmp.const); if (modelType=="additive" || modelType == 'aalen'){ print(tmp.const %*% matrix(time,1,nt)) } else if (modelType=="prop"){ print(tmp.const %*% matrix(1,1,nt)); } else if (modelType=="cox.aalen") { tmp <- RR * tmp + RR * cumhaz * matrix(tmp.const,nobs,nt); } else if (modelType=="prop.odds") { } } ## }}} if (semi==TRUE){ if(modelType=="additive" || modelType == "aalen") { tmp<-tmp+ tmp.const } else if (modelType=="prop" || modelType=="rcif") { tmp<-RR*tmp+RR*tmp.const; } else if (modelType=="logistic" || modelType=="rcif2") { tmp<-RR*tmp+RR*cumhaz*tmp.const; } else if (modelType=="logistic2") { tmp<-RR*tmp+RR*cumhaz*tmp.const; } else if (modelType=="cox.aalen") { tmp <- RR * tmp + RR * cumhaz * tmp.const } else if (modelType=="prop.odds") { ### print(dim(RR)); print(dim(tmp)); tmp <- RR * tmp + RR * cumhaz * tmp.const; } } else { if (modelType=="prop") { tmp<-RR*tmp; } } delta<-cbind(delta,c(tmp)); } se<-apply(delta^2,1,sum)^.5 if(modelType == 'additive' || modelType == 'prop' || modelType=="fg"){ se.P1<-matrix(se,nobs,nt)*(1-P1); if (resample.iid==1) P1.iid <- array(delta*c(1-P1),c(nobs,nt,n)); } else if(modelType == 'rcif' ){ se.P1<-matrix(se,nobs,nt)*P1 if (resample.iid==1) P1.iid <- array(delta*P1,c(nobs,nt,n)); } else if(modelType == 'rcif2'){ se.P1<-matrix(se,nobs,nt) if (resample.iid==1) P1.iid <- array(delta,c(nobs,nt,n)); } else if (modelType == 'logistic'){ se.P1<-matrix(se,nobs,nt)*P1/(1+RR) if (resample.iid==1) P1.iid <- array(delta*c(P1/(1+RR),c(nobs,nt,n))); } else if (modelType == 'logistic2'){ se.P1<-matrix(se,nobs,nt)*1/(1+cumhaz*RR)^2 if (resample.iid==1) P1.iid <- array(delta*c(1/(1+cumhaz*RR),c(nobs,nt,n))); } else if (modelType == 'aalen' || modelType == 'cox.aalen'){ se.S0<-matrix(se,nobs,nt)*S0 if (resample.iid==1) S0.iid <- array(delta*c(S0),c(nobs,nt,n)); } else if (modelType == 'prop.odds'){ if (attr(object,'type')=="comprisk") { se.P1 <-matrix(se,nobs,nt)*S0^2 if (resample.iid==1) P1.iid <- array(delta*c(S0^2),c(nobs,nt,n)); } if (attr(object,'type')=="survival") { se.S0<-matrix(se,nobs,nt)*S0^2 if (resample.iid==1) S0.iid <- array(delta*c(S0^2),c(nobs,nt,n)); } } } ## }}} ### uniform confidence bands, based on resampling ## {{{ if (uniform==1) { mpt <- .C('confBandBasePredict', delta = as.double(delta), nObs = as.integer(nobs), nt = as.integer(nt), n = as.integer(n), se = as.double(se), mpt = double(n.sim*nobs), nSims = as.integer(n.sim), PACKAGE="timereg")$mpt; mpt <- matrix(mpt,n.sim,nobs,byrow = TRUE); uband <- apply(mpt,2,percen,per=1-alpha); } else uband<-NULL; ## }}} if(modelType == 'additive' || modelType == 'prop' || modelType=="logistic" || modelType=='rcif2' || modelType=='rcif' || modelType=='fg' || modelType=='logistic2'){ P1<-matrix(P1,nrow=nobs); } else if (modelType == 'aalen' || modelType == 'cox.aalen'){ S0<-matrix(S0,nrow=nobs); } else if (modelType == 'prop.odds'){ if (attr(object,'type')=="comprisk") P1<-matrix(P1,nrow=nobs); if (attr(object,'type')=="survival") S0<-matrix(S0,nrow=nobs); } out<-list(time=time,unif.band=uband,model=modelType,alpha=alpha, newdata=list(X = time.vars, Z = constant.covs),RR=RR, call=sys.calls()[[1]], initial.call = attr(object,'Call')); if(modelType == 'additive' || modelType == 'prop' || modelType=="logistic" || modelType=='rcif2' || modelType=='rcif' || modelType=='fg' || modelType=='logistic2' || ((modelType=='prop.odds') && type=="comprisk")){ if (nrow(P1)==1) { P1 <- c(P1); se.P1 <- c(se.P1); } out$P1 <- P1; out$se.P1 <- se.P1; out$clusters <- attr(object,"clusters"); if (resample.iid==1) {out$P1.iid <- P1.iid[1,,]; colnames(out$P1.iid)<-paste(unique(out$clusters));} } else if (modelType == 'aalen' || modelType == 'cox.aalen' || ((modelType=='prop.odds') && type=="survival")){ out$S0 <- S0; out$se.S0 <- se.S0; if (resample.iid==1) {out$S0.iid <- S0.iid[1,,]; colnames(out$S0.iid)<-paste(unique(out$clusters));} } # e.g. for an compound risk model, className = predictComprisk className <- switch(class(object),aalen='predictAalen',cox.aalen='predictCoxAalen',comprisk='predictComprisk') subclass <- switch(type,comprisk="comprisk",survival="survival",na="na") class(out) <- "predict.timereg" attr(out,'className') <- className attr(out,'subclass') <- subclass return(out) } ## }}} ##' @export pava <- function(x, w=rep(1,length(x))) # R interface to the compiled code { ## {{{ n = length(x) if (n != length(w)) return (0) # error result = .C("pava", y = as.double(x), as.double(w), as.integer(n) ) result[["y"]] } ## }}} #' Make predictions of predict functions in rows mononotone #' #' Make predictions of predict functions in rows mononotone using the #' pool-adjacent-violators-algorithm #' #' #' @param pred predictions, either vector or rows of predictions. #' @param increasing increasing or decreasing. #' @return mononotone predictions. #' @author Thomas Scheike #' @keywords survival #' @examples #' #' data(bmt); #' #' ## competing risks #' add<-comp.risk(Event(time,cause)~platelet+age+tcell,data=bmt,cause=1) #' ndata<-data.frame(platelet=c(1,0,0),age=c(0,1,0),tcell=c(0,0,1)) #' out<-predict(add,newdata=ndata,uniform=0) #' #' par(mfrow=c(1,1)) #' head(out$P1) #' matplot(out$time,t(out$P1),type="s") #' #' ###P1m <- t(apply(out$P1,1,pava)) #' P1monotone <- pava.pred(out$P1) #' head(P1monotone) #' matlines(out$time,t(P1monotone),type="s") #' ##' @export pava.pred <- function(pred,increasing=TRUE) { ## {{{ ### row-wise predictions isvec<- is.vector(pred) if (is.vector(pred)) pred<- matrix(pred,1,length(pred)) if (increasing==TRUE) mpred <- t(apply(pred,1,pava)) if (increasing==FALSE) mpred <- t(-1*apply(-pred,1,pava)) if (isvec) mpred <- c(mpred) return(mpred) } ## }}} ##' @export plot.predict.timereg<-function(x,uniform=1,new=1,se=1,col=1,lty=1,lwd=2,multiple=0,specific.comps=0,ylim=c(0,1), xlab="Time",ylab="Probability",transparency=FALSE,monotone=TRUE,...) { ## {{{ object <- x; rm(x); modelType <- object$model time<-object$time; uband<-object$unif.band; nobs<-nrow(object$newdata$X); RR<-object$RR; alpha <- object$alpha; ### Here we use mainLine as the central line (between confidence ### intervals or bands), so that we don't have to distinguish ### between the case when we want to plot a predicted survival function ### and the case when we want to plot a predicted risk funcion subtype <- attr(object,'subclass') ### if ((modelType=='prop.odds')) { ### subtype <- attr(object,'type'); ### } else subtype <- "" ### print(modelType) ### print(subtype) if (modelType == 'aalen' || modelType == 'cox.aalen' || ((modelType=='prop.odds') && subtype=='survival')){ type<-"surv" mainLine <- as.matrix(object$S0); if (monotone==TRUE) { mainLine<--t(apply(as.matrix(-mainLine),1,pava)); mainLine[mainLine<0]<-0; mainLine[mainLine>1]<-1; } if (is.null(object$se.S0)) mainLine.se <- NULL else mainLine.se <- as.matrix(object$se.S0); } else if(modelType == 'additive' || modelType == 'prop' || modelType=="logistic" || modelType=='rcif2' || modelType=='rcif' || modelType=='fg' || modelType=='logistic2' || ((modelType=='prop.odds') && subtype=='comprisk')){ type<-"cif" mainLine <- as.matrix(object$P1); if (monotone==TRUE) { mainLine<-t(apply(as.matrix(mainLine),1,pava)); mainLine[mainLine<0]<-0; mainLine[mainLine>1]<-1; } if (is.null(object$se.P1)) mainLine.se <- NULL else { mainLine.se <-matrix(object$se.P1,nrow=nrow(mainLine)); } } ### print(head(mainLine)) ### print(dim(mainLine)) ### print(object$se.P1) ### print(head(mainLine.se)) ### print(dim(mainLine.se)) if (length(col)!=nobs){ col<-rep(col[1],nobs); } if (length(lty)!=nobs){ lty<-rep(lty[1],nobs); } if (length(lwd)!=nobs){ lwd<-rep(lwd[1],nobs); } if (length(uniform)!=nobs){ uniform<-rep(uniform[1],nobs); } if (length(se)!=nobs){ se <-rep(se[1],nobs); } if (sum(specific.comps)==0){ comps<-1:nobs } else { comps<-specific.comps } for (i in comps) { if (new==1 & (multiple!=1 | i==comps[1])) { plot(time,mainLine[i,],type="s",xlab=xlab,ylab=ylab,col=col[i], lty=lty[i],lwd=lwd[i],ylim=ylim,...) } else { lines(time,mainLine[i,],type="s",col=col[i],lty=lty[i],lwd=lwd[i]) } if (se[1]>=1 & is.null(mainLine.se)==FALSE ) { lower<-mainLine[i,]-qnorm(1-alpha/2)*mainLine.se[i,] upper<-mainLine[i,]+qnorm(1-alpha/2)*mainLine.se[i,] if (monotone==TRUE) { if (type=="cif") { lower<- pava(lower); upper<- pava(upper); } if (type=="surv") { lower<- -pava(-lower); upper<- -pava(-upper); } lower[lower<0]<-0; lower[lower>1]<-1; upper[upper<0]<-0; upper[upper>1]<-1; } lines(time,lower,type="s",col=col[i],lty=se[i],lwd=lwd[i]/2); lines(time,upper,type="s",col=col[i],lty=se[i],lwd=lwd[i]/2); } if (uniform[1]>=1 & is.null(uband)==FALSE ) { #if (level!=0.05) c.alpha<-percen(object$sim.test[,i],1-level) #else c.alpha<-object$conf.band.cumz[i]; c.alpha=uband[i]; upper<-mainLine[i,]-uband[i]*mainLine.se[i,]; lower<-mainLine[i,]+uband[i]*mainLine.se[i,]; if (monotone==TRUE) { if (type=="cif") { lower<- pava(lower); upper<- pava(upper); } if (type=="surv") { lower<- -pava(-lower); upper<- -pava(-upper); } lower[lower<0]<-0; lower[lower>1]<-1; upper[upper<0]<-0; upper[upper>1]<-1; } if (transparency==0 || transparency==2) { lines(time,upper,type="s",col=col[i],lty=uniform[i],lwd=lwd[i]/2); lines(time,lower,type="s",col=col[i],lty=uniform[i],lwd=lwd[i]/2); } ## Prediction polygons bandds ## {{{ if (transparency>=1) { col.alpha<-0.2 col.ci<-"darkblue" col.ci<-col[i]; lty.ci<-2 if (col.alpha==0) col.trans <- col.ci else col.trans <- sapply(col.ci, FUN=function(x) do.call(rgb,as.list(c(col2rgb(x)/255,col.alpha)))) #print(t); print(ci) n<-length(time) tt<-seq(time[1],time[n],length=n*10); ud<-Cpred(cbind(time,upper,lower),tt,strict=FALSE)[,2:3] tt <- c(tt, rev(tt)) yy <- c(upper, rev(lower)) # tt <- c(time, rev(time)) # yy <- c(upper, rev(lower)) yy <- c(ud[,1], rev(ud[,2])) polygon(tt,yy, col=col.trans, lty=0) } ## }}} } } } ## }}} ##' @export print.predict.timereg <- function(x,...){ ## {{{ object <- x; rm(x); if(!(inherits(object,'predict.timereg') )) stop('Wrong class of object'); ### || inherits(object,'predictCoxAalen') || ### inherits(object,'predictComprisk'))){ ### stop('Wrong class of object'); ### } if (is.null(object$newdata$Z)==TRUE) semi<-FALSE else semi<-TRUE modelType <- object$model; modelAnnouncement <- ' Predicted survival for' addTo <- switch(modelType, cox.aalen = 'a Cox-Aalen hazard model', aalen = 'an Aalen hazard model', prop = 'a proportional competing risks (Fine-Gray type)', fg = 'a proportional competing risks (Fine-Gray type)', rcif = 'a proportional risk competing risks', rcif2 = 'a proportional risk competing risks', logistic = 'a logistic competing risks', logistic2 = 'a logistic competing risks', additive = 'an additive competing risks') modelAnnouncement <- paste(modelAnnouncement,addTo,'model',sep = ' ') cat(modelAnnouncement,fill=TRUE) cat(" Nonparametric terms : "); cat(colnames(object$newdata$X)[-1]); cat(" \n"); if (semi == TRUE) { cat(" Parametric terms : "); cat(rownames(object$newdata$Z)); cat(" \n"); } cat(" \n"); call <- object$call; cat('Call to predict:',fill=TRUE); print(call) call <- object$initial.call; cat('Initial call:',fill=TRUE); print(call) } ## }}} ##' @export summary.predict.timereg <- function(object,...){ ## {{{ if(!(inherits(object,'predict.timereg') )) stop('Wrong class of object'); ### if(!(inherits(object,'predictAalen') || ### inherits(object,'predictCoxAalen') || ### inherits(object,'predictComprisk'))){ ### stop('Wrong class of object'); ### } modelClass <- class(object) modelType <- object$model; time<-object$time; uband<-object$unif.band; nobs<-nrow(object$newdata$X); RR<-object$RR; alpha <- object$alpha; call <- object$call; if (modelType == 'aalen' || modelType == 'cox.aalen'){ se <- object$se.S0; } else if(modelType == 'additive' || modelType == 'prop'){ se <- object$se.P1; } modelAnnouncement <- 'Predicted survival for' addTo <- switch(modelType, cox.aalen = 'a Cox-Aalen hazard model', aalen = 'an Aalen hazard model', prop = 'a proportional competing risks (Fine-Gray type)', fg = 'a proportional competing risks (Fine-Gray type)', rcif = 'a proportional risk competing risks', rcif2 = 'a proportional risk competing risks', logistic = 'a logistic competing risks', logistic2 = 'a logistic competing risks', additive = 'an additive competing risks') modelAnnouncement <- paste(modelAnnouncement,addTo,'model',sep = ' ') cat(modelAnnouncement,fill=TRUE) timeStatement <- paste('At',length(time),'times:',paste(c(head(time),''),collapse = ', '),'...,',time[length(time)]) cat(timeStatement,fill=TRUE) obsStatement <- paste('Given covariates for',nobs,'new observations'); cat(obsStatement,fill=TRUE) if(is.null(se)){ addTo <- " - not yet done"; } else if(is.null(uband)){ addTo <- " - only pointwise calculations have been done" } else { addTo <- " - pointwise CI and uniform confidence band available" } cat('Standard error calculations:',fill=TRUE); cat(addTo,fill=TRUE); cat('Call:',fill=TRUE); print(call) } ## }}} timereg/data/0000755000176200001440000000000014666545364012642 5ustar liggesuserstimereg/data/sTRACE.txt.gz0000644000176200001440000001676214666545364015057 0ustar liggesusers‹]\MÒ$»mÜû_Ì:H€àÏM¼•í'[ Ù É?Ç72 €=Š˜7S]]E‰Dì_ÿù_¿~~ýï_ÿâöoÿÓßÿûoþ‡ý?»ýÓ¿ÿ¿üãÿÜþÛ_þô/üýüãßÿòWüýÿüù×?ýúç~ÆøõûÓ?ös~ÚÏŸ#þ¿øï£Ã~š_gkë¯XÿK\ÕÖøô£þÇö3?§ó²µýnn~ÚgófkÚî¼¾ùå“Wéš~3X|ï`öëટõ±¡¼Nެ_?°~ÝäM¦|ÎYüÈút¹÷Öû¯X¿7™ë3ñF~Õø˜ÊlSý×÷1µ‹ø¸­·ñÿÚ~߯îu6†ßÖ¯÷AåÓæŒëìÜÕém›¯¢[ËÃGØöÙó>hû´1NëmøÊŒ¡x~|Hvó¹õ›ßçÆ’®Å›ûj5í}Ÿíë´·íû@2Ž?[ÿ̺+ìëпȩݕó×õ‡õ­»&ó³÷ˆêë>¸êÂB¸å ÆŽ-Ó¸nܯcn_`·|Tn„¿èŒý:ëîƒî[—Ùú Ѹn{Ýj¾­nüª}kÝ'òÿä³bQç˜þ þ8&þIÏg扞ë"«ûWÂòftÆóÙCÂEäŒû\lXºfº>†u÷½ÒðŒ3áþn÷ã|ôìøÖa÷ª>[ç6¢Æoáë'ÑÐä~éTØð_ºO-›„#Œ3ý`ý2á&Øþìu¯sµ‘×u^×ãÙüªÓÒw<›É†Ï ¢Î¿”ÏfëÚG,–W7Ö×ml=7ËÎŒw˜îrýºÒ¢+­jÞo„Ë©¯Ž¹“öã›{ry†byÜæ"Ú§Yzh¼Îòû¸;_ºÃóú<ñÒ2GOƒÇ»-¬p×Û-aö ÕµªkW¨Nõ%Þù­í:ŒÎ w¡ïï`¾Ä'fŒ»)þý~?ØŠ´-õ|Òñ|]ůƒwu÷;šO·#m6Å-ïÆëÖG5€‹ëZC¹-w–íK,¼ë“/a| ã¢tl©‡s·o};ätk÷I×òϸ‰'ðp'›õÞ0sô°ë#ÞÇ7»ÉŠ÷i3W®›WyÒØ&kÚü+aüýËÍÂŬ ̓›z²åžk#î¦Ýa +­ëaŸ;bÛá1; A8Ât‘ð+ÅJ]NÆæ0 šÕ:{0uÝ„²¸ÎìØ¾³£2Îq3w›‘1·ËÈ`Áþ¥ÈüÎvNä)À^,0yãù“×80ØæÜ}²¹#›©Æól^…Ðεhä}"ÀúcÜëðXwfäÖÇv/t$Ò3-ðèÀܶ¹ãÏ5QgäÐÕáƒnùΑC—üc÷ˆÄƒ.âŒdz–£¹mžD§ƒÍ)ÉôÜ™žûÛt@ùÝðè± ›è6°Á÷ZeXzk^7°=ƒ#xÉÜô„À¤ X‡}k¯±Pw»7iÁÉ7<ËÎ\ßµ[Ú÷nŽ‹Æ¸ö¿ò5…­ø7OS-Ÿ°{/Üû— ÜÇE’ËÌHgº™·÷Jœ (÷žÌ( v¿j=üKW@b¸eË,¥¤ƒ­Õž`÷Éøk œ¢Á—î.2…ûd[îUÝ_Ý=Îm¬éÇVÍîr#¡/ÁU Ô ¨ÇBD©'ËâU‡¼êTÈ,'±qîæÁ;öœØçe•¢”Ñp½|œHî|ö­îtžÕ“Täýæðë`ßÓ93Iç˜-°" ›(Ó«+êÙé;@qlš4`Gs$ÃÞ7d¦&žÈ4WnÍëIE}2ñ:¶àXt¿î)yz>öòå‡à-³h™«|T2¢É[˜òpl‘F_mÏìyë€kQCjT¬oÒòãi=_Ûàcã 1IÜÿ-Mð7ÛJÈ~7-.~%™Q´b£„h÷v+öx"mDÈt GË*”iv3o¦ãøN_‘ž.?4n¶A>`¯÷¥éÊw¯W÷&j¯$¤GÜ,µÞfãºkÓ2L‚¶î<=‚·ŽOÄÜ@0 ÄRlÐ;2ÜÆ½´Á!V{$søêæúõ¹T‰©m@õð2†¾8uñÄc3"el¼Œ?òTÆK?‘‹6âöÝ|fÂ÷ø üèfØ—0ŽGI=h$ÝÙqf<® Ŧä‹3À“ó[ÏÝâpWüå1`ñ”wï.ÃàGnkë­zñÉJo¼öQ,¿çJªæVq`°q—ß|#ž¶{v”ÍñÒàðL¬A%fTÐŽUÌ눦x{Öe™V{ò‡^¸8s¤óŒB°ػۈ醯Ý#cZ"› ™»­µôË£<‚v £¸`<£Ð÷ð\ßp÷Ó‘ñµ__%žârÂÛlÉîDœ¾äûe÷̗ݱœ•eµÄ¾­NO#)ö ~ûð«_x½4Ì=ZkKì9iÌ· ¤*WÑw%ª÷µàd^W«‹,ðÁ âë%*ϾàZH‘ |£%mùÕX²‡9hTàÇþº¿xzh»ZC†µÿ¡ *qd@€ý&ýT $óEAð¹å É^'ƒ4¾Uà|Dò¨¡"4i}Eò†}÷²'yž-¾¶äGÏôø$¼ hÌý"²G¥4ñ½öÇZîE¤ ØŠc_ïS…ÿˆ\îÕÒ‹ÛÉ×>=áx†ÿIÖ|ˆà™ådÍcìS¸$Ú !‚ô¯‘nÊJTY‰J²5I¨7HæDr-ŸRT;‘ð-j½ŽÈìbIN22Ÿh¡û8¤Â‡Tø²{¸ßÒXŽ*µ@ÆoÍ?3ïõºÅ’»s»ùlTVñ`ž+V›‘›vòn(KnÝV‹u¦‡%·Lh‡°ÅC€±ªÕ¸Î‰óDêl3¶Êï6N’ô^åDUHW¥Ê@ ])¨DÈN.ìœîÜVÝ#%0zóÒ‚´3" g®çêÃŒ €ä‡‚1„éŽ Ég!ŸVÊÔ$¶ž˜´[+uËÃVVj${Gxw ,7Œ·wL'i‘5<°…á-q™B¹œYwFèüÍyFÔõ†D[ %D ǪÝóSš¦À•((%=UÐRØJî^DŒ) Aâ’%l!´ç¬pd£Z4ä¦ddxéÉ«ºduŽË`+/ÌéeÝ † •”{B}aP`¸Wù#ÖݼüUGce!¼FPvØ'×ønWm+=|L>`Ÿï¸?kÖ'ª!Ûz5Hèû–žò-u„Ö³¬C¦ªÑéåg‹x¶úaå}R^[UøŸ¢ö@ÂÖÝ¥[ºÿ–¬‰&…œ—€; ž‘>úQ8ÿ½xYkÜ+œJ™‚•GȬî$­œj¦Bx¨žVìjã~Yig+†Êöa³»‚Ý-~g6ØÌ»•ÿãeÇõk-¡Æy:ѰŸ×½ °QÚ¿Œäj—‚äð—ôÓÒû6$0ØB?R¡Lä”É èŸ_6àhÚ$ø|eh$ ¦Œâð½”b üð#3Ð/³ó´—·jH¡ŒF%¦¡ØÙ\)5µíKÐÍÉPw†3‚>-@W§ •=wúžŸi^­YGdê¡ît‰Q#1j¯¶ÜWxùmµ”ÀE!°ú(22žtÖPz| x”wêÍN€© È—& TæCbˆBPx û²“#×΂:3¢uû}¼Šm8©5½éZö(±©“™hs£Æ3Õr®æõ•S1 k´ƒdЀ–Y\NH Ac œðK¦ŒÕM8r¢û‘=/õö?&!O^Ø·/ºöUhø¨x™"©sð•.‘ÛA; _9&*2Ø·äû³’õŸ¬0×a[]–8Biëæ¾]¢ä!O?¯-2'õPUOÜOÑM„}µ´GÅ΢d%÷Ù\¾}FíÌ<—­Þ¬â> §uÖ¿O±d"؇ȷ|Â×è£ë,ZÇ-Zwæ¿•¬‰+¯ûsPÛ²ž”W{%Š^`¿``,lÝO‘Nz¦ÓTª˜)aÝ*ñwkRdžVL8Itqè,¯D9Çaòx¸Ê”^®vŽéž>oüË;€}(ù1k®.éqhŒÆ¯Ž…ó¢þÅñwsêxœç«Ú 8©RÀiÚÉ<$YhƒýÆÄõO[ÉT6nƒ½™’m$·ÌÀv¹åw¯Càdó€qûÂç*«(’_ÿe§¶EÁÑÖ{O_¥meÓÅ6ßa/}ÒȺ-0¦9=)mÅþÍÓ©“㎠MHø,ÔÏ|l#¹›y…bÊ9žû¨Dë‰\ä¥ÄÌÕ²~Xáè¾7I+uZa¥¿·³Ìá9~z&÷øŽEhüŒÛIQÑ¢NsPÈíf‹yÏ׿sø?³à?\©éôd@†g²²²÷*Ä,ùÂ,û˜å ¤èjÐ(a__¸U'wUóéBÑÎZâò·Y-ÍÔ)•Ññ¥ŒBˆ.e4a`3«¢Æ¯ƒ`Œë ÞE)ÙQrÂ&ÓCDe¶O°zÈoÏ aÞ+¿¹2ogòPŠtzEºPmg¸/FFŸ ‘ ›w;5rF©µ¶¦ =÷(Û:˶^å"<3…^9©&R‚¸r@Ôâ(&Kcʾðyý©VÚŽœ‰ùˆØã‡E/îvjzòÑT YoÀVF‚êi‰:½‡¢‰„p)V—ÃdTõâãízEIií®M曋 µ^¶ZÍ)r’j e,ô±Ç'PQ®ˆåÖ}©§‚æ{€§»*::ƒ‘t £z5á‡Ò‘fÜ>Õª_áNl‰çR%‡ýM¼´à‰=§z|Ë•]i­Ä>Qý‹; ë‡\= Žè€ØEæ̼CK©Ø5;ÚóFõ²íuâüÁN êƒì¨vöJû.¢kHT5ûåqÑ}b©§çž;r¢QØËíñUMHAµs1cœIh'¡ÉØ“hô Ø*J<âLS­v'™ª’©V ™‰êÓƒ{~ÄÖï&ߨ;K~BtU™A©rXaË%³C¸nSü.Í!"«'¼ù­mä(Hjiÿ*wÍù¢eÔµPÓì€÷ÂÔ`‹w>j à‹°¯vð]ÑÌð£fw ÅÃ>}Ð+¨QÙÖWx¯,v§K÷—½ˆžÄ L/\—øR¶¨J –n/HËÑ ÉÑ݇Íttø’¸O¬j8d•FN¶¾| £W±Fk>ùöÝlqNá†ÞŠ/µÁ’’t¦|÷ëY)Wœ¯¯Ì†Íuª\ߤ£[¿u¾%YÓ `Î7”|°Žz˜\Ùdö£#faŸ8½¹XÕoÍH[´.ô÷USp9Øåå;Šcñ¡fxe¦)dÛ¾/cAê[‰`•jXÍøEoÍ7V±ÐÙª~|6t̘0L Ä+á¸_5·²µ®_ÝRÿÃN«úÿ°Ñ}Ö«±A½gæÝ‚™ †yVaŠYRzB&y¸4M«bŒ¤J¡9 ‡ä)Ì.¢„ž ï|ÕªçCe>’5§K0#4ºâæjxQ6Ûòæá5Š&ÙÊcêêç±&¨Ò’ã O oÔ½Ú®µôx—Bê¹ßlõ(Øà iûZrX;ÕÌðdgÃs—œ±Z’”Ï:õ³TßÒ _­píÔzEàÿÚ23'´#Øœ;‘JZir67h¿IVtqâ:)E}ŽÍ¢’×iáîɰȪ’£"vGEî+@²„qΆÜH :~ôMHäP«IO}Тö—ŠÉß3²ß¯cé·ûLI!ÞAØÅ‘ÛÆ‰ÙÄ}ÉI¬\æu7Òí7ÏLl-uxØzˆ¢3; YiÆ’ªIæ?"Ö˜MëPöU´߆¸y?Âs†V*úVÅ$òF ³Ï‹›‰×M@Ip†Œƒ˜˜Z5f½-K¢Yó€ŸùÊT”k£†<÷¸»zM+þ\õo[ƒ-šW™ŒIøŽÃsÞêSs ÄVÞ3Ûê!Ö<˜R`dÃ÷ö{µÒ„fózEÑ (.ìk®Ç¿¾æzNjqTÎÇUÎO&ÏUT¶÷Hc‹m²5^ºóbeEtù_eõ¶7eì#î$?³¸ÚG7N‰™Œ]+Ìpòº¦Wzî”cú•cvjF¡Ä$Öä„,Fwª@Y9M&îKó4qŠ:"ßzìm¿ê ú°fé¥ì{P¼n‚ÏÀ3üfžßõâžowVÈŽ•r öÅÆéJøi)K ‹èO²ÌR ¢÷CXC" 'o4‘s›KgÙpa¾Úÿ«Ô¯Ûì\‹ê¡:«®Éš ¡=û]¢Ïô´&Ì'+tÎT¨žšQ-{ Ž*iÍ=Åú®4ÓŸÓ÷©yéBž!!Àæäºò5Üg*ö”_ºÛVCÅòˆóPŽýhNè/©‘ÏÅTS Gýº¬ïuÞ;YajÌBŸút"Y·L°`_ÈA=ÌÎtÛ5 ´8 ´‚I S¾uñªr¢máä`\É0\ûÐÒ¬Dô< æ‡Ü¦G$ã!ˆ”pƒ¦ˆ²ðWî×OLykf¤Šf“nÃq’Ôª,‘B Ø 3›l&hˆcΌϜ¢J9Ts2Ô ÎUbcN‰í60TA67{My·–ó{(I`_忳mÙkœÊG+`_¼ ÷è$„'GÓFçèoÿ%ôsê”C.œgaM"!Rn¡™gì$½TFÐ7mã\>ÓÏ$™ºÃv°¥;QQ*mÇÙ{ïͬf(3iÁ¾£'V^,eŽKŽKþÄ ÝèyU¶DàõÈWBWÎp©Õ<[Á¹Yrx‹“Õü´”!±8°?y\jGØÞצ6x¶bÌ/n…§›É­ÆÆéé%kÜ{N匾KHé•÷fuNØÎ³tâ;mI_l"FÙvÕÕtŒžÚ̈QoO/<|5Û7®ñ­½wÎ_ôwHÚæÊqŽ,t&ç4f/áˆoÞ+‹öøZ7 Š…/MúTDÕ¤™£¹S¶S‰œÄ`Ù{jÏ5c9R=9Ÿ2k*ÚDVZ5³Œ­AkåÁ •WöÉã/·V„?h%åpöë©vDÏz Òy‡øÎtŸ³éØÛ*&HSV¬y|L÷ØVµ† ÏÜëöHÐdu¾3ã©V[ÑË(eÇçõ…¬Îd¼²» 'D_K}à`ÜMòX §ŽfN­‹#óUÓÙu ?Ï©W~Û™zdXÍI‘}V;ŒÇ.szÓ¯[YœÂ­ðF‘¶Q6HÁHž§$5ÒK¢Þš5S¸jþ½SYï<ž”¼x±c’–¡w ž‘ýqž°{xbeªxEDêŽ I“äžì¯…‹×C†Ó›Žš5—0Üë›¶æ„äÔF ÝL¾ÔDä´QµAÊJ‚ƒ°ßE–f–΢h*Çî´eê‹28Ú:5æï¯ÅÝã õ_ð+‘E…ót²ß 2J¢‘ÝŠœ;9Øî3¾ê°5§XbÃwð°ä¼åéökÛA§8ì²ÛÛíÁáüXhù*Ïœh¡1ÂSê4KT^ƒ©îTS»g—Õ_4§Ì³6Ç·ÁY2VG}¥’ûÁG£X˜f‡dÅÜ/ê/fÛÄ*Ëœ9ü-„ßî‹äH Î¥Ùš_ã{ȵ£)f±d·d­£B{\WiÔžú…7žÿ•ìŽ}Ññò,J7Ðx ǭਠi-Ý‚é̤½¬§Íz£ QÎ3É““ÑE?¯ý¼PAñº®'OÛ;uŠA“l{sL©-­ôˆ²Ö²0È‘qëL÷§,ø ïX€}v66ù;c¿Sñ‹ !íê²Î縟_½ûáESOr»²Cùÿk–½ñ\CT"yn¾!yÁ>UÈJõìƒ<Ùpvž À¾NêÙ=R Ô{*pæn¥¼½ê×,fcG¼ÙËç¼~ö¥4+ªiЭ` ‘B‰ÿý~r8ØrÚS¸ayL<=Ý£ms¢<þo!oB9Š×9&åÁª0ï̦}ìÆÂÆ5²YšGuMzþ¬Ë×(½gKoT“Tž!Sž!˘’vùæøX01áaA¹‡ë—8xü‚+†zx{YsDläØê‰)ç- o¹Ù¨ßl˜ÆƒfúrÒfŒè9ÕeQvY2³Þ3§-_:‡û=Š„]›d7÷„oE£äøÀàô®ÛªúðÛoxÛYƒ£¯#‡tÛQ;wãà½Ù¨Dë žãs£~©ÆSñ`B¾“lë>¬É;m›Ûè'ž¶µÆ¦\ÚƒiOºñšàˆÆBšå¬-Êüšü\l\®³Oâ6g|éyV‡9W/ÇìG–÷wû£KF’E^tšÆ_7á¡®ÂdmI‹ÐPb»BŒÇ7¿6\¹%ºäïwØ¥=•­#b(7ê—ˆ&瑾xL@Ùõ™™?ùê1î,Ĭý‰3bhÖ´£ðXôY>34G¦ª`ØÌ,&﨓áDt²'ј`ç‰ý}"Äx–ç&*9;îlt÷1[Z–:ÄÁy˜±^16«‘”,ó[gƒ:†™£º™»´“Ž*û¸7{T[h‰Rk¿R«%EÐUS…Á‘§ð „Ê7·¢f©ãÙ \<¾åbO¾RgŠSDkˆ=Ød¿#QÖÕENµïã<^ WGzR=äA½ÓÙ¬žÿR´·±c†ë(<ù™=v`ýÌWÍ´ÚøóJm}©Êñ+B‘~§–€g•S—sQŠfÅ}Q¶wó$]£è~2c}Ô²ÛeÜžî¥Ã‰¶ãï´¥qÖ©.G£4j÷í÷{ïÌš_£Q«˜ig¼¡<ã¢Í¯éÃ;uéUJøÎt9­y€äâp2YùKAÌ>våî¶uÖ¦åáÄ6ľM ûr˜,—Ì6ûoû|—_¯ç¿HÎ~-Q¯ ¬å¹ˆÖÃ;U‘þ¥´¡ I™(7ìV÷·¼_éórò=ó˜îX·ZZ¹qî,€È"ž‡54æ·…e¨ò‡Ì¤”DƉ¼¹Ú•"ѵjBKv:!3+yßûQ€§5ŽVsp¶ á¨ÚÕÏP…Sƒ¡®\äßäE´}rú†½#Û*â“Eñ﮿²2‰Òõ{!<´`VcÄ–ÿÈttZOtimereg/data/TRACE.txt.gz0000644000176200001440000006664514666545364014701 0ustar liggesusers‹]½K¶D9Ž$6¯UÜ ðÃøÙ‰¦%uµº=êjIË`€|©ÒaGfzøóËKâc0þùÏÿöÏ÷Ïÿû?ÿS×ÿõ_ÿþ_ÿûé?ü_ÿã¿ëúïÿ÷ØùÿŸ®ÿí?ÿýÿüÿúûÿë?ÿ§ý÷ÿÏÿçßþù?æåŸÏÖ¯þÎw¾òÍù«uè?è?þZ__ÑÏI+õŸÏÖ¯é§ê7×oέÿ ŸûmÙøT›£ÿó٪߶?ý/¿Ñ~Íþ£ý+¿*Ÿ«s®>[õsß·ÖO–ýyýÆ_éó«ú¹uþùô¿¬¿‰_&ú¥³ãoŽß,ßÕ{ÿ|¶êç¾`öŸÈÁè¯þc ý6[õsËŸaè/|ßúqâê°g¨;b_ÒõíŸÛ¿:›?CYMŸAWü]û¾Ý~»þ}†*ܹÓÍúÕüœ~‹ï]¾wsˆØ›À§ôi㯮_Ùþ©:Šþ:[ï·éÓêFú_]ÝÝØö¾lÕω?íþÍæOkoÂw¥7}ºà}áSå7ψßVªja/bàSö‡dþV«ñ]RüSíL}[c窥1z<ƒÔxRÝ }R]ãù›í=¾o×o¶{³õ|þ)=#»J¼×ï_NÕ¿jkîÈÃÆQ’±ìcºêݯèõÐc¯¯ÊVþoÔ|ñºe{Æá=Ýï±CÞó1×äcÆçšî¾n‡®ïÁ,˘¤oÊ~¿­|Ê®ÿS§l-¾ììf{»[ÜýÝ¢o{áêyŠóÑÇÑÏÙ»¡_¢ïÊ^‰þŸèãÄÞ}R]p·ð§š¾wž¶:ü쎹õxØšçCOÛÚþ¹þ›ñ±Ò슮_š‡¶óuUUí„îœY ¤Ù~2¸Ãqú’©?N×kD­ÿP»³ñuÍþ¬­ú7&Ÿµ–Ê?;}ï¤W»ºæ ±ï“¯¿Ä›¨§êßµwL÷¢íؕݺ?nºÇ¶ÆQò}x¡KˆÝìëtýüíë…^‡Ê÷:–‘u­oûuÛû¿´I³6½ ¶†íÒŸÝGü—é¿7°Jµ£©«™ß=£2i{Øéf×ÞÖxa8u=w¤…=¯ÇÞ¿­xØÝ×–6óøÎ5ÁÍÜüxMö-ñ±YzüÙaÓõË‹ Sï¯kwÞÔ‚›Zðºp8÷¯º$QÃoÛxˆ‡˜Øá¡˜F©…Y­ÍÌjmùRÕŒ´Ø:56#¾m»­ºš?ó_§·µÐLϸÕÓΦ.iEtƒñÜØÿÔ8fÌm¿Zísmõ¸ÖR$^¿T{ÿRãFèµÀ§àÑ”Ö͇ôÜ^¿sø©û;NŸöWmK‹×zÉᵎ=‘YtOl÷°Æo,úÕ°$ËÜÛZþ‘b™²xÞ*½‘Ý[¯íÝz¡ùJÏŠÖÌdÚš/A ÄÈÛÐh mÓfS7´„%þ8»zJÍÂéê?ƇTnŪq,¬±5žPì"óç_…p¥{¸!FS³Ñüù;ê8gÝ_2vˬýˆP¥§^6ûx2ÚoÌ|“tàÇΣ­á=ôon½Àt~eÖp~öÊmÅ÷K³î¸Ê³Ä“ÎUÍ­zÛüõ•·ª†±ìv“ûº¾Hÿ·xé^ÄŽ´1-€³ßó¨¯gûmÉ@!£”÷4Ö2y£âAeÂá«ÜŠï¡‘J‹«¶cÛs*x ú'Ëß8ê´SÇ”¢A^õ§Dqƒè&XÎï¸Õ¯±`}š Ö5¿[pé#B9•׫á~µü:;{=ŽØ¯ÇÙ“6ìcã¾:½^+MºÛ¯~ÄR]3€´“Ð3 K²‹>‚.aZqwñFZ8¯^ؚ̒ߦW K\°_²`‚ßDx+jg¢—â!µú#Wº×L·ä„ ÃF¼å…ptݰêè¹ê¯¥ÅíXÎ6'Þ„^ÃÁï Ÿ.Òã„áïëÄÛj3r »AºÜà@Evfië©Ò%¬´þúò³ãêF‚»V»=d—ëVǯG¢÷º…»\[_­üYjç;ýx/ ìCçäKW/3OcT×°Zb+í¥FGùÌ\‹‘¯ ò¥ŸD$Ò…F‹@I¶]j[¯½lêïÓÈѸSýõËŸqØ2G¨–"<ÑîÛÂË~C=;t ¹º½m[¯ñÕ¨!_\Vµ:ú'm½¡ûÉ$j?£}nxå§QC©¾vžžå¾~-{åëM,6]s¾Ìƒ¨F×¼zïfã+è]hÎ'ÌùÌÏ5ݵ1x„Nä~àèù½6Ì4û…ê¸P=Ï™nCk4ÄV;h¶¥ìçÑÝh´ÝxýØ®báÝ(3Òf¤£Þƒ¡=|ÛŽ·yÜÊaÑ­ Yöèz“±õ‹XE3†Õ"ôDn·ÛÅ;߸äabƒéÅB[aü"¥é9¨aqåalmÍÏ©a'¼p- g²åST³Z«3-^…÷Ên‚­ïK·ìŠ®%Rì ¤cé4¼ 5þ¬F‹¥êšI…FgSxÖ#òV-"×õ]Mþ=ˆXÛâöS^ïÈP·nlFƈÇáFFqmGÜ>Ð?f^T×»%G¿/¬Îo…lvûl}S-tÞÛ5³õ†JzœfäÂèý\¸¥ëþY»›3üǨ~K›q­¯Œfô°÷åfGßÜ Äé˜Ç²UY$Pñ›ðW÷‰¬R*r»¦ñ}ÓòXÚš÷¨^7(4ô/n¦á€a1›Ys[_D¬,FrmÒˆàœô@ÄÂîqÓ™ø\-æt}#‚Q™V.ÂË^š­7ÑPñ*zOÕ(MF¸ŠªÞ~ª\˜D£pƒªâ_2æ ÎA‚sҼ둮‡``é4âp<·\x”VO\õiÖÝœ.ᔕ‘sÁ¹õ‹nÙ‹­×ý Â ß F­r,¨’#7;o°B‘ï@H‹½[õoH:ð‹HZýY—]‘Õo¼§ëš<\S<º]†ƒ.‡Û®ê©‘úv73áÐ2€zZú9´0¾âÉ"M¶^Ö¾-¾¬#ê=>bÁ·µ«š iš,ö½Fxæ‰f"¤YŒ: þõ«P´æ™ÄLjïô qëÁ>xÃnjT?hµºxD£æï®–ü³›¨„Áyq^Jµ«bøª;[5 'šæÎmÌôm}CÖ,…°Z ¯ù¶ÝwšO$v‚jÃ_ïœ-Ú ³9²lQÙˆ d÷âÜ8B_ÔŒ«­ï½ÒhL›·Øy¯4V5œŸº³ §ÆÂ‡n†eKˆ.æ³ý!­‹Áƒkªiãå?¨Žœ ã¨=k…÷ÕR4$†æ\¶ÔÜ0ÚßxÝ‚ ýõ½¼­ú¡§¶ÿz¸‚ ÄÖkq†þê¿LF*ö–l½¦[/·Ã[ å1ñÐ,Çlz5ÂÐS[c«ÕÞá¹wÏ¥vêL&Z…ö^]‚Ù³^Ò Ë2^;¶Â¿1öMcÛ"Û’-¬êÊ8_}Æ!z„P‚¥*¶¦í–ñWZªBAF[ɪ…îZ5Vµ¨[…U^…a?ñÈi4î.¶¼f¥¤ œ˜qžÍp8î\†· ÅÉ:žUÿ!’ç'k,šeúÖï™E†n+ >Wê5Š·0"< f¬™ûyæiÀdzƒøu¨÷ˆ×{ÝY<ÓuûçVÕ?ºê=÷%BU 3Ð Ôþ¾fTÅQb5†Ù‰܇q\‹”£ÃþøÆm³þËrNÆ…º3gÇ‹`–gÉQO¨Ѿ•¥Ü¢:÷ÓPÿŠ2žÓªYÜÜ@âô«y‡Ô¦ŒˆíŸ2Y}WëyÇWËÔM/P”úÔ¶.XØç%轸qr|ŸÁlÙü3] l"ô2Y¸ÚZ»»«¶°7† Å£€vð¤7ðÐc¹"]ò!¬E˜ìèvf’8ÑŽ´cØÛáËš¿rN¼Ô-qz­ž6w¹Q¨%A‘ØŽ&ð$Ç´r{ ­H‹­w;ã¶¾µÎA“Ç*ä†ÛòT+õeOÔ¥ÇÝê¨u¯-ú¦“)t§ãD4fkæŽzJŽ.ý?«–sW¬’'^ɬn‰Ð.õFÔl6›j±Z^K¨%LülÓ¶O×”ácO"'Ó3ËYǃµ¨»ž‰ÔÜíwûãÊ4ÕëD%ÏŽ? £9Ýh¦,% ˜™ŠŒ‹=0¾‘ñ*YàzyÖšÕ"=½Õ‘­ Ò&ñ´)³ÿ%Q»Ó蜙äAvjZu,ö¯…58°Lø•9òbZ˜м >Š7=ÌcØšq™•Y&ÑbÃö}'Í €<Œß6™‘Y8ß èåºrµµ+lwË÷\KùiOö§[> îH†Ä‹(ãÖbÕMµÃ0O")8VŠÅ3¯ tøûCqßÞŸÝ߿ײIì1“:ÍØpŽÌ¨$}LÇD­sÞtnX8Ƹ¶JÊF7‰dšG$÷žÒ#£RÂçúGÃèf%}[obVð97U…`ÃDia.+‚:¼¿Séds8–sBßÂæÂ‘¹QùØ‚£™ýç  Bž—iò²vâ>%«F¿¦âË*zq%n*7Ym)ö]'<öÈp¼‹³ÕnV[*ó¤1¸¸!ÍÊx‹¡’×;žÒ^Á¹È¢Ú1™Œ‡ˆ|Ê´ÁÖ»c‚ø*ЃJ»hOik¦ä–„}ªŽ#à—!?©£eL¤œ]qžPµb²JO?€P•v»áTNîÇ¢/‰¿I|ÆMܽq¯Âù]šL#Ön‡ÃÖ6髪tÌ)¨C¶&ðbPgu ¯ßšICѤeÕDßA–µ+}³vfï÷]yµô/:^a«Áˆb6bj‚ ñW·a¶Þ÷0~q@ä¢s}OâöÌvo«hAvð~áÀé‡wL@¿ñãèÄŽ½,A485fÉGDQ?Ë™"Ðtgbù?mH™<¾YÚÊÐ AðOíŰUÄÕÎRÜ´Sv|[[H‰WËÏY®¸hÈËL ¥h©ßS®«2z ð¾‹dlÍ®ąÉ<æßºû·¨cë+Ë*üdÜid[3¸Óø– ü÷ÈÈê#¶¾7¢Ü4lh4¥íhLÔ¥óÙQ@h‘¼a/õ}d@”¾+â§AáÈïÍUÕX¯¾Zë’7ϯ޺”‹ý7™<ú24+].íˆ`Ò®0ò,•g¬ÉÓ¤‰ö&…pÂF½ Øß>œÍ¡&g0;'Æ)ÌxW㇞@¤¸Kª tû©åR ÃÒÙk,Ú:MÍô9' ²§ ¾ˆì"³9D:C)Aü¦kz².ê#2èŽC3û°IW} p˜2%׃4·Æ–Ƌ̇³ÔÚ“ÛzÝìdŽ ð»ã>%öHKÛyœÁôÒó¨‰Ê¤¿3ê£΂A[ïµ<Îú“Òɪ¼ãõõ (¸ö°¯Ï£ÎðS%“ AXzdq¯UÒ$·ÌQÇ­» ³Ž¶æ+6è.0W¹Ì˜ÓñVû=Zá&*·£Ð¨QsÞÙ¾á¨äf/þhG¡¦Ã¹7nÈ™ :JXnÀååáêéíÎ+Ø#K­Ë²q[¯1‹Jþæ’4ð(6à0×S?0 ‰V¼„úpºvM°î‚;ú-êv€ã1" @ÓÐX[ÿƒ94½Š^¢¶ÖK–´7—BÚš•Ìê§ ÿÆCofݧ#T·õa³´ôð­§Ç€ÿió^Ö“¹ö“ VÛd[/ cåÔ¼Ô¤a™_´ïˆˆ÷"ŹÐpÃO5ú©ÀÞ£‡ªKm͸E:²Áx뇼TË¡m½—ÑèYÃ-•.ñÀ%žËœˆÓ èm,‹m}?Ç‚dÉÜb¢Â<ÛÌ:+ŸŒFºEæ¶f|ª/ Q®_ã€-5š©Uæ¤Æ'ÅA>/¬ž`D”¸‡¹>#жÈ÷¶…»ŸÃ)¼äu ¢:ɨ\s‘Fg+D‘‘dV'ýF9E6 2Üu·T ˜w¦gĉÜýl ‘õWÅA-W^3#¿í4%õ·5ixÛÉéÔ@N€ßva&•E³¶yŠèýíV" Q =އt<Ýö"5¥ˆÚG¾3µ#£ÇÙܳ dâ^ÌäêÌä0´—.ªg5r ănž÷*<ï%®¢Õ†×5ÙÕ æ–…dpBû¡oÅv/M¡X£Š…þÙØ:IÄØºÅ`¶ ÞRŠÌ~È·mã÷ÈÚ²uô&¤LƒwlýÛëJP„ÜA€'½=ùóÎ,×bØŒƒì³nio`K­“”v¸vqªGžÙ“GY$Ìm´¬oyÝT»í«Qw 9¶ÞJÒöà ÌrÄ¡ÜÖ»ÅV2r'ê5/7ÐÀÕõûjOq h"²™G Àe ^¾²ÜU;º+<0kÞ™Úô¸€½XlÒÑÝM>«t“••¦H°ôëü’5Ö$‹ 8?uZ8Ò£^ðW¥i5ÌŸA›¥šÀ¹Õïi4éÙXeÕbˆª­_ÒÉÏS¢¬q@îrnWx8}+¦ªf`ŸÖŒÅš‡Æ]YƒVV¿¸gQlGjhajý{q°¾?¯dÐ~¢‘ú ™ (¡¸Ѹ1ê6ë! LoBû€˜±k w^ygSNců[Ƭ³3)´OE2Q±Yp{2¶q˜ÑÙÙ÷ƒg'JS®íL½¼:70†} S}ƒj@Á÷ƒVñƒú^F"#`p¹¸™¥U½Q¨Zº§HÊ&Æ€ú¤­(ÔSXž¿ÔP‚hé9ý{ Gãöžó4Up¯+bÇlaØùëZMQ¼qÅ¡Lƒ2‚ÝÞ7‚¸­ïKv0¯­÷tîZÔ:–M>¤Ç (‰C¼¢‰¨ ³ÅŒ†­KHL1C`ËÀ [oxhŠ*|ð(° P@( ¼æ¦ùzÏ}’;‚k/â"éê‡Ç¯ wÍ×î­üT;)ûmÊ}[™ ½Í„¨b­ãISelCDoÁÖèÚGØ5Š“Cœˆ×5JÔ éL‰jè>iÞ}’™]ä}C)Ø•…À3XOa»ºt ê½Ü6yô…°äÌšŠD RºpÃ*ÄåeY¨²®˜¢á›&ulb­º·…/з(-i¨°ô¤MT›lÅÞ/¿_’âtdÀ»#v+'j„;AsöóW€¶^Òà àCЇ4d¡í¥Œ˜Ìv´Yaépˆ½_Ódh_Òã( []÷6×JÅÉžE±P:^O?¿Ub#{Ÿ(M=í/ËŠþ¹›Õh¼…¶érÿ(Yg;S©…^-'l׎žUÉúŠ4€Œ-Ddàå´"‚‰gj"¥[øºâŒŒ96V¶¬‡è’’.k“–‡~¸Ô9tÈúäëoÅ~ÔèGãn¸fU ¹Õí§2*nœ/ˆiÀ^BÄÆßÊzsÑ×obIC­Èê”NŸàîBôð&=;wIÃÑ`õ õè¡jÜÂî¡zô*mïÅ.MP£šS£Fr2¢gÊV4„]« 5(lÁt}ËÓeeÌÜ›ÃöÉáºGöŠU·šm~¾°rž](çdŽ^¨F>¡3?¯ôátÕðK@ò«¢|ž2@sDáoZ DiÄÆµ1V3û¦©áMS·Ñ9ÏóéÀÍ)ãÁœ5OñÞ´• ¿y-ê´ŠaóÛ@Qgó:j¶I㉦bDEvõFì$kŒÔÑ)Sc- Ì©y§é_j=A¦~y†]¤±´9 0v‚—Ûº²òLBäå=%¬éù¨Pb¡¨ÒNrØAëÊVU!ÓÙZòèlœy[1*$hÉAòZ“ E†u…`u¯‰Ó oe±­¼²]|„Iå†IÖ±]\k¿a/j@Á¦–lëF,´!¯4¤Ï!¬Æ†üuãä1P6O2ÞR"vBóÉM %¸]±—”ù!Z€_ÝÁ¯“>"¥ZhoÜfî+«³ìÄÆ%«¼d‚¯É¬˜]0Õ;a"é«.›þ9 xï„D0ò¢‹2ïd3¹5¥ï+A€&Ù(LU&¯]=¬Îžò¢3Kûí cê$òŽÄ5 ød"õÚ ™ºê –_Eûå6qæÞÚÉ–á°´·–WáÏ0vÇ7phm½¨eG 0*Ô—påbð]rŒ†U‘¹9ˆwÆCù«Y]Y {øyAz°Î­Q™he´K¶ìBPΔsšéó°™L[¨úFº!ã2_-–‰¥w˜ÐZ˜–lÞëì©f…ܹcŒöŠH`  tj"㼌 Ò0}P(“ƒ!Úí¢¼ÝYQl,ès«¶Þ ve¯ƒ¤áÀ [ó×ø~DJ¥àªÙúzsª‡4B µ ë/)‡n¾ )šl‘® 3×KgF„ ¾ L{JcH3œI3~Í”ö%¹¤ctOG­…¹Þ‰Z,+SÂ&{¹!ªiýÔ‘¯?ÜŽUž[ê Ç“2õ–í-CšóöR@Û›ÀÅbWfKÌ:Ÿ*ÒA¤†9b¾‰¦ñsÛuÐ@ÂH.gg!öj{-Z³žzó“ÑM9è„:ó{жT5-4´¯ë.¶ñ=k–¸H"éˆú¾’–4@-,Ë‚2céJ?‘Õ2jjLçñTFí`vBš=äl½ûkÍå{ê|-ª'ÆBøix³}»<~I™DÒN´:º±)±À;£4®ç†´¦°˜ê4”y[n`ÐlüÙ±³<•°ú õ$Q=¸Çn}¯ÁxT¹Nؤ~wÎèX °4Ä—×ÍAp*ÂA)">>$[]/U¶Hí1À‘óW8šgJ¢Èù)b¶”÷®hâÂ÷úKç–¼Ò©sÌFÁ˜ €®‚E'Ü£#N¢ôº)¯¿ów¤æžœcÍ8šóH6¨,AÓ…<ýY>Q÷‚|¡GÆ5}#}ôA_ο¥aD¡esþƨ9=X_{¼dÌ(é¸ên‰£´lß0äm͘Çÿ²3‰"Ò©€ë’óá¨8rnŸšPŒð’g”áJƒ^Ó`Ýäâ icÕO¹³Í‹Hõ­ÅFt1Ùú¥ÞL¸ô&)VË ß‹?¢TÒè(aÚ7ß»µ !ÆÈ‘Ïs»¸~OW<±ú\²´ ÌFR°õRÅÊ;ªmDåi,€Ë¥rÀ=8‡'·õÕŒæ=Gçh±×hÏȇò!öã,Ãu×  õ¬¾]ËåiA[Ѿ€§ÞŒï¨Òëü¨V8)~B”LÞ¾ë-Öx¸ ½À#éÑÙ¿7 ”ã^v6€ùYÙu6ïáîèóeýjÉãEøvQkÏD­-)ÜÞîxKˆ,ìš?jÛ¬Ræ&¤É@¯dF 6Õ*·ˆ‡Qc[Ï2ñ¢7w,ðrL•Ÿ*…|S8jyžø”8Ç}õ<ïk¥ Aðè`è†(Ѿ<Ö茚d̉>ù9"›Œ¤÷ŠÆ[¹Î”ÿÚiŽ—1`pˆØð“Wi±*!-Ó§´D@¸Qqqð€S†úBwÌʤÝv°¤‡ú°´—*X²Qå@LôãÈG$¾HÒÇ ÆÀä:}:iéb‡J.«¬6òêìQF¾39³"QÕU¢ÒK¶ˆðJðsaÙ™¿NÀ‰n-iU'œÓD‹­ôüÕdâè 7ñËeóTÊä^›EØó°8Sþ#ȉŸ âM÷7 •D|NUPÈðÒD„+¦Þü|‰žŠ~*yEl[ Äõ,Ì+8²AÛÏ2ó-ùpú†J× Æ¸&›uð¸Ç|H¹†@ÎÄe¶in–R'èlþêþù.çΚT{ªßjd.fL±œ#}¡•-MƒV_ò§@Î÷ª†ÙT±DA 9…˜p/>á¾½œø ½iòPì'›öUìLq±èòt”4(õÎ4r‘•›#k’ÕÙiû#sïÙÖ´NV}“dd±¢¤þjª6ëÕ·Òœµ\ ßA|}3¬ ‡:ÎÁÉQ2PÿýÂã#™+=Üc«Å;нì¸Ý<ÖCÍ Î˜?‚rÏô‹wü"ÓêF ­„¼¬+Ò¯CIè¾ qÙ¬%šõ*—»=Îleh4´jãåE±¢Y¯µÏ‰TJ®èŸªåí™è˜óê–‘wE IA„튘ôÃDÖ‘ (WO°%%!Ð HdÎ^q°¼‘;ö=Lšãù5éÜ”¾bí¶B‰ÅÖ/§!,P@#ÝN3&©ÉY1Ä2´J5 0Å«u¢òVù¹<ÑrS›™d}A¼/ ø#¤–Év•è /ØúhfQüíÖ·õ%ÿ÷Ôt'³!Tj+ ÖÁÊUÀ+¬Ï¯Bð<ºî2BÐÿE¶ýSiž;ÄÝú+îf®ÑûÐ̸Œï‰˜ö"çŠH#bL½,ÜsÍ–ïÈ!!ÖPC/´ö:1މߛ?4=Ýt %»¶¡ªWo;jÞà ‡Ÿ4ä:>Ûd0æ_™ìP¨¢6 ‰­$@ê\„ÄãsÞ°‡-d|¯‡Ìuàœ¶d³§wçÇŽë[E÷aËIUÖUÖqUY­—ú’¯‚  ñÈBqùÉvN¤ o a"ËŸ½<Qf• ,0¹T+WÒ×¥†I¥.7[Ÿêë©[@¼1ãèAƒ‚º…G™“!¥7fb £bö’5Ä+h¤{Ž¡ðØ:¯µŸ›5µÑ(…«×ìôý»ók8sóË*ç—m£+l`‚ðZwá5lž³ÃŽÇàÙYŒPcë÷(hêšA=™©œ%M,2çÛÆÚ¸´k’T/63£Ú>çÒôb‹q[#Ž«L¸dý5±~5B0ÆÈÖ›-¯e%°Û+š#¤{Iîå¾úbXåÕ¦Xvd2óLŸ"–±Ç ·jEzPA[¶õ¾‹’ã2Ã¥öWkh§8z2€ÔJ¶™C?‚˜GâÔ MkQ WQ1¿Òc|²ªæ*ŒþLÊI Í ¶æÕ6=Uzhʳʂ¼é’KHBëT›5ûQ •nkêc»c"km™2úÕM¢avílˆ ȸ±¯>lc0vü«ÜÓdŠ~œîdvh´~y3Æ ªTç•ñæfl¯1FŸÌ§Žjb¬tÓID*[–MoOPS8Ö¹G]¼/ΘúWI– Þð9üÂeèSû>%«ÐìÑTߪöÕ„Ú6˜µ•L†òÌÙX_@-íÖªM ±2É¢¨çÄT²9SâôâÝhÂÉVÄ Y^¨j´Wv`}æàZþ”Ù‡º‰×<ÛÃn’_¾0ªÞh ¢ý×öùÀlÈ«ì·îÜ4†ùîü6Ñ?«ßaŠü3'%­Ï½ÐÆ5Îî·Ö8SHÆ;‰óË?b\ESëµMþ°§ôôÙþˆ™Ä±7¥Ž–ŽÔÎ$­N5xÎÀ¥´5mÁò.LZR1…SÔqžA3½ &²ž]AšCß•SúP’9Ìu%ö œj†®aÝ6ÉSBˆ½wÈ'>ªZV‰Ð¹q"ƒ†}vMví fú!…›ÕQ&H´óZe±~¶tøj «¡˜E_ F¢HÌ> ,¢æ :Iò±°Ë^*ã¼yPß«Þ9h 8Ùbë‡mÞ0Å {›îk @ÔŽë^3ï·îj Y‚à )ˆYI¯+$LÂK½¾c¶û<‹Î‘Š€°Bλ²ó;ŒIx7Š©E‘陜g¨šdò¡¿½y{´À­êj³Xv@#Éy¼@Êé¹{ ×Ý0N=ê”ÕGÊœRðh噈Yx|܃ÅËËé>`³ŸôQ`,û×]™€@(œTÈÍ£éĽ\ÁžYkÍ¡ƒK¯íÙµ>Y\³í9ïÌíò¨w!ßcŒ)L4Å Ó¡™¹Õ e0¹­ZoR£“Ž„n½ž½a¸Ò¨žƒ« ä^} ÚO„ºWœA_9ÃÕsÊ“Š–¢ÇܔǧÞuºòî’}ß«Û1¹£Aôd@(ìÜ"»•Ù²ÁŒ“”@!;[W`“jÖh)c' ™d/¦`d Ânc ÏК¬LPî\]btF±FfÁƒksù2ÔÒ“«‡¼ÓO5ûƒ]‡0ÜãâDCº:I”&¬=’Y³8a&£Ë–÷.gÇT"õë #ÌuýôHeç«D7KÇì{úó&¬º§b¬F]ó±Ã'gÖ÷ËÄ6P‡63÷~‰;ñ+* Õ+ ÈJ¶ø® ÁüñŸO]’)¤܆Ô7½ÔÜjÅ_AÙ ¥j´’íz¼¢¿líËÙ1‘Û"‰ü^O=æ×™¶z›ÆÀÕäЧô¢»¯ÿD…B8›“8³» '&Dì¨bÎPÅŒQ&cøEpšÍáµ ô;åQ¯9³¬¤¾ñ2…'4¤_Ñ-ÉVÔ¯¤ÇöÎ%¾£÷Üÿ £ÿ7 +A$ð+wÙÁöC©žê’kv’@vz¦âœÕtR+ô‚ê_úF¿Y?<ÝȬqPR±ã¿ Y¹­yvV;³J@"¦>Š}Lš[ö(èŒ2vÿ YÆwàEjØÑÎL#š¤{ü¦½¨… ||)дuô:;i á#hؤµh 6Æ{èSô•~N ðÁ @ó~OÑqkö­ž°7n &° [ ZíÙHâ_‡².çQ;2•6E ÕÇéjÃ&g™ž Ĩ$/yu ÑKW‹°ô6¨cÏøVÐd*r3{SPkÉôå€{ ÀìóƒaŠ!± ±Â`…Ùê§RÕÁ6¸(KÆ=f«ñŠÏ¬`æû‹]\«Ž[;@#iv‚˜%ž\fjb4Ï=*á³Ò#RPþ”?I'l¸×‘PXixÑfœï!é§dC‰¯›òÌu}ÐjÞtçð<çÙhëJêgÜâ"Úú=*ìgó¶Ô‡à*¦ñ Ž¬(*:Õò陚G:Ÿ€òz¡‰R2ƒ^ C!vàL(‘Xkuf†8uàEÏaçÈO¨D(Þf:l*aÎMó97QY9.ùŠûM´çÍ ,èºôÑî¿"ûu|³¦Ö­€?·^¾»;1¶ÞJ>9ˆ¦øŽš']ŸÙsêN7‚Η.=¿Î”dË¡! มiÇúAÃNn¢¦ ­ˆHµ!•d¹M9Îòˆ“5¿4Ó t‘‹w‘_9ÀãV¸fì\aù«›þÌN® ›tº€útª§þ)‚ž‚”SäiAA0“f £«»£«;!úŒï*ßÝÆŒR¸‚2ɼ©‡áÿA–µZïL<ã]ÏvÛzÃl¥Ô+¸ç§™÷ÂxÄ_:…š¹y[¿‡S4r„á•)\(Qsœ*„v´ÓÞ± (Ïœr Ja¯)2Iá(ºåt|êÆÙTiw†JÒ>Q% b²´§øæ¬‘„QU*È£hæQU£í¦÷j*–:”¢©ûÈ|xôÖäVõ¶zÉL`³×ý(„{ë0 ±”Y³hCÚv)$Ãa§L¥SfÖTØ—¹0Wi•Ëö50$«M]£ÌS4Ò˼8.~Úm·õ–ˆú¯d†—ƒè08¹¡˜AáÃÔn;&}×QŒ±5oH“šú®­÷û,Ë«ƒÍÞÖœ`. ¢u„šÝCÍì§ìЖHõ€£.Ïø†Ñ‘ô t“˜Fo]yáó¼óž4+,K qœ¸UC®y '´'´³Rž~uµ ÖšR7'ÌkV±Œù±Ö`ÃT$H= “l½?sdÍUr~&ËZ NËÊÌL:½½¢]©ÎôTíÜ©ƒ0OØË _¾€Äuëù„ÝçÞ–æJ»D)Ý…S¶:ùˆê{²ü³]qúˆ®tìŒZÌ33ÙEƱ)Û™­3URöRóDW}ð!Z¬‹­ß;¼ˆù®´µ†úœ}ô='¿é.Yб÷þMU4ÅtkÎ>ÄvÀèQ*’Ò8b•’”ƒþÊ#£.ÙE(+o!Û§~fÚHÁI!ø$’eã#›œ&'büFµ« #_™ã½`-ÝÁzöÌÌLÂ;v~Іph›÷š…÷$MNÍð1r½9ŸMCŸ¨­<Ú3röúÝ©€S º| ½Ä‰§ ŽÅ”=î&ê–dóÇÊ0ª\£>]^#›DCè/Õ8pi ÙäûÊ<@0º¡½7Rö§#Ììžå†Ô§³$3qŽ _Æ-wö'µŽQ–²•\>Ch²ôÇ®>Œ˜ßt‡PM¡ýRÝß¶^\·aa=nµkš¢g}…ðvÇ È^û“ʬG5‡0ѾŸf@£X߸•e^lJ÷R·£g=‚–ÉiDôV}Fa•ˤ¶ÚæñW§aI· ÊR¿þ銶þÛve¿{fƒãû‚T§G}°^W\ô«Õ‰I°;J¥¶¾þ²gËÄdýÃTf2/UUh˜ðë:×Ë™ šLî±oXHÛuæW¶„³5ÏvÓ73úZª9v"€+ŠØwf‡UÛn÷«qÛ.µè ]™"óPÀJÊCK²ë.‰×½4»V›6qq¦NƒËhÏH[›€¾ÿµÈ¯ÆM–õ6 ¿)s¹@ “dý—e¥™ïœ&‰)ê¶^ZsMZgM¼r¸ã\FR·0—É;IƒÉ"u÷® IÉfœÝzÖ¯ú?Ú’|S¬¿¸¬øWêuŸ'<©Žú(aøÕªF‡³[Ìt&kð˜e`ëì÷jp)VĪǔKƒ|4í²ÙJK’z_aƒ,…­G>ɼÂ#ÔÆîÔÆÍWÓ²pÙ ÛÔ*šûê­©˜˜I£Ôí6’­÷èì_’W:Yø8ºa™+ßÎì‚pàð1x¨7à ·Ü”¾éÐ<Ä€5RaÊ#œß؆ Y¨î²P/m¹y”¬ÀœL„å™’Ú{>ì¡ùGöyœm%ÏÛ[*Úµ«<Ž© Þí›R(NŒ€®{@—…~txÂ×.ªAy£ºòF$SçUnˆ:`˜´­Ô½˜÷Çmì ººQyÈ0ÂØµg#*à8ïSŒ0²cþ|ì]Àí¸QçM™+µ;õÂ;TÆzI~/ú`£Ÿvݤ1Dãci©åEa¢S“¿€izeë—'ë6j‡IZÖݱʣ­¾0Ö=2e?*Ã+©»O]×q§Ø8`6¹á80h¼ø¡êL„#-¡ïxi™·oCóˆáÐ.`b l [2 2P¿§Â;„w¡D d”g@¦ÖNjÓGú}¬-¬çß=1AÁƼϹŦÖo :t4vo<¼C[òT´`éÏÐïxçºL·Ù#Ë ˆb-ˆM½L 4O+캠R#ýŒü›Nõø•-nÝ€³õ:€™vkj«OôõÏøµBŸÝ¡¦?êkWÇ`”EÅÀŽWóå¼"þÕ\6H7·ÕïT+÷Iã‹9 ›1¼L¢£ ñÕXTJºª]ÐaövÄlçÌ¥ñãM†_,é½3Gª“W~0.ö<ƒÀ}b°ÂôsB9&4ê#%Ô;Ds¥­·ÙlfE¯fÏ´ =ì9÷&Õ™icáHTl0m›p²dõI…{MÍh]rpò †ÕŒÀ';Ü ‡é\o«ŸK ‡¸gw%Ñ0Í#M­¬•êüZ-e=-w3„Ô[¯¬`W¹tƒ51b$‚îD0*”kR_õ %Ór†oA–Wž*iýÕ‹Ûd+«`¶ñX¦Öy‘9Ô#Äg Üî…„V1X OjQÈÚõd9BŠõ>tžNy§çÙîT6e¡sAý}ãý³ ßžVæ„ͼó^­7(Gü²p Q’óˆÚš8t‘ƒá*U¶~/µ³fg›.G‡„Ï3±mžìýÚäg·ƒ÷EiÐ2ÜÂ[¸Œ'l³ß²l3(Va+šû0„.\ZãØ•RƒPÑüUe\b¯µíe í†ìå‹€ñgÎGDü®¼á]áJÚ/ËL¤탤4èNÇŸUrl#—Ty]WM©’Ê~†jdA[oéïh²—M‘9üCW1îr÷{KS/U@$}y©'&îÚO=c0ÆÆK\h~&žõŽñæ}fmÀ§<º×„ž-M¯õ&*Êçî¢>'PH¶KÒÏþ­ärlŽh?e•>û Érþ4£î¨Ìߣt£–º–EÏ ðž*v½`<­Ï“tã&‹þÏÔÝÑßV²Ekæ$˜ÝÝFÝ]øÐ‡IÇÔ¡=S®½¯.{}ôÓ°Ï{i(æÂyˆ-äš|£%ÉŸ¨’IæŠÏIx=ô=ââc=íäŒ5E;͹T?ëŽ9ÌÆsDnv]oËÉDJϧå£)c cï:Oœ’˜9yZƒ­oûÒïäTï£q" È#³og^ ÄòÅ&½[†G³ÄË; =×Ù¹Zéöè€6&ß–gN“ñ‹ÓÜïivõõ«Â4h­P$(rçB=¬rÙV7Ú6¥QN²"O°õ˼¨L¤Rt²!ìÂ}ø‘à=i cÿŠ0Þõ¥$qYzB æM +VŸÖó˜B^SZk¿ Ávú„äA ‚ƒÝ;}z”r6L°ÉÓNmdªt¤^î€ÎkÉ­·.Áó’ä[°j[Õñé!YÔF“(ÎôÀÎ3Ô<ñ•X ¶(†ÚOjĦáb³¸‹©oH院¼–'=§µn@6ûÑS–†`Ùoöž`tV¶x¾HIž?ÇÖÛ§V’H)•t*°%z›×¸îˆÕ`ù;›ÇÁM# †ú³öñÆåó¨Ñ[ìâ{'>pÇÎÀÆ °½þÄ’3™d掙{u!¾me7Á•ºcís·ƒgw@ëf¸ÖMÏoËI*ïCYÒ…%÷V0ýÜŸdBV(Ò¼0fÅUß9ŽŽAcEG/ÎíÕ£GÉyØUÌÐÙzƒÉ31qLÈQnMhëচu¯“Œcèà\5wGY•D 1ɱäÞ0iLBf%9UGs£Z"Û¨IGXŒ¨KÎm±jƒYàÙÕYuÌÆ^£±õüÞ4%EJ(Öù!qù¡ÍËZÄ@¤O1xÏä÷I,˜'t§=gOŽeìÒ¶ä{·š^ÊOjz¿q‚ùÓCÓSÞc¢½Àstt}cÒÓ‘“¯ºÅç€÷z¿í™Ñ2ï ¨ˆ«$ÐÐ’€=[xR¨Æ´~[ ¬í8ÇpÖ‘¾>ÈbΫ«e¢;5(XfA‡¸'µ Ô¢›;²Á!xZ©—a&%¿oíÚ0§·ùœ^¡—”ú&£f`œÞðqzqOÌ׸ĵhQª4½å]•gbJÉÌöùý”åÉðm=µkâÞÙgØâx[ß|)5ûzš¸›ÀÏZˆô‹Š² C u½Éæ‰#[ž¦ uô ^?£áÁ?Ê¡t9À©»ã+x™É uÝ”óöQÉñº0>GYËsÌ?0ªMxìÞÅÝQòðè»?~䨬p’Þ¤8Î ‘#(]q.²¸º?öïáêcÒŽçªÇÔœ? k8NIS½AŠ?ÅÌY½UÏ¥èÖ‚³\Ó ÕÔæ{Iˆ(´šDém—‡Çý‹àò¹Õz—•J­÷µ2„ÔÒp©¥à»ŸYŸw™,fàÓ/ê­ˆî:ÆHÔy Vrˆýé>SÖáÀ8ð’å¦àö·Òvj¾ Ÿ"ĹHäJe@6”8Ýágà ÒX6¦°±}¹êöŠgÔúRnLt±Û ñsÝQ¤ØDõóe¯¢†óLêƒ Nöà˜e-²6*ʃH†!™ÂY9kªŸ"…jùC¥•4Š´ rqãÈÓ:ÜPûO­[-¡ÚV' ¼æBüºnIEsÍ9.I»[#à²øfC¶ tÀóýÕz^è—ô)g/ˆn¯~)úåRŒD‹0y`†‚w0~jØ^¹#ªea»’~í¸—$3¨í ‰ôö¸K›ZO§Ø-Ô°Îxj]6“uMÑ,h½‚Ù§×6í^O±ÒŠöËz5 ì0Õ (ì³õ»‡Q´ýüu ÅA¢ÀÈLP•ðÓ¼Ã馃Âg€RÜGLc‰;L˜O0Q0Aã—5ûpÈbAÓ::©Z«O"*h»‘:óë GÇ8?Å÷16e_m¹'”š.þ4Úö” ÚRYü«…Ù¾1rçüV¸™Úï]Ûgi*yÊXF€¡T :Ð…J"ô$‚an}•$VâU²-ʸ¦,cAåÉU ƒû+]ᑠϬún»”­Þ(΄…KÍ÷!CCSw{šåž){Ï$ÅÍÎòv@Ïló6V÷ìЄòŒ6òyÓ¾—C£R=ÓµéOkA˜eP,9‚ ’«¯q«ûZǽaJIÕhD˜dbë-.eÈÇ)­°¾Ÿ`׿¿PÑÔ’ /^º'Y–z$á Œê&1#;¼^¦(“eî†¹ßØ9â±/Æ!z“Þ@úñªøT(ÈÀ‡´—öf<«{O$4÷·uzô6ô|3v†ôÔpé©ÅÛSr-ç̘¤4òÕ?Áxªù&­¦§ïñlQ³Á ×!«hëŤՓ¦ºI ³¡îSê£ bªIÐ¥ð$rñ¤%nÏÆeˆ+GC£‹‰êÛÃÕùJ&ê‰ð÷Š&tFkMÑ1Q°÷,MŠ«VÁÎuFþ%z•Ãí¡j`MýŸá¨%;¨ÜîÝBCûPdÏ+z·$;ýfbÌ£ê;:ÁVJ¥[62ô &ɯt#dS¯ríåé½Ì  zT•§<×ÛUDªtåºÏøº\ßÎCE¢mŸV'³õ©kæ[tÃ{¬0+Ìïȃ’Û3Žñ ®ŒÍ ! ?ÿ›&¡b×TF@ƒÂ,|Š’Ã*tMh#Â$ì>HÆ\ª¶žjü¾:€ëR÷†Aö^<ó‚e9Ð š@c½ Q|0MIW!¯:!ïªoN¿í-õd q¿sÌlE‚jìgl w´ò´ï˜EN«Ó|«¹-•vc@‘2ÉDú½uæ()BD•UtÅñÖh‰†SaŸ}l¥\¬=Vì4'Ê@nº Ü&4ïhU#gºâ¤UN€OÓÁ§°Åkþ÷9MU#%ŒŸo5)£’k\æÀŸŸqD”%mLÒ)‹²ÖöF-6 ß>µ`ïtÎ[úï’ß²¡3¾Ë•:·zgÉ" Úq½ZÍ6 n\Ïõ€ñʘåè¤|< (=FMÍÙ½5­_›Ú€·oLl<Ó)<Ýp šƒJÓ!I_j‡ôrH˜‘d}Â&åÁC&Y¤ò½t”ü¥Ð%:×Ó®¾²’9³*¢.z ƒÂÒ÷E[ÚI‚™È%]$?‹ÿ»r¤Ý4 rhäÀTv.Ö j.PPòg¤J-…W‰úœ¤þÔ7NâW€{b±<³MÛÃíb2 íÙJéבÿ«£ñ‰Å9º~ ÿŠ«Þ@ý»M?߉ö†Žè–y–‹Ž„à vj¶xöÑð2g ¢ÆÔ¼Æ”þõ¤ÚóŠ.ÈXN·ÁòíG][¨¤ë†§ÅÀ™RöaS­ÑX³ù8F jø ãm€§äüP”‚lý’kr ÑΛӫ‚â_þ„ï9®g@âÊÖ/ÃâµX2›ƒ­ü†ÌUGæ™6o³¤›špSä*9IȤÐâsµ@ã¬d7ÄN©9¹ä÷ :.ý­¸dr €ÜÞ)†t'mòÁ&BëùêŸI2>G’—zEjTs$ZÛ Á‰Àú¦0º£^Vž9ïÔ`3†Ù‘c£‹äHüØólëW_à 9ne·…Y)«*{YMÍV^“Œ"Œ‘Ń…+;‚-0ɺŽìjP¨P×ênÅwõ”9Fs’­ßÆB4¶J¨Ó9]†âV¯ôöK0Äè †e*°ôÒ—0´xî (hs’°A}؃bZ>»3Q™¾­D_y|&ÆÅD ‹86O…Q“òýô‘p3t„Êeþ›ˆD¡9käÎVH"ô[ƒ©Ùë-™"V(QÕº.po*qÿ“× m‘Él1ÕªIšÚ Míï¡/'ûl㣠HŸ"×U·ŠWssÞ zÄúyg$Vô]FÔ“MC ®„›ƒ^›¿Îl¦^\ëÈ××QOTId>“h b™©1'l,Pˆy´1·‹öy‡ z`•¨Ãþc37²‹’dü‚¤²íœ¿f\†4#á®F­ŽwÔª‰ $Ž—£©6¬×^ú]`äã\­Ñ¨èE—Jñ2½ã "?í^6{‹ÊêAO ÷IËZดH2gqæ¼ e•*Ä×Qš¸ôý:“6º‚ì&’8)0Îír~9+Û„Qïïýv>oÓ˜zRu,›ŠªQ´†vÈ|KÑcó(Y:ßwÖÞjïãxÐ\tø‚ˆ¡Íkß& ö/·(ûL6æP@KøÂVýúð2Õãkšô&¥¢†Y‹6ž.<¹“¹çCÂtV)O&QJ׿/Ü%DÂ×vu@ €œXOïýÁ¼)°?Šh“«†£¸'ÐKKæÁ§êy\¬+övô[>þohí=hí½ 2úD¨ÄÅèIJEÛÊ 9ó\ñ¬Ò5ÛæÖü”Ú¸_IñÇܨԄ¡ŽâCgVáf¶dU<{ãÖJ|©*œªŠzŽ­L65L²ZÎg¿Î'Cv>ùÈ¡*s/;þs™´Ú Œ;ã²ë*²²é›]²mÕ>9±„DÇG}0K”0¼‚‘ ~%Û}8ùJWËy´€-¥+ÌrfŠFDxOÿ[Ûék6Ç«qÈ H’ßèMÂmhtS·F°Ó¨…¼¨¦Š*Wwª®Ä0Z)ë”i##ö Hú@£ÕxZÞæÛ§Ô²Dѯ™ý îæ3ò!3q¢QÒÖï©×š7<îZ+]/µdiƺks”h㜙µÐRù2MÝ, 5B´nè"«{ÓþTÎò„j[õ¡Œa•þBg©ñ9ðÒŠxMÔ÷÷©0žf¢ýpGgA¼öžÜvR0Ù©Üá…µD,K£ô˜Ô>ã!Üž<ï+± j²êKšaj¢JM9Yô¥G´¨{Þs‚\ç…wâü…ÝTP Þíú•10¿!‚_úH"µ½ÿ¨p¶¤§›…YÔ˜éyìÐIE耑ô.6Vc|òJði0¿ÊMИxg’þ ÐüäP  æ¾ThðÎßr]¾EIp½oŒÙÏÌôHizÉ3þrÒ¡EW#WËb½°a@o+åÆj& WýQ2;l=Ìu¹r]óÊܱ^£rõ´µÑo-G 7=äXL˜ÔÀèÕ:Fþ!`Û½{¬§î‡õŽ&ã´^ó†–š†š’ÿšÒpƒ6Ðè»gœUÑÕS}TRÜÇÕØÙSíå=­í›®B§ÏÖ4åÆÒ‘}¨á:öíyÃø„¬Å[Üvxv¹SA·iƛԳ«ŸYÒ&68Q+™H³~ú#iòŒÃ[9£ôn‚®r»&š€«—oL⺜Ö$mÍGû\á<°yI…2%j«—¾JhRÍRÐ8të&sm=d‡^…†{]ç íÁ:‡¾/}8ãß”ÎNõeŒa[rIvAIá(n[„…ˆö( §„ê€ ÛØç†~Åc]÷åG³ö1õŸBð~´å€|ÛhKnò €xT¨ÕØw²8 "ù9Ì 1c>¹„¾åÂRpãœÃ޼D×/[}àj„ n »Õ­óx›ÍfuÍ"vŠ2 ú dç0‹ˆùÒ&“PÛÝãN‚7˜y O‘áYà™Ëó¹Ucœ/þTÁ$uä cÃæ!Íò°ÊæË&“Ì©z:;åÑÙA™‡¹[{êâê=°Avg˜7 £±5¯ ) šoê Mˆ§MO‹®&‹g¦›®VCÍåFgÐŒ€í$]$ÿqIþÞ+̘+ÛBÞ´BÁ=Œ1SL£Ag¸¹à÷¦Ó§JÀJÑìR´G0Í\/#ƒ,;Ú\Û~o¦†ì¼~ªcŽL/7n±Îît" Y‰#˜’@†·î^ræ£ß‚[æý†O5p9/[¯â4˜ÔŒmkt¼2±µÃí&ÊjÛbb°å<_½µlÒ?L­Î†)õð*ŽŽ^  1G“N3RŒÞ7)8‚e]*ÔŠ†büØGÚ  ‰Þ<•ñ_M=ƒº¥­/4ÇV +Út“û×§‡Â(ˆ7v9ƒÂÚ}¡Ÿz4¾Q׆ÚSÀ„àÚ>Œõ..€íÊp¯ Q„æ&êùLêô˘zQCÞmb€ÍzØÖp‘uùˆ’*lŒ­ïSîˆÖ› ¨²¬¡,+Sd³oCÓíÅ”›×L–MöÔP´µ„õ æaë‹@Ïþ‰€ùò²z©áÌŒxÇÐt6cÜ!Lza5L«vT8kb™ˆ5(6sÈöÊÙ»êc1ôH`ºêrÈDÔ¨Vïû§„²9âl —u@ ‰&möÙ½o›,È}ǶߣýŽ4Õ;¯éwדu6{К.Þšžò;€Ì<Á”á˜`¸°µÓø€ešúŠMG‹ød[ĺŸˆÕ¦Êek†„ƒ°cm—Ae`QFŸ¢Þ_ïšÆå›£v!|躇ûâ¢}=SIf—ýKÎ ¢GlÅø`è‡[úrd T™~’çØ‘û÷œ&ã¼ÚFÞ ¥Í{ÁË„Rm´Sš:ûK!“.®“îÇfì«UP:K  y÷—æmäZzv"̸/½ç#¬•cÆÚíÍEé`_¦Œ9Ò;×™¥‚ùÄ¥?óŸMõ• (¡ÛæÍpæMä÷Åg¾EG\Uû Œ$¹êÃç ÁzÚLŽã´å¦evm@û`táxën#7xf'ˆH˜ŠÌ Mœˆnæ¶JÑi– ÐZ¼³ó4á™ )ƒGër¿5 £¢úÞ¼ü¦§>+é?| ä7”Êh9UTŽ×ºÍãäyêÖ°0Ôè6»BŠ7pu[oŸA1ÿSp£lLéÚ—ËoùQ6ÄW‹ª™5,¡Ilx“˜gåF¦Ë!() ÐÑ]ƒÂàUJ#SÁ†©²: aaL…`¬Ó8ã7ä¼hÈaòU=€M±’ª!ÐÆyx-§kYÝ•ýèw°Ñ¡©Ùr¶q˱*u}v¿r›ÐœA|î™1ÀŠíJ¹‰™&}½ Œ& šPÁ¦ad ™˜é21I1ç|2£#ú×@=ß•OL/\DmQÑ ¢»o³Ìb£¡_"9N‹ #&ÀÏÒ%DàMÿ1ñê™Õ5(©Â¦Ë•FlLó&ÇèiïÙöõLýAÇU+ëy‡&g‘C|rœú‚œ¢ía/Æ–0§A ­ëÃÍÛœmQ–Ì­>Û&¬¢¤ó”±l×eHjé6%s+¦%h©o©žFqEClo’F·¤RÝÓ‰ ·›º¨æO½jºÊN{ä< 2kM`p^Ôܪ iÝþ?4Çáï@«Î;ƒ8u\ƒÀM cë† ±½£Š£'~ ùMŒ?O4 żI¤LÓœ5ajT ºØNt“ýr4;:åæ ÖN? ˆ1ú2m{sÕûJrd¨™›z ¶i9Ñœ ÈWÄ–Å¢yowæO+b*Úx±p i!qi¡œht6ß½1ñê¶?1ôŸÖ&ߺH€ñÓjæ mqØ¢€„)Mhfiôüb½HC}„ÚÊR²žHhi<•J+Qò,sè_˜:Ĭn“ñéÉÕ’9ËÒ;IùL åj~lŸ4áþœ´¢ŠuäódÛ³ü;Œaµ• ²üJöβ½k¬énôì.«Ò’Ôf⑸âaG!¦ß¨ù :Ÿ´Ô7ŒL¥ùšº%5›SžY Íþz²ÈY7€7ùÔ&‹”˜]JTAN\.¡yÙ]™òaøž-Ž^oÙâŽײíÌ›FT²~ãð´ [¯rÆ ä5Ìñ-—”Ë‘§GÕAö{"LãŒíM«˜ŒZëdT¨O‚dƾ èÐ``С‚Æ €uÿº5¥6ºiÍ„Z|u°wÌ„øgö;4Aâ!í’k í%½›Ó?œ:q]ÛÄ6/QbŒeŠ^ãY1K~-\XµÏÈ•>/$¸§ÍrWϧǑ­Qd»SzC#€¥¸k8ÛØSŸ*í!)ïñ¶’½º~ý­.…û ¤£Œ+4aŠJIûfKMCtÐ<:/Ò’IJ×l´têJ÷eÁ§V  e¿æ­H+ýsd 5O“l(sí¼»à\rÞ„žÁì›AËÕE LW8• Á+ÿ7P¨(Tíݶ³Ü‡õÛ840ßÃø?I‰©ȵF® ®ô4ñÞ0ŽW:ëmÇýQ26yŽ-Ì)샢K Ÿác0p’„Su0Tgß©oæÕ3jMÉ}>ôñ:ižÛñòkÆm˜æ»ç“¨ÎìW3M{5j}¶W g™7gqJý ²d³Ë–^¼µ&Ûeô+à s½oˆÚ1è‘òÈx™ôç`äÎÁjCNmý*«åb¬šbtHš…‡‡•$+ùj.¨÷^©q€¶‹QK^gðÏY+º£¸þ$¶Ëú‘ÌÉâY‰NÊñݰÂ`ë³8—PFQ¿!VÐË·ÕòÊ[·P­¥Ç=8VK€ø 9-3Q®™\¡%™&ò§³¥Ææ vø¸B \!ßfI½õ#ѶVtÊ×~q%ƒà²nÂF¤Ž0«Ï‡=¹ânÀ~`Öl3ýç¾ Œî)lÓ[%ˆîÄ‘ô+“­Gú6ôXÛÃ$¦½õ&u¸kmÌ^ Ö×Ú 4¯®÷r‰¼Mh»z ™^Ò<ºÇCMN×HÀDÛØñ…RB}„ÏÕÉåœ^R­/ý<üZ¬ÌÄ”Â,]^“]^)ìÃ,‹4¥î¢ìýá;ìP΀±?Å×@{­ÞŠÁuek0ä< h[ÓRѺ¢t_ÛþÛ %R‡id€Éˆ5Âë߯éYgjÖ²|¡;-=Ǭpê'TöÅUöÃ’Ôgßœ Š0ä7Z©{p&ìÒ|í’é1çÜYÊèt4äwïÈ_Ä£æá9œ+^A½"Hø";Ó˜2{Љ$z7ühÖ[N¹ù†Ç UåQ§Àw2® `RâIØP¬öw¢ÑÛnmm16$CšEøvî¾Ã¾­ÕS•e´ Íõ 5NyëïDoRÖBÈ<Ódtvº$0»‘l™ ÌœüE5¼á,bQÎiÎO 8Q¯´¸/ö1¡­×Ä”\ýP*dl#“ØzïÁùå0rõ†OÏs‘°ÈÈg^~24;Œn?)$R+3¬ƒð÷ÿb4»æ*timereg/data/csl.txt.gz0000644000176200001440000012247714666545364014620 0ustar liggesusers‹ý[Ž9³¥‡¾×(ù^眇&Ð’6„ti´6 _´eôÌà2:-œÚýëT¥ËÜÃ/¤]þëÿúóúùÏÿúüGÿŸÿößÿ¯ÿìÿó¿þ/ýÿùÿç?þÏÿüŸúÿÇÿýÿoÿÿËÿ&ðŸÿý?þËŽ?|ÿÏÿåÿ¾zÿ·ÿþÿOÿÿþßå?þ÷ÿüùçÇÿ¼ÜëzûjHÙeýßWpø×Ñ…Üj—þïëzýë|ÿ/¡Ê?—=🟠ÀP¯ê]sEÿ÷å˸²Ã€ºÅ×ÏË÷ÿkÉÅùàõ_%tN~—TÛÝÕð¿"û¿Oøç²‡užS^ûUÅÿ¾Úµçu=k„Át¾¾{»ON'Ç=¾] ›˜ÒéAéñóÂåW:ÐE-bH‡G…—®\c øßWª‡+­A éð¤ðÖŠÏ—/ÿ{¼ì"Î1¤Ã³Àý»üþ4ý뫤ãE71¤Ã‹Àû”¢9á_Ån˜d bH‡WÇ÷ô¯Ó+,/ ƒÒáMà©[q¥XZLò¿ý²”=¼‹ƒÒŸ|<˜óqSõKÚ†k1:º_°×W ×Â0∀S<W[úŠÏfFø^ùõú\ŒoÎN %kc„„ïß×¼ì(íd¿¼Ø*Æ? ¿¯;>_§é‹`3á'áGþxuýUŒ~~bKÎö7‹3áá›Å‡sßœ€1Ë.‰\¨*0íXûçþø8‹cLÇËjTÞ ¡ðªBÒ{Þ´Égô’í^Óï%¼¢¼ügUÿßvâá?# Fª ´ù÷ŸbŠà›àe‡óñ<^ųIétY ¿Çgºµˆ BwBï[w†«ßÑÉ"†Ý =¼ýïöÿýêÊ‹"ô ôø¦ÏöÒ[¸1ˆ7˜½å]Ú˜CÜÑUœ«ðjò®õÒ¥ÿûKÖ^—l£±‘7 ÎÏ~—ÀÏÈŸuüTýrÖöùÜ¿àÇ}å,ÿ,þrƒÈ^q<—fyaœ-þòCâó…tµü¥„u·G$$ÜÛÍÞ»ïŒ]„8§G6¾Z8ò­Q|øüá,å„oÁZÄ ¡çA¯ä•=\àÉ"†¾ß9óf!û/® ™ÄqÐ÷׺Ãö“6;à÷ÍíçŠ_®—Êÿ\ö0!¶A¬aöø$·'f¿0Ã`ÄéA¡/3óÇ+(¾ÒÁd‰R«˜"|7øôê/×ï­Möcä%hÿ’æe¸³Ã—å×(ÑæÀKÔøOLgà»»ü–f ‚ÀûnÉìUJ‡û¥Z“"ø|`—B:;ë-Í@$¢#+ äö÷þñ3*$ÿÁüsÙÄX‘wŠÎí‰p°#±¹â²©Îôl$ýE+ùŸäÿj‘.{ðÒàÕ6ßLÍïxê·gãû[ZïyºC¶æ6¿°ˆB/ƒç=ZÝ@ÙÃ×o³§£ì¯´·æ0Bà ð¾*›oívíà¥Zs!1¹ ð¾*›¢¦÷sótÑ/k#$&'o¬‚5Ó¼æÃ±öÅy@e/Ô÷…)•­:û_à¼êæîe³ˆC P”7…­@¾FŠ$ô›Šî¿¿"aaCŸÞÏ·bÏ›ëã­EÌzôà>]AÝ­AÌzôô¹0+–g:bqd3„Þ½Î1﯌ˆ³AÌñºy(7:BþdÐâ!­ôþ„ÑMyøU×O©±]ŸÒøvõó 9ÑS´1CèúȦ÷EËŠv¢[ƒˆ!t}^ó{º»¼¾x7÷L³1Cèú°–þh|¾8Ò¿ Û3#„­Ojí ¿‰s¸ÛS5æ0B¢þ’° Žüyß4õmòüE'ÇÇ‹—Ž`ÀTçu*nð 0.Œ0”. þy|^7„óV ¬Œ2p×ÜçÖ{ž?/lbˆàýÀ‡9©"ï/xÎÖ"f= zš7öuõñz!ƒ˜!ô8èý²Ö… ý0a$0¬¶naƒ$çRŸëlBï_\(wYÓ$ú÷e+En¾èÿÿi  }Âë;Ìë´ïŒeÄ}¸›ù±ýW lsDa<ÚWÿO·wøêºÖ2‰Äx´û×dö–}w™¬i y(dÉì9ž¬·lÍ[Éä¹d¡šÇ7‚È¡µäUþ0û McÉb÷%‚9¯,Þ_·FxØ€Ì ÑpÐù”­ÂAß9caDÀL¹+×áB°V1Eøü`Êô˰9ƒë²V1F"úk‹lÑÅÀN Y³# ý¥5'!¶Ó øj­bŠð3ø™wtõÀo–f ‚/À÷×Õœ,yÂ×dMbˆàõÙ­ü¾­‡Û§¦…Iæ3/}Žy/š?Ð/kQcoJtúË+jÎ{ò㛡ˆàdz˜ó+È_ £èïE@îÙ¤\´ÇÊÈ ~˜‘ËãPYõ[LA‡ ± âgšqÿß»Þæ™èfŒ(Ô¡§àðð m ÌfŒ(´¡ÐæïsjkaS¤¤âßì®àÚð5‰V3f¿QÅ&øH>³pøìîÑ@ï¾ÍÁ×ãåÖ$†>/þŽéÅ=ŠävߘÄÁGàc¿Õ>s¿Ï7|´&1Dð ø4¯²_©o~c1ž| k†ã£•Cèúä gZ¸øÓ…OÖ"†H¥ã,’ÞÕ­íßa.X“º¹¡Ä;ÊK92%)T×A”³S‰à°Í—'ŽHä!ÁiA¸æ[«Ã°EºR”ˆ|À–^˜Çë’–éJž_˜¨˜ƒõ3[_ ÀNÞXÅá·ÁoóZqø—6|gbŠÔYIA‹8?üäïk#¡~Ô$<©U 1È?—=Lˆaóä±ÅA{âÊ ƒ…8Úgz„æÞm6fŒ($(HšÀ´«J‡‹’óÂ*¦?~œ_z#«è‘Ÿ61DðxqšO÷o=üxÍ“I ‘ê6©á ‹Œ•‚´Í7EVdÏ)î2q$SÅYÜ@f^Ùø²¬2x G$ühš¹NV¿0Œ9¢~tßE®‡0ÁØe\"Q2tc·J¼Þ)´hÍbŒ¤!©æÿÄéÑEÊ䶒ˤlôš3[=ý—µŠ)Â/à‡þL XítµjbŠð+øñíØ#½µ£(”6(mò1œ/sÁ(5¡úLöµÁ*5üpe!Œ}B ­uŽ?œ`¬*fùUõé¬o÷éñßÜÚÕÅáë³Ùlb~ûâŒY̹5´^qZ°Ýõ‰–q—–•ÉMQÆlú A¶äcï ·G¤_íRŽ+dE@¾SG ÿk§§µ,Òþ”Èö·Bqsÿë’™×,r©%îØ‚üsÙã™rJùtýÇw'dZb8"‘‡ÄœEÕ¨­ÄÊ0É I˜JÖò7×ŨōC`.øu&= HÂ.[Åá7ð#ehhwǯÉŔΗJè9ASéñÑ~©Ò5FEøüL¯‹xÍ76e~…%)3”0ø;P×>^Æ$†>_ßåÓ-—_é„/—µ‰)Â×Ƕ½ëªjl{õ/kcD@bwMÙqØÊìùbÁ¬Ó¤–ø×¼ôšžç‡HÏH^'Ì0˜stRÚ#ÓÊÉ8$2Áüµ—À{›í2QHC¡|.üÅÍßö þZ˜e0¢¡`‚Ñáp ®­¬2Aò$iàS$:N[çc€€1Z#RÒçRÞ›Ÿ[Ž“µ!{!ì8Øyί‰‡›YÞed3¤Å‡üZH¡d¯—ÖüP9òõB»+¯¯Is”ݲClÔ„<‘@ÅF,üt}Å4fï{'Ä­ÖKGC QºL<œÁÊ(C¾Æ¡4ô¼åǺ°‰!‚OO}#F•Ûã/š­EÌz½oOÉCwí¯¾³1CèeÐ'·ÕŸ«ëéÒ\Ö f½‚nº„ý›¼5È6.H²rKÍÕ<—V^ôkKޏ¾¤€+æÒ6Uæ8A¶ ô³K¼f‹„—ˆ 1éšs “v]ê–-×’ìÖ¡Ñ>·µW=_-ÔeÓ H4<4Ä!9-ìeÏ|¾Rlcº@“áN*K Ô_èB-ˆÜ;I_•t˜Ë fÚL•ë@Ì 3 FêP¨qñÝ(h|“Ì2QhP¶’sÉhÝ ÄÎPþùÉ’7~œŸîö|-«ãšÑHï›,)3Ú®n^·¦ÃõÉÁšÄŽ—¼w¼¶#yt‚ìQws‘û½ó%!án¡E‰ßY²àAä„ ´éÛEј±ÈTÊ’( ŸºzØ–ìlöË<%ûfÉP‡ïªÁÈF³#uP ;'`¬bŒ8„þ_¦ùø$kS:¾ô|¡4¸}o=ŸW_³ÎÝÒè8A ý' òìˆ5,ì`ŒÄ!PÈ ~2¹$kS„ŸÀ÷ü§ãšoøÁÅágð-é:  Û-YÅßd_§ ñä¿Ä«8‘7W\³]÷Ï3ëÙše ç¾ßS@´a#YùY¶|˜Ï%êB~#FŠ„!0íaÅ æ÷—¤.Œ2ˆ?£€é³°æ:@ò ›"ø¼éàãÉ|c‘mà‘%¬œ.uBSð =Zƒlì+KTô)·#¨s홎|#Çkù™!ô ºô?ßÖ{:JÁÈ f½ :uAÁjc{²1£Ó³>¨–søUñ_ ]®ŒæFPu«6Rlä>»ÔùXâ`GÎm §‘:ƒì¹, 1œ.!IúTÐ4ç“Õua˜át ©9A1*¿špí]gáëõ¯¼$¤a·xAJ‰ ˆiî…ë–X—oHˆB eΚBY˜e0¢Ð†B£…!ª³7 p×°YÓ¤¾Dëÿ©õ_>œB[XÅá»Á'G%R’vülm²îÒ,…%(t§<˜/îš…ït†> <[ÂWkC´ž¶Šù<›ôæýk–z’$NÒ©ýŠvÚásµ&1DðúÈæ÷ðDìˆeaÅWXŸÒÂÍþàŽÜ‹WaÓq07}*Û”„Z7\YA ·¯s–§?<у˜ñÏO‘‹¤iszwÒWùü<ËÚ{²Œ&Ïö0!¦AäC‘–¹!ŽÄO“e>ÿ}W,gxT¸1Š’‹i´öB¡‘¼$ÇÛõIlqúªÜ u6ĶìÈQˆC¡Í¦¯Ø*¦?o\(_ñÉ&ëÕ)’Þ|œ?ÝN|ÎþÊ­C+Š"¹ )Ã'<ÝÎêÓÜð:½¹ØŒ @ï_ð/kUàü"© è¶O½Æ$?èÈg£ìD€"© eJs8­0¶x;`ÀP„ïÀÏý¿Ì‹sq­îÊÂ(¦_ÙòžjhÃñö}cS¤×»\y|îr$ϲŽì€i½ø9«]pé0!ºbC¡‡;™ä §[ÁáûÁ_%ÜíøÉÚD¡‡AÏt9Öß=±'“"ø8ðÔ3²~c|æk3CŸ€÷ïF$OøËšÄÁgà§ÌV·ÇgK3Áà#j§;ÇY“"ø |â~¿'ëÑ ›LbˆàðùMÙ_XoLbˆ Qе¼ë¼ù-Þ˜olbŠðõ±­ïJ/bà뀲Š1" Ïm{ÓB¥ø˜BV1EøãÉ•­Î”¯ç?€„%Ù(¦_nÔ|¦t Ô-¤Oé…¬s è0!¶A¤‘ 5ípô²L‘¹ø&ߎ?Y›lnP‘üà©Ýa=àÛ:7ˆº)É~ž*Sª?XY“"ø¼sÕÈuº:ÞÚÄáÇÁŸæ‰Œ’Ñ ^×MdS„ŸÀÜØ-Ì×)m³M |þÑìN*F.‡›=_Ö$†¾ŸÞŽÞ«å`}°&1Dðú¬fN//<Š É$†^Üòvs¹e<_ÍŒ/úÔÖw˜[,Á˳»òÑÄŒNÇp85)}'jJJ’ç§K“sˆŠ8.ÔçFŘ~ÏË "ø<ðó€½qŸ?óÓÂ$~ùѶMT ÝŸ¯…I |xO.ä½õ ˜a½îÙ}UãÉxc3þù©’µëù¼ËÚÓµkÜl3„î~´,ÃáÊDk3:]ZJÛ@½3ü¯zÁ˘`¸hPe'™ÕáCÞ<­Ø0½§_¨ ùíÒN‡ Ñ " ÿ׎f,ÚVWYò"Æç9IÅ~î8$>0¹<Ÿ¡LŠVYåfMWœ7¤¹ì‰),Ì0˜® ](Ìz’Ú´Q@ˆ„Í2Qp?šHÛoñÞŸ.бŠ)Â÷ƒO#’J:\¢hm²c›ª,t±& ¦Wíð›–dMbˆà#ðÉÊánÁšÄÁ'àã< 9ßû÷ùÅÚÄágðóì Úiƒ}cS„_À·#ëáîŒÖ&;¦±&}bë;ÏoÿÓ½SíÐG¼>¾ŽºÈ™Û{ǘĎ—U#ÃÉq©3ÅPãEL' >ç¬Ñq‚,™>׬Yë‡÷LÔ ±%ôÏO“nOÓù#ó¦e òpäkô÷j绤I'#í¼«ß‘ó¹hÄÈþ€&ñ(*u)×^¡ú…Y#ceÌŸ.úL]µ„„¨¶ƒÀÇÈù(ºœzÊ5v×–Øâ ƒ?øìõfyVÐöfl—áˆDøÑ¢h22¦c?  ÔܘeŸ4‰whÛ—9O·•-¿,çžpîp“hGÁ{™Gm¯±ö. iêÐIºä9ü¸Þ˜ÃÀ¹ñnÙÿ¬uaŽiÜ$ÄQd¨¤ó{S‹íü›ež§¯YŸ—Èë7§oæçÜtÉÈ~}Îf Ã„Ø~Æ/:-˜Ô»ê’Ь`ŠL½ßMŽLçÙò/kCï>̉_˜Ñµ»ΚÄÁ{à QÜõÙšÄÞñ²‚ÐF7…Âo#æÕèúÊ0^qšÕñs· ±€h¶EyÏÓ’¶ÂîÔš, ÑOÞ3ny“ùÀnÊ&kø]¨ÙÇñr\Ö"†t¼x)eñmF²¤ãÅ1&1DðøÕzp‡o¶X 6qRb!¨Žxoüz183„}r]Ç“í’2` "F§KW´äçÔýaû"»» î¯QžIahÒÇH>tÌ~$ê­¾Èa0·‹dé"‰zgÜ/ïyióÒaÁ-iÆ&Ä0ˆÜÖA¯Ã3ÑùÐrD"BÂq}¥F‰7 ú`»LÍg/¦1ŸÒeÑêÂ*¢?ƒïûÙν¥öëÈ¿Ù&†¾üèþŽ2JG¡î¥d‘Mqmâ„+ºª˜bTát¿¬2\ií .¸"^ã6»±Nwc50Ãøç§ÿü׺©~¨œïLcC„QÞu‘ZÔOÈ.Sd|Gõ–,’\Ý…õ”î´æÁšRÌ‹ìW}}f$z©t^¼B5÷ú€>ÈJüN!Š(ˆo¯ RfƒŸ;Q´Çf™4”®à†B¤ðm8(økaQ à‡Os8ðQ©ÏF™i~t®ušïª¶ÿQ#“˜|>rÇ¢¼7¿%k3€OÀ'nâ6Ê žðù²1Cð’Qñ‘q…7]ßQ“ù9Óâ*Y“¢úÍØ Çgé[éuHLáÌþ>¨«Ç {¯íGïr›Ê‰ì–f1EÄ]\u!;y§ÆìÔgfbøn𩊇Ö[›¾ÿÑ•ò¼>᥿›d¶äG#Æ#ž-bðqàéf;Ý¡ÑZÄ ÁK ¥×ÜgPÝ9îšÒàÂDײßo‰ixØ™i0¹AB; Õƒ³Ê}ºF\ù„©[»DËF†›×ù4âªNŒ1P¨C¡Íå£\~{Æ,¦@ AÀ÷…Ê´ýpÇ_Âò˜"|‰¤#7ŒÇ¯øÃ hõçlS à À 9ý¦ïøÆEV™µeçûÁçdGp«lÑA?šÖèùúNÀÔ4ó¸}„ó\ñ€1‹(àëã,äoÆÜéÒQ¡®*½Æh­Hµä˜Õ•t˜õz ,më¢éž~õD,e^\ÏÔâP(uöÇ&Î ×Â*CBúy ÷á´:Ê´0Š!ïdoSQ0EyU¯Qд6[» _ö(ˆÆW}Öná6B:3 &wT;2G|Î,ÔL«·.‡·4h_iØfo¦ÕB×H?z!¹¬O{ }k’a¶1mWÈPðäG}ý è{:‹ÕLYÆ@¡ühî 5¸.õt™’5‹)¨C ‘s.ìЉŒbø |óŽ:ÞL5X£V/NiØØdfT£­™;ý×âuÎ(8(džÃð7‹îIÁ%kc  qá{gõVP‹.Â@Aê:7L­ãú6 Æ.Æ@AŸèf&¥Ï¥{dcDA:› Y{®Jp£mfåÏis¯9k”ŽÑ "'„—´%b»ÈV,ÒÔ»‚ …еJØ+¤…U†…ÇUôõÚ ¬ŒbøñgdmSè$oùΙMZDNœä$´`ŠôtÍlçÀ»F$$H ÿy°Ó í[ºmÌÇWò¤Á¾ˆÐ¶ttºbƒofIH~v1—ÃuoÖ d¼ÞN2rËçõảÙc½þº½ÑMüUAÌ^ÛþÒ DYw¸ç³5‰!àëCk@Úõ/òÖ&úsá‹“¤¥Eø5Œò:Êäѵ¸¯/?Þd&æÅ/ÒVïŒ2<•Øñ«Ì‹sòí ‰Å»Ì„«¼8Hbg„?\—¶ŒV‰‰vÙŸ|ÛÚÇn# £Ýx¹?CÀw?štÍþP:…M ß>mn|=𽵉!—LEŒOûŒ-Â…4Ê×òì…’9 ضüfúЀ†5÷f9A1ŽmYÞX¢:#Ï™w*ùvÅX Ô‘ 4¢D®)©e› ²bQPÒüP0C 6¯*]“»B€Â²5ïñØ*Ûš· D„wùtm‡oŒQ ?¹½ÖÞ˜Ä à3ðé](ŸüðTk3/Ÿpwa±H÷°æç¤7­!ÖR!sᩨö’·bçr7¾€{l]˜cH]&ÈW\e ïK®t’A© ›gHq*cg\U´^†­3³·ºˆW#8çSº/4ŒiŒD¸%x‰q:ä¬]LBT…ø¾Øß5Y»‰¤és»¤´ÇŸï,‹4Ñ8ˆÈäüˆ”_^oºkÐÂîoùCG™ndœß»ê¿~$–• @¾25BF×»B²FÊ­ÀM8›ß*¤ÐR QUB¦ÆN~G-š~Th ž@ ©@`‡qÙŸBlÖ&f?^7Ÿ~2x37?‚·&1|§üÈ =ó±alü¹±¯ºè•ŸØeS?q]˜dýH!ågþžn¡ê­IÌ<¹…sÛ·»ƒŒM ÀxŽ+gŸä¿«˜…ñ K Ðì g……Y3E~äeÓO Ú8íEšLM•Â\2ӡᆦé6H¿›¡Ú„ÙÍ"ñaZò‘¼@ÚD¤àÆ®sz ½Ö-fª1 ^Ÿ 2t î†Æ8{…ðän¡ ¤å@Äß"B3øníDÐ<‘M3ˆ1£ãÕÁ·Œ-[B‰*ÞnÞqJQÖéZ»˜…ô3–”sÑN¿FY˜µÈ %«Bzû9 ƒØv m‘ Â(”[ö¨ÇÝ^%oÍb ª*V;ýRËfñß‹B…BYxx2zåØÞº£QÔs+'/\zì"h¨nÕyb$šì¿>+_½YÆ«ÜH~Fî©[OÌ´ .ŸÞxÕ[ä4FÈÑ<½62^MEdú”BZÜ6r¦ˆ‚ÇÃÛ?©¶^‘™uŸÉ~£ƒañº[þ¢>ÝLöÐ܉7ÌÕ½µòÏDŸo öÓåƒÆ(o9»£/ª!}«&øoûË'¼NwŸ1¨*áßnN ºçä>)èÐf²‹)Ph·BžëNN Ho'«"áRþž¥‚áú…Å8è¯YjXzúª5Š!ð*Þn~E–óÏlŒb‚ dž,|.kC 0žâÂ_¢“@½¬Q Àx¤wJ¨ù(`Œbˆ`+'O %Çèâ3gåc+&PüŽw fñ±q«~-œ iaÊ¢ÍB‰·UdƣƪßcDBº8Œ{žø •Š6” S[“f¥E2#oËž™D‹†¿5 -åSÛkÔ²0Ì` TÃôðé|iŒ]¶¯Húä ˆo³Û.Ý…œs„à×ÖßÅoì>Œ’Å¢È4¥Ad]˜a("Q¯Ÿ‘MIÐßÚܵBYYÅ8ð&^½¿*#’?ÙÄ ðýͧA&9îùgàåÇîŸA3[ÅøocÊOú@m~S{üK¯@„þûy®p_:›ƒ(ù ÎiÊ ¥¨jäìºÄE¹ãçíq€–ÊîùXи@.c‘‡´êfãOe×°ÙôQHÐFteÝIŒV®“]Lé ì„ TclOÂY³ìØ —î98h(k2 >Õ6KÖÔ4%Ëäo&—nfšÃWÁ푚 `²7g ò­Ðænkc`Û³‚³V1E ñpU.kC PU PŠ¿nawg°2Š h*yE~Ð~³Q ©€nL '9¬Q€»Ã^ 'kÿ¹`ïV½róÈ盫 úúë5MÐ4o„u»ÖBÎÆß„¾¤6»6ÑJ¢@"ª„í¼ü[Yº–(+³l3è®~Fm1ÇCý^A»tYLBV…`ÚÖ½€¿¬U @QÈÓÇu©ú|ªµ‰àן‘\K÷Ùáj±&­î}ı¶nóËêpg–ºx‰!|ı¤r˜«f÷L—e“˜¾S~å ZÛÛ\_2‰àG·­J= ™mZ|c¸(Ñ¿îÐë²F1D~‚=ãìYíù_~´`|\)㶬‹££F~"Ý{—–ÈýeO­ í†òÑ. ˜¢Ë¦˜D¤â€¢eÚýŽ ãkþ·ÒEîÓn: Èr#çê°»%à3Sƒò¼ g 4ê­‘8 œ¶Ã¥K† 4šj8vªå'‰¼àˆ´ë …KÊûËä­MÌß)_Ê5æPÉá§ÍÖ$f€ï•ß÷DsŸ£5‰à‡›O­ O?@´&1ü¨|‰€Ï>§ãõ7&1£ó3²v°œðô¤}+pÿþtÔÙ!aØŒ<@y«”NЦ¬6qYªéQ,eö|ðI\ïÂÑFÄ3>"µf÷™¥€^™‰»Æ]h]ï>‰‘x‹0,¦½Æè¥H¦™Dq¯íæ&pâ†7·è_ô˜ýË•åN¡ênhãGÛŸ¨uÁ´ ¨xUqüyÕ4‹ˆö 3ÆÙOlÆ7Ücι ãI㺬iŒ iiëümò+µ=л҈'m%úW1n’+1Œ|0)§Js6Ÿ™c3cR+‰#"pC$‡ùâ`©±ÑÐÀ«Éö" 4œjXWLjw>i`‘Àv-<0Aø€ëH­‘/Œ+SÄÿ¼&ÀVd&‹ øÞSO‘ªÃ8/j£ˆ^“ŸûBÛܤ¸pC9ÆWâªïFÓÞÄF |9®¥ÏwTÖqU; í­c›mMH$•ðì`lá V²‹)PȪx9F‰>+ FŒÌb Ê­@³™ïœëÄeíb $ªJÄw¥ØzPÐÄq2Œ1h*‘Þy¾5Òé—ï ÛÅQ€ƒ' onvÖoÙ¬YL‚S…•!ç_¢Ä…]¶^ƒuŠ8ÌB'ÜÑ×êN(K¯˜žÞ/‡•ÿ:ç=S'q“!«•êªÆ”ítEùF#/ÖR ÞÔà¹Ãiä…]LBT… +ÍÕΚG Î(íiLýgž(O›9 ĬÄÄw|7»Ó^Y±ºçŠ dóÇ~/P,Ï@ Po.í.‡3ðÖ(†@ ©@1iΧŸ±X£"g ¹ïsV±ŒL‡É̱÷ò¼Æ€©bö8@Û å¹1á­ Sólܺ­Ÿ34B]X¶ð¿bÆ­JÐÕGþÚNB¯ä^\~d„%ç¬Ü|RÐ¥ölS TÁŒÁ„h§“5ËŽæì ñVàñöîx–h0H*aOb+´“Pç3Y¶è+VíÑ-ÒñòhDOÔä²Ì_³Yët ¹¿¤-2?dšNæh§…h ôYA³ ȪÅÈ‘ ‡sÄöîO¡Vk3À÷Ê•Eô景ƒ¸dÓDŠ+¼Ìà“Ç#¸ýòÖ$f D¬_âçÃâ’®œÒûwò_Ö¥–ùC¡ ä ™§È‚t÷:`ˆÆ“ yêg(…Ž4ÝÐFÏÇ=WèªÓ<Ù‚JVÏ로O×Â4Æ@¢¨D˜'˺»cöóµÉÖ,†@ ª@ä!Vípñµ;èlC ÐT ñÇâZú¨ÐV1EáÕ &/ñô[»ËÚÅ‘@ Ws(M)ŒŒ}ú×#3þ¯2Ÿþ C›ƒÝC¤³Äzûí>ïB0¥c›\øæÜ ý\„J&Èðl ëdxâ@Äß"T;[Nº=!ˉ &¿úx2 bdëlJÄdSXK:ŸÄ*í›_À 1‰±î™Ó êéf- b²ž3CZóé,p16VNQÿq*§ÛÉ  õV˜óq´0p«Pf M²ñæ»ÓO]œµ‹1"ádz\ŒóôSk2;|­oµùñdWî?’÷« ðK”Õ ©½V%;AËYvö}„¦pbò’úžÃõY¢ÇŠ¡d­¸^-î[,7ÒLê½®rDˆÍÒÞÌîU5ìÜ­ƒÂµ2ËŽÝjp GœÐ2¨GÕ(°E|£Á¬YIOË;¼N´¥`‡í…Ó2Þmq5‘œï¸Æ[ÂõÏq¼ž~Õœn$_>ùôˆT×Þ7?*<šZL¯Öz4zõ£š>ü‚ É·>îO¡Z›˜!|Ô¡ŸêÔÎN2¢.×hMÔ¦ësÔÎ| á†¦8»|4o{Õ%6Ûb@P‰ªâøUWOáZ™¶xÃ9¨ £x#qÐЧj¶‹)PȪ`BíÚejwÈç”fbið jj§ƒúVaŒDU‰þí¤DÞãïØi¡jü´ ™¡ )‚ä(;J`nÆ‘@n($hwû•„1Œ1ÿüx up·²K·Œœdú×#Üø‘´ÌÞea¹£gæ›zlˆìÌXIáÆœÐ{ó|œ@9Ö>=ŒIk^¸¸BÛ_~Ãñ{¡3ËÍäõúÝ}d±“è"UEœùN•½ÄèøÃ–™oU—h*!M?n ¯ »³(Ö,†ˆQIkFl§æ€Ž¸œbÜ-0×á -g+­Q €Wˆ ¸;bl +€ŠHæ"Ä=Q&8™£@Œ7ñsž£ÓÖ¨»“¶8fQÚe<®Ç;j¹µdoŒÕ.å¿¡sŽ ÓeÝÚHË4[Bk;ö:Œ0'£ >Tü>¹öË–ïŒDR Ïã3õ5ú¬pÇ\&»˜…¬ Öi{ºNÕZe½¶] Üܨî|‘n[îTת Ä÷gQz\ù½r É(†@ ©€ ~@Ùe‡ºû ¿$mò¸\ÿtÿ{kC ànêd{¼Sk²V1 ã®s¥xºQYLÂx¢ ëtÕËZÅ.º[j³f“ÍE¯;‹ý/SÊf;Ô)Ô™>dõÀDªËrÿ—.áU¿iGWÊAbeS T!̉[£e§PŠ5‹)Pˆªß«ÏÌö¢5‹)PHªLS Ó9 “™Å(dUÈïHññv>cS PT¡¼Ãç ç_^>2‹)P¨ªPç´ƒ±B>üÒÆ,¢@ ÝqŽm„Ó) µ1™Å”®àÐüM3'¸®AÚã‰û“²ØÐƒÞ}N ç )ô¸©uQâ¸§Ž¶|d!‰ B(H% sÄ_ã½Èµ2Ž8Ðpªá;mJ˜©'b†¯ a®?ÕT„­zW“YLBP…Èý–ëé'F˜Ìb ¢*j·çP¬Yü÷¢€6yxËÿŽÈºæ·±øØäîÿ»3qyÑû.¯å1£Ö nUîCÑk¬19sQUƒ–-_i,²ˆÌj £QEBf=N?—¦ééenÔ%dô'šý¢_Ià ¯‰ã _IÉ …ý¸_Iɨµïû¦êâ¯$ŒaŒ l«Ñ\†q´ÑÉÛñ“*ß•|Øl~_ô¦Î:-Œf9„=³Õ…!ŒDV‰~KO³%û§?)ÀcQ PT¡ïÒf¯^:œªÍÉ*†@ ª@à6éÚ ¤…Q @Sȉ:éu#pY£"ˆ*eÉÂàöȇ3ÐQ¯³Q €Slf,\m/9[Å(xU(ýqüüÄŒi²»ûè²f1 A*ÒÆ@ÁÍíYLB¼¦Þm÷\ÇÍ9`ž 7Ñ›)"€f‡èÒx›ˆßÁ¿+µ‡xÍßÝ`¶‹Í ÁÌGŠ~Y» P¼Af*ýWØl6)öáK{¢[_ZÄQERWk⽄±‹ÿ\àAiÒr¡Y?ÇŽæ)ýµ 6mV<†|*4Q’6Þ@5ânû¬*^UúŠ™ª}¯“ˆfˆ²mÄFP C¸f{—5Œÿ¾+x$ä ‡5P†)¢Ø‘û—I–ÆË}L¦ÃÀ,7“ÏQ{n<3ジ¼úQ©¼CÃG½‘@xÌ^{ã×ôHÂ5œDqãþÂ,‚ãÜÓ{¤àhŸä9®vºJeaC àTÀôÈGçŒý52FÙÎýÞëê[ñé[ìF»Ííõ^£±ÜGdp> Ìt3moÏÔ$ÕÅ(WÅó?æEbúÄl$ðê\ñÌ݃`d^Œk+‡ ³¸y찶ίÊ7ù2uÏ/Ëam&é„̈ÇÓ¢Àíêembˆ ™eÿM‡_þ»1Š à;ågîB޾i{>ÛÄ ð½ò÷óÀw¿°·6-|úJQ¸NIØ= Ÿ>S 0ßfF žÂeÍbŠ(`ñŠú”éSêxA˜.—FE¤Àúñ™6ÜØyÎæ‹°+s 2QeL†Y‰'‘keœÍ{ó#tм¦&ƒÂç&}.4*õDt$°îÆfÚ«Žù ;ìµ€Zd¼Ê¿M=Û~­Œ³%Hoq6ó 4꡴ȇðˆóù†Î]äô+µSÐ3'DDó½A˜Wë fÿ÷ñ0—̲պBV…ÔÿÛÔQ Ôó9³˜…¢ ™{‰ÏA›1Ìf1 UŠyeqÆ,¦@¡©Be…߉aÏÕÚÅ‘¨ãnÜœ=ç÷Ï^«|î¦gj×À…B¶Í=¨ZƊ׼MâÉÒnÊôûuAΘ¶P3G aÖ¢5¿Ÿ«ì¼Âޮɼ¢CÁuÊõT­E} *Ëó€z…Êá-2'%«à£(eEO6Î~Ó³\ôñ-w>¦fÌG[n¬9|ÌÝ`‡‚³ñì„‚þðÊC}fëg§ÿûiq©OæÃcÂ%âšnhæ¶&'è0l1 ¨ä[¥MO’ÿV…3 ¨U1´/EŒmt€h` ‰T¡Åø<øK8ýZVÒ±>ŽZó-Ó±‘Ú ‰›GÄ=óixžIÓÑ‘ÐhÜ‚­î5Fʆ 4’jHYÿôiŠ ´tc»˜…¬ ¾¯B¦eZ9]üj­bÊ-PçXMp‡S¸¬Q t,È\S T!¾IˆÝ_¥h­b¢ Øq/×é§¾¬ULBR…lf{~Ð’YLB¾x¢îù 0V1EúÊ•R…ýégH «ˆ…ñ·)ßµž4|Df¥ Dä‚ÔÕÍÑü4š:BICù¨F˜3ÝLnêŽEÛ† 5²hõîux^ÅŸó&___mZY‹†î5ôÿ.s  á†Æ6'êÔx„&k‹á@$Þ"LËõ RãÂ4s€ˆ ú[W™CÄ„ú#â~¯•»U‹¹>ùÖEPHg"n©ù!{ÀÄ7"Ûší1€ÊTò o$H­<ëjÕÑ%Ÿ¡Ê‚HëY×~õ™‰ªŽ£ÿêÕ}–ÐU™Å(4Uæmsíth§IJ0o›ˆýk]”¨kAÛFẬY¶D½+8UH&²§°*œ·NÅ„nQèvê´ ×RÏ=k¯‘…ÙŠüsÙãM74³‹â] -"YELÚòí/>ˆ°i‹|ê„=v…?€òGÅõ±Õ€‹Œjþê&$©B£Î%”£#ÛN¢YË#hæ„YÓ Q|…Â"6ÐàðßÔ: Ìp3§{ð¶a"u– 1hDÕè×q~Ü“ÛKèWìb ’*˜©n1NÂY«¬&ÐåW>fkÔ"ú¦C…ÔåFЬåêÕ:Ðî°ª¿w5ÑIB€Î[Iû~†j††‰™"^Eœ·[èæÂ–1á– ÅñÚ Ñ•c=I˜E õm´ÏoÚ.ÓQ·,Ý>òË·!aA[;üIȸ0ƒÿ\hXÄNOaDÌ—t¥§,+ÿçMš³ÜLvÚäºg겋 Yy“öèÐÈ´oÅï¹ÑÀjÊz“²ÙOë\˜¦ƒáæ òî=Ï~¹´.úïq¢ÃÀL7“]²hv´c¦…!+7mBɉ¬MyÞK¤¶r›Â÷®PTÁ¿Ãì6ƈ‡‚f¹ÌV1¤ dÔ ´°ØÒuLEåý…øšÃ›vs•Q ‰YägmqÕ)÷fsešotxkÌMãý*{ÔÀ#ˆ 4’jX:œ–älÿ½( Y^ß!äx`ÓSáõ/ò¼ü³ve¤ÇëYR7£äz†jÜw1ù‡û,u¯*––ñÎl›½ý3RœÇ¼ñ9!:ëÎ?™}(| ¿û,: Ìv3} BØ3QóÁ†Œh 3³ÁõKÈÐLÖÎËOk?: Èr#MÏ÷¼Eú°0cÑñ½KT•p\î>ŠHŸÂÊ*†@ ©€Ÿ³’unúF@3Øã>3„l&M œ°ã£M™Ä ðÝͯóZk”:?ò‹5‰à{åG–×½ýˆ’IÌ?(?qr~ÝÛ’*2‰àGåç×Þ^Œo#p“#iëè*û¤¼ì1àç°šª+í—µ!O¥ñ}^{ƒµš’Œ²®Ï w+ ·T]¬æ·‘tP›J)ƒ,çÝlU̘ûH, ž@ «€éi8>ÌOua“m´è º„·Õ‹Ñìk_š r— .fjxÔ´í/-‚®óí C¼P™;bÿt ¨î¦®£u[ꂹ ÖøÚ"1cô¼=ªØ`Íð(ð>ôÿèG#ÔÕ‡…1”¨”`3¤«zs˜I™qÝêpúÆÆ@"ß\Îq”—5Œ1(*‘M•¥ÿJ‚»cØd½‚Ó†¬XÚ{%0ƒ cŒHH泿ô!›S©¢>ü¯/<ÿû\úï”ÎÐþ£MKî±2)”$óú×a4"»êq…Y! å”- u´ˆTqÜWô+ÃíàNÓï´K4•ðÜqE(‡Ó0v1E$‘Aúƒ2Fšg…­YL‚S…hç£$´MÍlc áU"™áôS8LÍá«kZªv ö vG íSGÞÄÅ#,åj¢Qææ?ÝÈv’pëG˜VéE*×DÁ4†=ÿbf;ÃzÌЉf ¸¿ú1ŒeÌ‚ §’ŸßïÙÁwÂ=¦V(îý±tòæ;SÒŒôðçºEf·0ÃP ‘o‰Fᶘöua–¡@¢¨„ã-CÈ[…Ï@ PUÀ 0ùYÓƒÈ&þëίï£ÕX]CÄ9þüÒIYUŽ×¬Õ¹çmfÛǬ`ü-0‡ÆvT|T€‡l2 ðfïvü´2‰àGårÏ©'æ‘_ƒµˆÀ'Å3Èçíê­=ôÇ÷¸!We¬pX—ùÑÄf¡LÛ([ÅZ}»™iò$ú#S;ÜÙÖ#áR ǸöÛÅ(8Uð¦ÉØéÂ$kC àU ˜½ß hËúÙ(†@ ¨@´ó òAÁ[«˜…¨ ‰3ÆòA@,0f1 I²i™r:‡¼2ËvL©!ß …>\‡ŸA,0f1 E Gh1!cw ÞZň8…²pÐŽ ö¸àkùÛÐQ@–Yè³Vü© $É CDU ÇXêµW𠫦ÕöXü“Mü×Â×õæªì­ŒûÒkfôèëÚ¿:u‰õ ¬ëäähžl^f–V×ȪáÍÀ*Ÿ¶îZØÅ(Uœm{: Ÿ¬U @Uøæ]àµÐ|\Zz½Íæ´æv PáÐIຬQ r©@6ã8ÃþG€Å80mNO!Y£ÍWjñ· j=¿¬Q @P&Ý¡Í ›š)³nÒrÜkLR7ªfC6þé5;7×; “ŽÔÝPÎós„ž¡ueÊ*µ‰—WE ÍLOma›9@Tð]tˆ¿ÒŸ—{Ýü¯ëÓo¯·ÆKi²×l[ŠeÁé‚e¯‘ƒÖAõ&½ •É^¡ZöÌœ‚êüFhp´9,íhÙµ—Pß½õV±«ºÁëæçÚA!_Ö*;O~ 0 ¨êA@‹…g£]±ümšê9çžêº+g6¸ÛòO©ì÷pïÔËÅ8Ȧ­yÝ  ‘Åx(&Èw8´o%£ ÕôV;? Æ(†ˆÞûH‘ä¿#³jÞòË s2ÿF5˜iÃ#&¼L4% ®‘\Ùÿýç*;?±uI3øÈ~Âuá–×,ðyµ7nIò© cˆÑ ¶›šü|OýFj±uÁ´ Q/G›UοÊYäîöBƙۥ‹81Êš¿Ð0¦Ù}n—ð*a'Û†ÓµZì¾íd[yå©‚˜r<‰¬Yv‹ä(©B2­âùVs\h³Þ’*ä7ýjµžÎ!Z³˜…¬ …=ËçsX˜Å(U¨¦½—+ç“0v1õ–¨³Ì—Ûܯ®XÃ# — Ñî:ßÜpüøy°ê´›¦ÃÀ,73QÓ}$>35ã’ 1hTÕpôª,;»ýÂ0Æ@¢©„7=\ó^a”°Ìv1E¤@ÛkŸrѵ‘lLV¾þÅ$æ®nì+ìÐtCçâ…;×eGm+[ *YU,í:™®vŒq¦kgßÞ˻ԻÅ=MKz—Ù]íîÑ„¤í݉%ƒ× Òs ÆHì u´ˆD1·A;®ãȲÕí 牷ÎV»“hëÛÓ|à:Ñžus Üv;…p­>e3 åV \€ãO¡Sf³˜…ª ‰‚‘˜yøŒU‰c¤#C<S¹>²1¹HÌM“µ0$D‘fç÷ȼ0c±½ëþ–˜ ôí¸‘¨+³ A%Ü»Puêá$VV1Qü;Ó‡ôx Æ&f€Ÿ”ßev®ñÆ"B€ž•ž©y[9Ü5Ö"^^ÞmúÓ·ðb`L¼*ÜpÆü—Gz4ö𠾿ÿXFÙм~½ÐWÇ}ìŒÌȹ€i M³§,·SÛv˜¾G‰üwÁÁÁ¦éγë ^‰l‹k]ÁÝ Ô‘$œ.̪ÁSD.Ÿ) w<½P¯,MåÿìSÂ_‡˜–_¹«ŽÐ»M §KØ7šƒÿN::öÂÇÇs8ŽÖc5c QT¿ýœÔò^£ÉÈ,†@ ª€4’³·ÐFéZdC ÐT ¾#mÝ^+2Š!"¯[€üIaÏnaÓÌ|Âg áûh–U‚ Ôúþ/å øóaÓa`e:­sÚ0Ú‚ðr`ÄÁx·9<÷ÄQYÕæ mç%åyî&b€ül3ÀÏÊï œ¹ {´L~äGË3@¼Çë$Á™Õ4ZbfŠÃ•/Ÿˆ{’ åµt¦Sf“Í ‡î Õ#Së†ÈÆ@«„ïW`Θ¸f÷Ðlc TB¯s¹ßÚ¿´¢(ÚÖ`Œ–ÒxšÇ¤¼L¦ŠpÕ™ífr“ßr䃓!¶õpHØcã¿q†ÐWdS àTAFÓªâ;6ëmV; ÙÎè¦E³÷¾Q0f1 AÂ{™1´W0f1 Qõ€±Šþ\øˆè >º+ÚÝ–eÞ k}»”,îNÄ@’nGçüÙ‘¡û„l«)pLBUÇÃÖÛ^«Ìø.ÐTÀ†égpY›aº¯M hö‘•ýE‡_LbøNùÑ­\a/¬M €WÄ^…zø®`b‚ d®j¨û+T/k3Àʯ¦Š¼íùia’]‰'¬Ó’ΚV/ù6KŸ6þ˜£Bà·.™Ž2ÝHN„¯ì©~{2c•˜PT—ðLÌþ¼7{ ›œh¼} …uIŠÙï’öW¥X›˜~U~`G„º6g¬M @Shz•¡¹î³Àè>[ÅQ@vwÂËzöîçý%ÒG‹¬bœ ôû˜æ~ÿ¤…MÄßßüL%ÒuË×§}6‰ŸLqñ­¸GªRÕ±VP~Ì:5߬Œ ºÈh5:j"™y=34š…r†³ «y¯)fþ^4Íð6£ËG¾'Î>"ÝêéÅŽy¾Îÿ¬;‰ÉñŽnýÿ'\uÖÙ DFqÙÏ[¥±}{Bæ°ŒAQ%LƒB[Yµh¬“ápÔagsÆý˜¶061ü¬üðÔ×wÒ>^#Ë3ˆï8µã¹°=ñÝeyª‰=ÆWÝ Èð`¶‰À7Åg>Ùºÿœv¡™LbFç¤ÍeyÕyßT÷×§k3Àwʯï陌÷ÈœG¾_˜D á£H Ã2ÂÔqä–Ë5þ aëôà0;3çAu7µÒcx¦ÞáùÙC‚ŒWG“?¿V1Ö"AEü»P>ëW"Æ6æ@#ª†…}¥aLãDõ<¨AàéIO« ¸þÅSÌÎl7“g‹Ž·þ–¹ãa¦ž†o{^8ñnÒ“>‹™§ü(¨âÉêž6 #Lü¨Pn<†@À«€ï7Üg|áxåk¶F1AÂ|G;mïµÿŒQ @TȯôÒ?ÂÂ(†@ ©@ân#^ù(Pš5Š!È*ßÓåü+Ú}T@Á%YÅ(U(¬0’wÄcS 0á:üâUk1ú<5fk(â›òõE¾øû>¦èš­uAEO^M¦Né]íò£©»HU7ÍóH8h¨»‚«Ï‰vKpûÎ|’XØÅ/ ØÇeÝxÌ÷ó(hvÔ«­äWþÈž¶_/lÜåÈòX@ì¡Æ”UÈ[‡‹iáyìãACçðؘ7 ‚E9Ú¡wÉÕ£DZصèZ,ÒZ[…w¸RÙÚÅH4•ˆoOßóáÕx–Ðõ4YÆÑ@È(Ã1»H ž5àÕ Ó˜ §yɘ¾ÑЩ{ì½9ÐðªQÌD_÷†19¢,$ñsÖXv±Ÿi¿-y95£ ¯'/ß)ä¹s%çâe‡QF¶ÙÓû„}ÙÍH$•ð\†‰¨×^Á˜Åd0ÍÎNçP-oÕ­ê¾ Y’T^PFÕÈ|ûHŠc—îýWU7cha–ͬ$iˆwœ;à`™°ejbä|A‘Æ9㮣Õ²ðU%åÊÏÝu$ܵ°Œ T±dýèÏÉŸ¸æ‹Îó Õ¢›ùÅÌÙ c¸ôKVç÷ȇ–)¥ëõ¯8?¢•_:x+k]Ýþ•ÛÇÄŒ)6„1¨*aj´$|#1¤Í†- **zfD/)áß®Œ6H³Cf98_‘ØŽ~(ÿ£ÊiÚçlc áT"™ N×e c $¼JäÕÛ½Ä1;‡Èí "ÕýÓ(iã+ cØ¢LE‚Pn‹ûoLeé!ÏkKû {¢ú±Éc\©Þu2ÃP ‘UÂLM.i«PÂÂ*;˹ ðHmÞ“5ƒP•xß&ŽÙê¼Ó¨ˆàe ›ß‚`KÖf+«¢« j7ñ*çËö’×ùÇ&ÏÔ?ëL­r­ü-Îo™z++?PExùçÜWìÚ*À‚…Èt;«ˆiIäÜC¶îVF1ü¬|Kr{º°‰ÿZRV%_uoêviEþoÆœU$ij“ÈUµÛªT©"t‰6oõ‘5ð¬ÂÂ*†@ ¨€ x¸½ÀemZa*¢H¨1¢}MÜŸ@X™d·[A¤‚~±Óî ~kaÑŒ=ßtJ+‘Ú‘õÁÄà‹â¾D—ˆõÑZÄŒÎoh”W–Mü塪44t¸Î?k¬l“ë†Þx€6ÊBÊá­ ¤åˆB/Åã˜_Ãþ w[ÆH8•Ü_é(‘v1 ^ú­0»©Ë Æ,¦@!¨Bš]I]ïVf1 Q2ûòG—ÎͬYLBR…2ûÓôÓµ=…²°j†€Ÿ•oQÈÈÙ*\Æ*þsQ@O»¢¾aj‡ÑïÊ[3wjÐÐÃNWjTÍWOÌ´0Ä` QUñ©æ½„ô6U†Æ‰ÔƒB¡ d8œEµ@CÔ©b ý”P,¥wYëLŠ—L…úHe¤AM7µÐÚ¨ùÔåÓ‚D…€c¶Ã|–áC+|k"ãîc²P17#rŠÖ•În…Õ·ÅgótyÛÖ¡!Q@+‘©"ï©èòžü¾²ƒ)ÿüÄ .©‚&Ë–OÏ —µ*ð‡¼óò#¯)Ž.\Æ*¦@Á«BâÉCÛ*»‰ æ­w>‰ë²†Ù—q—ˆ*QÌ•o®Óâu̳UºDR‰jò⾑0†1F$ô•þuvß–¼ÐÈ3L.{ˆå&f.éÜë‚g!P¨ª`Âa¥Ø&£ëü¦|Ïüý è ËùFIÓE+if/Íuº@Æ"f€ï”¹!ýoS»%~T Ì&1|óí ãöò$k#€ŠOÜüµ†->Zƒ|T|f|Ù_ü` bðIñ¦«xÞ[- 2UŒñB¡¶.¢´Á¢»©ý˜Î¡E-Í_¥§/vh¸¡¼ nñ- äj{ÞEâ-´œ"mÕKÄ "ˆZV,/©D)©Þ¶â7Ƈç‚K5:ÒÝH oŒ©’OÄe .C ào`G¿WÈÖ¨E\½+UpÜ£+.Š_FÕ¹oXÔcu5Œ]Ïõ]æ¬CùRåieif±wj»©)̠҇.,˜$*pvUœ×ÔËçÁü,RÝÂ4Æ@©„Ù Ÿ%.k—Ý w¯ Á85óYaµA7oe8¿*:±ÒrÞálíb $¢J$þa#±ý¹Ýe c $’JäÑC}mÞZ¢væáÖÃç›]T³9ТP¹÷S[nϦ˜9€ý)€ÙØñ.“i‡Ô‡öÑGŒ3g;³ÜLSuuËy &»ÞLï"õ1…le¯±‚¾(d“W„jxSâí÷—fÁ3€—N³sJBÛ_ûæ­MÌß)?ò¼—‘YùÈ¿¬IÌßßü©e’$¤ì¯.Dg› ‰N‡ $úÆ(†@ ª@yrðîï¢vY›˜~R~C’ÃÈ6÷µ‰ "€•+êçú½¿)[…I†{®¿/êðžÍ‚šnªiÃw¨ã3KÖ,úv™¬2ÎÌQÓ ôÊu­¬3“ÔºHQo\:‰¸`mc4ªj¾©Ï?‚XaLc4šj˜‰pg „Á„‹ÙððcóH¸¯~ôóL¸.áTBÚ@M9­_œÅµ ÇhxÕ(f ûÕ•2¦1A5*÷ËúNØÆÑ@nˆŽz˜^Åá G./í¼úäÙ£€ 72qÉ’ß"Ûh)ˆ·ÄÜû)h²Ç³Ä˜JMÿ•)H*á¹ßTÝ_¤j±U @Vâ<\%uÆÌ6Ù kçåÇ·£>ít‰VQWjò×ùUù‰##èôÄפŽÙ$f€ß”Ÿy“Pö?@Y˜Ä á£ñ¾€n®2;ÜBåZ˜D ðò ©í_dQ‘Iü×ÂG{­‹dÃ6:€p`­]bÖžÚ‹dÃÎt7ÓÄ¢ÓžÙÄUhºkxÕp\Rë^¢.'C›Zï®nªõ®‡ “V1Q¿˜Ûá*ÕËÅ$ˆü Ÿ~ZM¡šb² $î3€15ûßÙÅÈìù‰‡_Y3ÿÉ(ëùq¨ú®má¼G/æI×aÈù%õ\Ù?ø#ÚŠj‡ ®t¬HCrñõBHQ¢&Tœ2rÍv"º eÛˆ wk”é[4¤; YÖË ¯þ(ÿ,‘¬aŒDP‰@þÌ—‹§Ÿ+^2Œ1ˆ*ߺ:qä'‘aŒDR‰ôÎvq'‰ë²†1Y%²YU%Ð¥ƒ c $ŠJôãb›|P0v1 ã‘6¬ÓÝ.ký¹ðá>ÓÙìÔbX ÏM«ÅÞI Í}ìQ@–9çr$}‘>#±Ld3 ¥Kxì4/Ó[q8qý4>.ÑçQöt˜áfr[ør`ÖÑb Uýë¼ïD{¯";v\[å ±GÉ-ÜTsú.ýîº$k”眤~õå5ÝVí²vèÏ”>"³fœÄ.âgÌ‹BE¡Ö ’ƒ7˜yA´hxÕ0#°q]6Ú4’CÃvc궃B¦%œ?œ„óm "€RÆÛA-¼éö“Û !ÈÏd-³-õ¨]së…†ry˼›ÉšéÌ„›ízÜßañ ‘W–Ù¥›GX°i†y7Ò^",ìbŠ(àcÒVjcë2ÕÛ¿F/Ö:âä‹L¹Ž,72yr/ù³­§åU5lG¿—€ Ö0ëK÷ b:Oth{¿ì—Êÿ£GL‹xGmªÆšêñÒ7kC àT þ_$·°Š)Pð· $»?㻋dÌb ‚*d<ƒNºÍb ¢*Ø «“‚¿¬Y‹+xàðÉ-|”{…U~?Å:‰­•E.ÀÈ;æTLÍzè‚ø¿uR‚`k«ñ÷zù»LX è*ùVi…–u'‘±E2++A¥¨Š s¡8v{&×´Eð- ‚Ø2ù¹þm¯v’(y~ã)–]¡©Bä.x¹4 s6‹)¢€"ÆŒºùÉ)é f1 N$5qj'7¾7›«”¬YL‚W;ôtÍ[³ì¼Ò®TÁ²Âñ¹H«¥œðÒß<~T–”µ¦6Úò«é»ÌÕQn$?1QÿŒÔ¦¦:jñ,#xØÔ³6­,ÑnúYAWÉü’±©qĆà÷¼-ÁU~(gàç›ßL‡´_'·Í&1ü¢üðn´…¼ö¿ª·&1üªüHßtØÙü—µˆ 7¥gÓ×do=ú­Ï1Bð¶j¼¿øù²­[Tx7¸éE€Ë4^Ѿ îcÆ’™øÙ¡î†¦0¿_s=@ãÊÈWCCŸÜ­áua™íYƒT|Oã²?]áì‡1nõ¯Áh»¡s’œÓÀΆ閦ŽˆHpDDœY„ºƒHYYÆH8•0cŽÚ§˜ ³Ó º„¿%¸imüBÂÆH•ˆ<´Üùtˆ ɨýyœ7XGŸ¬]D@R²j¡pT`³˜…|+pÒQ!,ì⿉ ¤î~.ú|¾—(\gõúý1ZÙf¹™ésg˜ê½t{dj¶b0ШªáæËxiyÔÎì´°‹)Phª Ëá9ùhø¶Ÿ%‚5‹)¢P/UO›âG1ÁØÅH8•0…g YÃÕ¡z•HÆÃæ¿ö½óž c $‚JØnàç •¬a¶x—ˆ*aF¬ÝëèíY¬zsVz¨I%,ë(¡O3•ìÙä…Ðp꺢N„ZÏú9¾ÍöðÂØ4"ìÌt3ÙG[ȸ°cå:-«„Y=ŒwУĂ·\Q´¢f¼i9 ¤e<®* ­ª€m 4^ÏWi9t•{u…¦ ñ]æl‡;oçI`|“¹%ÐLé ñºT!ñܬr8…º°Š!p*À¨vº‘.ký¹à^D²}›ƒ~I‡¯Ê¿¦n#q-.æ@¡\•Õ­\õÍ)÷ÈÆRóPÅànª|¥¶®Z®jbð·Lã:·£ñ:×oQ…džßq÷/úV´ò|7“ujCkžËd»‘Ó}åÝo'¯g¨ærG@âˆHºnS‹u]·4nU¤“SG¾;¤îE–…bĆW [cN"š4[¶(³Œ)¨„ñ­•p:°®´ä¯pLQ%͸}*Ϻ8aŸßLBºhí<ÜBÏ )/̲+꘲*äw¢Ž¿6ú¨‘YLBQ…ò®œxú%êeíbŒHèÎcÕ~ jÐòÓJô8øã¹þ²œ¸û@g–›ùñBêiÚ3ëʃF½5f•{iÛÃFZf0ÐhªÑšëÓ©7e4Q(—*tÖ¼ô(‡ …ñdCº@’Šì€êÉ@áÇ¢ùËîB#c‚ ƒ&)ÂV¤ÐÔ-³,ˆKŸnO´jp¦s‰[ ÅXEgLv’’EÓZ@RÏåâ7³|ý›§kC‡Ùn&U¯¢àuƒD2+Û±¨©MñR÷¦Ú¼ýw «§ýnš]ŸR°@Åxýþݳ‡kòÂ(‚@ ¨@ì dˆÁ@#«F‡Ñ3í%ÒÊ.¦ˆBÃ3%ïÀ[wõ’yjî¨íQÿz³ L-ÜÌDï¥ù}dbÛ† 4¢j8“Òöš›Fv1 ILIKª{…²°jQf“àÒpš?%ZÔƒ€N,3u6œg‘àÒ@æ/e­ã3´ûª5Š!¨*`«Z?&•°QÖY•àÑppÇQðuø•WFÙ K†Cc¹MáÐ|ø 4ŠGac¢Íph¸´@]‡çK{S^-ý¹(8œ‚¬gç~|‰*3Mzt˜îfFj%Œ÷å3Rw£lˆÁ@ë†ÎØ0õuɽÑׯsÓ£=1ëjs>À¨@ÿ.óÇ<íO­ÞÉfßãÑùLsð•OžÇZKg„©0j> Èv#9MõÔ{¤1c•¾˜áß‚ÄÔo/k×D¨ ³ N%ÌÖ{Åg$³U‹ýR†›ËIFÅuBÚ äåvÉ›²®‹CÖŒï(5û¸û’}¸íU‰å†òòûºкÊ_l 2sШSÎŒ¹v;‘;ìMív•¦*ŽÛQÕÓ‰À k›m’•áªs›ß9Ãù:ýêßšÿ3c áT"ÎNÏßðÌî4‚5Œ0Pð·u¾:ÿäšCibÚqe8é´ô”¹ù‹ßÛÆHD•(fRŽ;ÝS¨Ž'ɤ–5JÕ6§ášµŒ ä84¼æÏtÑöÓ¼ÀF¿øê5àbŽ2ÝÈ”fñÍzF–ÐR ‘UÂ4Þ«n¯PV-zfxé4Ê5¯[Ø_·lÈëÖ kè›9ÝÍuÕ[°&1ü¦üh2œ¯ÃÏzY›"pÎÉŒ.Š'½œÏ[18c¶Š)¢€ˆº_DŽÔQZßiξtÈÏïoʈ {-´™Þ¶w¯©'¤fd,‚¸Q%;ôÂo¬ö ³˜…¤ žK¥èz#0F»ÌV1YL§ÙÃÔjm²f³T£6»JîÞ\»°}f=ûo²”¢ˆ@zê€Ñöü•Q @SÌÅ¡e/€*T²‰—:”€JÎyÝßøhoÉ&Ùœ×âpAOéh´ÉÒúðf’ÆS\»™e~JÚ©ÙÁQ€·Þ/Ò#€Û( ò‰¬Z¤Gøî!@Yo¡®JXd|Ú\¼Ç=j(qït‚å‚ DóRíäv×ÈXÅ(DUH‹E[ÑÂy6+™EÅ'È&ª÷›ÅQx½aï@ß¹¢Ù’s/í)¦’ØãŠÕ ×ÁD³{øN™_u¯}·F&ØP°üó‹ Ðow GæC.K*pE{ÍÅŸbw>Í“D[ú0 E³Èg¡£Tg³ì(²®PU!¬»AmtúµEÆ©wiÓm0©$íJ úφ1F$4íуVlî$qY¢Á@©Dæfdí¤à,ÐP àU¡pã‘ß°ÇûÉ E t9¶h¼³˜§¡“Œ¾¹ö0aê÷¾¢É¥õÅ,"§½äg÷ÿçc©9¦»™¦׉™†¬Z™6¼Ž˜>'‰Ñ̇™˜t»‚0Ç¢ùl¿­ÝQ˜µha[äðè«G!/Œ?Ú(¸1i²‹1H·Dઓ„Aš cL—¨^AeÙÉ꟞ü øjÁþ›rgCLõj7“7¬£‡Ã#3/ˆË}t…c]&MOy„±Ý]®Ÿ%Òr#=S àTÁsëÀÃ9¤lòf¹Páa>Ïnƒp8”ŒI̾Ç÷Q€Ò–Uï¹m¯–ûËÔÚû«Î/áêËMäÞ‘GbZð–¯… ¼¼WMÛ—´(+›˜~S¾ç©­m{IŠ¥„àáŠ÷òž_‚¿ë¿]Ö"f ¾-Ò4”ææÄÈE_±QÓ»ÈÒ¬ÈH‘GöúºGV ´Hd•0ã‘ËÁhÜif’°ÚÜŠ*øõt–DYNm6ÃY*Üðh5­éâp^otFv1M%ú6^C[h°¦ô…?»‰s58,3¸ÌzI Z“Îûë KÌßwŒ­ AGt|ž—ôûÑ‹jþ½&ýõ¶§?jÀ #òübNj97Ǻ4ÿë£0ó¢…tC5 ]Ïд@ZDò-´pi ÓVÅ‚w ™D»s×"û0‡öÏ{âÐpCùà#tdcð™ñ¢‚^Bœf{«$*‘ Ã~K4lÊo+îÆòá_`ÕüEÚï|ˆèÀ­ßž;?Tm g²^˜ñ1ŒÞ´ hpe‡Uj…‹h]õÂX$W¤ëÂ)î(“»êW®~†Cû/Û‘Ž²ÜH¾3PlóŒDj6cq»t‰ªŽ·Ø"nÊê>6›Æ.ÐTÀÏI EãÏF61CøØÜ‰³ÏÛ†ßàã4kC àTÀ ç=\! ’Qv:oð·¡âþ¾Á1²‰ÿZøðfm1GãÇ’wx¤w„ÞŠ‰¾Ò “¿BhvoƒÁ‰Q,a±ÁêȬȾä¿_ ³Ö›*úªudQd0Í­WVa> ȪÈþKÎ& 1ÿ„té(›åØlÏÔ#ÿ]ŽCÎ|ÔíÜ⮫ãþýý+‹¿/67Êèç.O\r8ͼ›kñEš—tÆÝÞ©N©Ž¢ÂêVµ̆W o’¸ë á“µŒ1·ç©»ãi\Ö0ƈ:ÄUŒrŒ¤X¼¶hû˜ûÊ{èŽl72–y·ÚÜ©KR¢$ŠH`+1Ê1ÍæI¡¹…U6FÙÜ-@¡á“Àª) w¾W¾Í _M @PhÒ¦N7p܉³¦æt…¸ª®¨ZÑÈûðÒZß¿ê{7"Í<†UâHØ3µI:²ÈéU5Ü<,r4ÎßH´•]Lé …´Ó1…80œ¹hö…²©ßů郔0ý(,"êß}&j‚¬°áÃ.UÀŒ+l{Ìä³ÁCŠìu~Q~`V¾N—Ä˜Ä ð«ò#wï,{>€‘IÌ¿)?ñ<šÃP.k3„¤â¸JÒ¸d~#¡_Ǿývž2¹W ót4ý·{|/q_e\ÍÇìL%Á¾Rð‘ &¥š6ðµ.ÔmCÊÍ 5nGxºz-{P’ϳC‹B¥Úd~5-Îe/Æçi^FõŸQ+LæÞEqñ£/Äù@@›BåðºøÑK´zýOäP8d5Ÿ3á¯:œs=Æ gÿ—²Ä©ç 3b”ɽ2¼COH­£]dž³ã§kø[ƒ`m/÷#›Å.H$«È£îò“\ñÿk£¿ç"ôØ¡í†òÄ—–öÌáϰ±Ç™#"H3ÄCÍîÍÑR$ó G ¼ÿÆögfœ…fúŠæëÕÂ<2Åpºˆ¿ðÆAÎ4•Zk £{×ùÃÐßµ“Û‘3ÝLö™§=UcÈ—/M3Tà ni+‘V;¸ÿo¹U÷瀾áœ1B-|$ЩCt®¿R‡ÀbñhäòQ9;(Tä%ûv~‰!Ðç‹[à¾ãe;ÝÆ#Ä/PŒ!@§ ´þªCéìšÓÂÃlR“·mýS9h x–-³Óº„S O®>ÍØJkS àU!pv`>*dkS T!òÆSÖœûŸ"[³˜" (bN«Ê޻ùÓtGüWõf_ÂýǨƒy,¹Ø[æC‰±Y¾{첡Q)TrOPyÒPŸ1gJ2F4áƒû-Î¥xºUwœ_ƒWÅëo‚ dº‘‰B`zü#2¥…‹Á/]"«„aáÛ(¸…Uüç]M±CÒFÎóÊkèòæÀ¦|¨>?"f²LBle&þ0]ת£VÌh™d¾T»HˆpörÐÝáͧÊt‡—ûJELøñD´…,YfkÓ»DV‰ð¦Gûâ4Åé&î°·L²8¦‚Ì“¦3“U @½¨_ö{c”ÎÜš d“H§P-ÐPDYýâc3(wú0É•ìâ¿ $¡‘ó|Iû²@WÀ6 7æ‡3q>PwCùèú5ÿ…ú…)‹wÿeðû®B~H:ÉïhZ ±á¼¡H‘Iº]™ýöñ€tËx_4·=öjPàNÎ)í%èJf-:Lw §¦ûk¾Î×Ře»Òv¯ 5ÛA!/{Òrýh*`2·ËáwÀËŒ² å] ÞÔ%*Ê"Ï!H*`ºµ)“Ï?B\µxû o'Õź~dІŒ¸º“‚?fQqÖTÇ–›¸›„;rÛCæ7˜èÿ¢ªŒmßÒŽÆ»keéà"q‹ÔE=ÎV¤Øž0ŒdM y{V(îxÚôŠrl*&Ó"sìéV™BNš™úák4_vTHjˆ†òecÙ#5àdò19‹7ÅK^Ù-^ä£/Gœw#ñ8ã5»þ¤Ä+ÜLvæÎ€ÌR×_³-p]díy:ÿôcžá£†zìÍ®”0ÐHªa*kZÚˆVyá7ÓðÆê¼0kå}‹h‰ï2toïžÖ¾7{™Ø¢Íù‰< O61ü ü0·ú¸=ùÆ$f€•ß”Î[ýž_­IÌ?)?ñÓ^÷w‘vjŸMbøYù™zóùÙšÄ á£øwƒ#hœÅ´}ÒîoUè*” ‘ó¢ ÕoWõ ¥•6š`úYõ ‡_¬©;ÒõÛ(bÎÖBüå³ây> Èt#)K®ncD,Y±HÖ‹ðÓ"gŽ:󕺨ËÄ=nØñEñÞ¤Ú\i{EªµˆàW凹Š5é–ns}&1ü¦ü8gÈúÓ/š¢5‰ÂGzø“_¹j[êíïkLbøNùyîœîO—¿X‹¼W|áR¤º½{ðá S•"Êyñ´yÊÁ«»lÓ!²rÆK'Ê?—= Ìp3#•KW¿gÖÑb o nœ~aSºBB&3§q&UÑÈ%5r¸s£>&R³ÿ=!y9ë2}NÍ'fZ²˜¶Ö5ü­QçK€+³‘ÈiaS TÁ°ÂµW@NYÅ.ºÀl‹€ÒýNˆó‡nžÏkoC[ ™¾yÑö»ƒó1¿`æˆܾÈ*£ò‹zÐxhŸË]Á©‚·ýÙÒ^¢kS àU!Ì‹^¯­Jv× K>2‹)P·}>Ç;íù× Ö*†@ ª@äèÿh¹õ|ª5Š!H*yw9üÎÍ[£¬… ’Ûé( £LErÒ†ãeñžÂ`zgC5’/ÿ±àÿ^p(èEm.ák91óÊ›Ÿ(ÚXrJÇhi/Q¹ @SÏîâÒö žˆÊ[‹[¯Ó7(‡rõ×íOþïáÚ£¤µ,¾ ¿B¬[Ý Ëï äE¿±t%R:Éøkù!’È`ÝSVQ+õ2„w0nòÿüÅð­·3!¼hÓ»¹ñ9Vû o'»àYÆ0îÃ÷ÉòVëýG3ÜM”ÚNÀî Y *Π.Œâ?ïÚ¼¬&iÝ{¨K4†kN½oŒ'U‚ mm™ãÞ·i¿&˜á/¶E↧…e¶Ób—·Ä/ Z}x©:>hÜ#MÅÈy„jÕ#IÆ@ÃD7^˜ŽZ´¶lÑ]µ#ËÌ”Œò“=rÑ\•(¨*a KÞ* …­ZGøÑꢇikûSÈßtVM¼ªç—üò)ä…Úxi›=j‹LWŠ‚ Ža¡Mn{&6‹lÈêýWàPÑVüó£U®½D^¿/ó¸Ã¹‚vPÜ-Nâ²V1õ˜ªÀ¢VEì¢5Š!"€²‹ºÚÔ—eÒëë·–æwÆ£ÝÕDx´’Š\¿9LSæÕ…[òï{IGénä|;ûûA}Bb‘kzd1þ–àIíÚK¬ÌZôMêTÂs“[xÜ6íZ˜Å(Ä[aÎWûëûð  ³˜" ¨P¯qáJ#ž1;ÜÙ55Î6ž²‚NauÑòè5øî1òU÷Þ7Yæ©Î:-œ—U—ÿ4Hy$ì}¸€Ì"·"»¹–……#Aì‘YV¹ »£j˜mf-{‰²lLgw¿[ŒZìX‹v¸0+«ì¨.U ðã÷Å•_ÌÚ0/…Š\ZÐzjTNgpY£ªÉd9×ÃpY£¦™£Y5,Ï@DE”] ØÆë§[5Z«˜" H¡®«ðuÖÎm:ïa¤l¿>NþY¿8+ÚÁiw ÒÑeNʽZ#¯³*ºÁÕE?4Méß058o³̺»bG=üésýÉA"®º½1¥+48$ñÙÌ\z«µ{žü^:Bâ/3‰³(Ó|Bâ+Åvðß‹2jÑÈO>­þAlj»6ˆ‡VVóøç²‡™n&W$âñß0u”²*”lØš5ë@×þ°;³¯…] 7|ƒÿ«éJuŽ7ãi,ï8op/-éÿtqØ»ÁãÕü"†L° Stl”‰Î5ìž ÁG}o4Ê*-eUÕ°›j:³fòÔ#»‘XÚÅ(dUðÜmKãB²V1E$0w»;üºí²F1U¢9ƒÃ5*ÙÅ4ÈfàÞáwFšÅÀ' åsG|ÔÀhÁ{h‘7ðûý ÃÀt73P3_öL¿2Ä`DùŠ-.¢Mãμì6&EþY/Š’ÛjÇp;ÜŸ©mµ@_í6² A |Ä“È(sfã¿+¶¶ ½‚¨@8Ÿ4âeMc $¼J}××n.V¶†1A%âo¼`c·»¬)¸W°}mè4ïu+'¨Ì–2šš ô K‹µ…9¢Nzcñâdܬ­I}Õ¬w²¡á\[e¶s¤Gÿäâ…ý|K‹Tœ>|6|•;²ÈjØÞk¯4Š]¹ãy, cÌ??ùÂîÝר$¿¶ƒ‚»¬]L‚S…hº:.“äa²U €WÓýêôc¯Œ²·º@PÌ•Éè|¹ÿ¡-¹¸\:_h i­aN“Oú*œ± §ÿ_kêù(ÓMä¾ä#­ø©}Xf3 Óó…ìÊ&N Ó—Z‘s´åßNÁt¦îÐpCùèÑàZH{€ˆ Ä¾éŽrÎ"½³"¹´Æ²û£ø| î†N3$Å3ïPÅM¦Žˆ *)»“\î+j·ãÕµý™æÎ V¥â¥!‡y[Yt æ)§¿èåJ}¤){ÚHvh¹¡«•Æê¶,V]¥ªJßR îJ‘§•†7w¥ììEÄóƒ¡ùˆ{‘dmcŽhÈÎ^4gÄâžÜJø…eŒ„S‰øžËuÙ)Ô`Í"ø^ùYÑ· [!WÁE\…U¹$š…ùÅK‡î_»S;ÔÝPv[™³…¶ïü©]Äß"DÃ&b«±êƒb»v‰ ŽgÂ+¼“ˆh(Pˆª`X´¶S@¢(™Å/ Ï몤hu]6á]ëüU¾™ºKí†Äu‚~YŽÒïâëIÉù$²N&Žˆ¼‰á$¡4άîTjØ&Ÿ?Qúë±o2J;´ÜЩy€vÓ;@Wm "UEL+×{ÿ,¢íÍŒ—ÛÊv¦þgá.–ã»ç£#õR‰ðÎó;;ŸÎ¢TkS àT!™2A’@[c²‹1ð*‘ßavæãuB>&Æ‘hxS ìÅURÃ+O½O.DÄ5<®\.•½ƒÝXCÅÏ{.ݳ  vËe{û—»DÇnh!¯K¬(²•ØÃ‘€ÛFYÌyIïÌÙtò[Ç&ÿ\ö( ÝœW†ñn~ýˆ¬ 3 þ–˜‹=‚®ûž%ô…fúÝA%<LJêþ$°d«¨*%õ­ü, ‰?´Æ øIù‘[ȧý%BóK2‰àgå§wš³ |täd“ˆ!|ñßF·òj¤kìK8ÆÐŸw‘ù(@aKöR<#Ù7­m½6¡0“ß´õåÇgj> Èr#MnSÝ#óÂŒEjS—¨*áØqÔFa•pÊ´[€§ë\a« …6äå1ÞòìÅѶÛÇ„ LîЬKîßåfº™tðèqýŒÌ ;øï»BMßÿ¾í:õ›XqË©™y}ñË(•ûÜkŽgl[0-*ñVinóGã¯ka!A&©Œìä¸ðt…®…qÌFVøR«§Ëe†…¢ ™½Ôõ¨P­YLé^]\,K‹¾ð#­#5áàcÿ`ÈAšW)“*lwÌÕR}yy¯ý)Ÿ›nŽ)nÏ+»˜…  žëÖïaO _™­bâ-0:´Ãàæ!›Ì$ÐŽOŠ·=¯ß“lKÇÎÏÊ7c=âáú Ù†lbˆ|]VýDZÈÎ<l~¾›yaB»™™>ßõÚ35¬hÙ|Ëœ.n1ò%×½„&€Û¤Šòt§ ~ž5µµÈF!ÛÔm€W0{MG£õ@°F1A" œ®QÊÖ(†@ ª@š“nƒÞýûKdŒbˆ$Üþ«¥RÕõônÖ6›ó*Ð,ÙB*735Ô=S3&Íš0¢Qpa°)$ç~qÞ¹ˆFI9qL¹ñX™8C(é†R“w{fÊ C˜…¬ rûNo›áHxTÀÀ^²Š!(*`v1¿±é'…|Y«[«—ŽCØz]:·¹òËÝ•Y/xt$ˆmNŸ~ÜpYÃ#ðè8¤3Γæ ú™íb œ*dS´ìÓ^¢ykSDžu·†–n'9a0 '⟵Ó4´p39Óž™Äet&ÀK¤Èôˆw{Úg»×¹ã„éQjÇ¢Žq¡+t„Ó²œ®9Þš£€t7²P÷¥1jê Ò C„W ›ø·W@",[eóþº@PÏyÇ®€±‰àGå‹{…M @RÈÍ ýþg}cCD@ Ì"Þ¶œŽåôæœïMÔÙ¡|¨È?ËİŒ®‡Ñ¯æÁý²P(°ÇQÞ!’£ü’[5vh¹¡ÜV#˜Á-,±Ý>ºDU G'õò' |þM»™…¦ ý»0õ£?(è _2ëmV#1]ªúOn·÷£B\˜Å(8UÊó¹Éq:(äjÍb ¼*˜ä©x:‡”fÙµxLAú’rv8ÆrºJu•ÓåØå3^ «¢Q1ÙUÉG0È?ë¯SÌéfpÜ,Db¬+™l/Âg fù\LËO㉗;: Ìr3yØ/Äô as˜U™wþ'×…Î !Í;ç†Uº{æ)æ/ŠªröYG†™éÑHm‹¬  ¥@"ÞuÕ´ñY"µ…Y†‰¤žîu8 ¶Š!È*h°Á=õI@6Æ&b€_”/“¶¦-`ÚŸ‚…d3À¯ÊOä}ù´ÿ ÊÂ$bt~rà¯ÈŒ¹v~^.¡|g.@ ,æÎl7“ªÿÇ,¾Gd]×õqG™sx+P΃†2ŸFÚédÕ"™#Áç¨_6ÞŸCµV1EYò~¾¡}ûMŒœCK:PðsãLÇZn¨éåÔ¶@ZDªŠ8®Ì?j¨/|ÑžŠªó»FS ÿ”ܼÕ0–1F$àWóØ?SóO—ᲆ1N%¢ôu’Ð9yBmþn‚k TÌq¾PW²†1A%g%$y cŒHH¹k zR¬ksÎw^sŸ…—9Iê[™¹(}K9ædS UÁñºî+¶Ê®6üwá²±’O|cÓ"à”íGÍôO dk3ÀoÊÜ÷¤¯1‰ÂGÎÚ4QOˆ“ý “˜¾S~ùäË661DŠ<¼Ø^•n¸¢Yk&‘˜“ËùÀŽE÷`ø|E…{T¢ãŽÝ—”tN)ëóq€¶jêOÐÑØ˜lYT\æ wQ–ë7¶är>@$hRW‡ o]"ÿ±®ïÿš˜b°œ«öæ÷T&Û¬t’j*–sθ;´w¿.:pÙÓÁ[5åÎj¸©<áôL½ëoæ?XL_í2QeŒ+[Ç?œUŒuöûš± ÅJöîõ¨¡õ¸ìe7>…Œ]©úÀ¨À²$j²v1 E¢iÕqü=0L„ìb $ªJ¤yDxº£”ûßÂÆ‘€?ÔEPs DIó:Z+.ï¹M«àj†ã>èbvö&ޤ‹'d]Í»6Hx•p<yÔW=)Œ6«³U @P36ñ><žC³FÙYŽ] ª@ßLÒ8gOY(f˜£7/ lѵ?$¹O XZYLBV…į÷z0V1E2_Ñ‘Yóø#\Ö&f¿áùj«Ô!*º“ºÅø¿‡û¿µ›šG½Ì¤j6¡ “Êu)Éô¥ÐWÌÞ¾¤˜fëëɤQ÷=õ²Æ0^%5lxI®ÎV"WkSDAšŨ]Òç¦6êÊäe—Žú #d°hÈØ™åfFÚüŒ6˜Ï̸0Ä` Qo ît0a>k,ˆ#ÈÞÕ¹‘äÁ-ªA]z°>ú¬p7žã‚„] Ù 0šŽ>!˪ÇÌÊ?QàY‰‹^Vš7½‘Xy'±rA ª}ÆaÒ°ìy稛6½IQk:Ìa`†›É¿ J7̆,oì³£6ŸöýˆŸí$üÂ.¦@!Ý <6á Ð.k•›Ð² „7=%_ 4ÞµÚ‡»néë6g¦†0ìŒQ i™#~3ÎùÖÉ“N @^Þ—Ç^Á$‰•ân&OÖ-מ©ó=MI½úÛ5¼j˜Lè|ÐçŠìZäg—TAÖ%SwžtPМŠðQŒë´ÝUº¬Q‹p@AæRD;±ÉÇòž,ŽÀçO$¸@ÒcŠLâ¿>¢ H“ý6èøËôÂêoÕ|íF&ŠŒ _ý#re†¡ˆŠs#6tSPpÌ*z–€¯žÍbJW¨HÍÆX)“7 ý'3li޳ɨÈÅŽ«âÒP·È°Z $ªJô3ú\z}“mêÂ*†@ ©€7=úóV@'‡Ï61Cøðï)R¶|·0‰à»›Oûb¿ÿU‘M&1CøHÉŽe­Nã“>¿û i&Ûb'¯HÄÔ,oÊšVMÁV œ 'YÄxò\ép®FYYÆH•äÃÔû+a†…ª f¾b¸ ϙͲC»B»¨Ö+Ä“Âzì# UÄw´jaZßyÌÑ“œ½ˆtÿß…&d¸‘eš‡T4Ûà©“ûÈ CDT 3¤óžÐÄž­²£ûº@RÏ×°Ô­@ Ö&f€Ÿ•¦y|Ec³ûô¢ôHýOôG{Æc…É»|U|š¿mU‡ook1„¸KDŸ“H×R /ëîFOõ¤Ùö8¡"Ÿ9-j€´ÏŽéVúvî}g¶›ÉÛºì÷Ì´šµÚnVx>¡ÁƒÊBÞkäÕ6x1¥¬k8Õðk×áÒä…]L‚W…`òÎ'V1áÈ”#–g " ½Ê"|ü³‹dFØâüQämnéT¦Èé{æËýÓ>"W·±¡@¢ª„ã1K¡nô‡55¯<ý© 4è×p*•? Ô…MÄèü†Lc,,x™u•™ÈÆ: ?7ˆëÈt#ç>íiø+Ÿ™Úª×ö‡«üŽlpûA£Q+„ê·£h” 3hÕð'f]Ù¡—¢Ä›n¦º¿¸2¬Ä$@4ÐVY®#Â:ÝTX²HZY-Úz|•‘ßÐF {t92ëÂ>@$=œ´Ýæü~Cš÷;Æò|Liä¯pCº0éókGS§gäÈ%¢@Âß•Üsˆ ?Kèð2ËP TÂñ·œ· +ž@ ÞuÎ@<]x‹3 á#8‰Î®Ío(¼!d=5 û݃\è¿Nuͼ•Pé¯í@¨J¥Æ´­L1#/-†æƒæ5°av†b¹PÝžÊÂó}Gn ·‡ø. ™<4dêÔtSM›ËÔ‘pNèî2YeÜœÜP¿°ãM8=­ŒºH¹EÌ©E„bÛÞ‹©ªæ®8PÂñD.ks Ñn2'náE±•PW$Å®#¨qOÚ~fÞ«zóù ©«žM§½ >š¾ð'²3ÝÍ4lâž9F*›o$¿E»†¿5–áºFZ5Ê^¸³ºFP σ‰Ç ¤ýi°]LäRâ~óì§Ñ•ÚÜÈç52×Äw4v¯ì¨éÌv3y4Äð>2ul<5fdE¹°—Gø„®£o{ ¤Ú‘ö÷E%&øR¼¸Î|[XeÒÊ… Hv«%íh}a]¢­Éu7ƒ^¬i;µÜÔi–³Æ¾wÔ‘Äu¦ÄHUÛñ(4tÈ&Yfcj]¢©„iwžOG‡ïš šùÃ’í}>Jlž²ÿ¦ {Wpª¹ -†· «–ì¦8±+xUHïk^ίRZ™E(„[!Ìû¼Q®µ½JÆ,¦ˆʹµ%$u+Nê-³ðÈù+˜5}“eõ~3¹Ç –úfZup^ôÞéùÖàí(†~ÖX¶üÀ“ƒÛ{.N%IöÀ-»BU…ÀŸ˜’ö +«¦æn«by«gÀ!K 7­Êô-¹»Hiõ ˜Õ¢C˜|¥•Cî‹ ²Nu7ÕïÇZë™ê\]X³H+è2^eLW²vAîÂ"³€QºFP Û’*44Œ²cLOª®o…4o­ÇÂ÷Y!/:e1E†ËÚs„jµýR¢¸Œ7Ò_¥iÙ©í¦r‡×|¨¹.ŒYôž-eyÕ>¯iûã›DÑßGY0»ž;³ÜL>X³›7PA³ˆÆ‘ǵ8äÃgL¼§¼ž¬½Æxb8&ÅN™Øœ`Ô¡é†ò¼Ž–öPœîb®óŒFV ××s5¡»öZŒ@†1E%<¥©¿{wiĶ‹)P¨ªLXþp0Û—¬bš HœzþHú½A&ß"šO$rÉ2Æ#Qéœ?œB³@Cé )íºAwó›§jc›ÏÝ šÓê*¨ß›ãŠ‚øÜKî¦kÿ:¿/”ø\Ó©íâߣ>·…'v¬šŸ¡Ëù-+/±‡W"­Ì? šÙ[þÎTø¶ñpS¢ˆŒrî…çæLÊÂ4æ@#ª†¬µ©_ÑICkÖÉ4æ@#ÝÜa |£aLc4²jô{wNûB?<œ‚8Ð(·F›}TßiÓ˜#hS€å÷Ô#ßå»™;W²Ÿß4k: Ìv3¹ÉWÞ#G ,²è=V<ü¸å²«á£Ù+»‹t¯n¹L[Ö“€Lì}Nùí|¯üÈ»Îo½bÍ‹ î\ÔEiÿžoŒ"øQùéÍŽý¯f£"(b(«!„½â_Ž ´MmGg–›É tèš¹aº²0d‘××5ªj¸7]@‹·„_ÙÅ(4U0žúz¸0(L «Žz¸õeÏŒZ=j–†Eµ”ãîtéFN›€¾h¨q‹„[˜Í0Hd•pœ U®­"ÍlC Pn ÞöxQ‘MÌ¿*ß¿+5¹öZ¶3ÛÄ4”8 èK‡¬bŠ( Í'FE{oÏAÌŒÜE¾Y]J¼±m>uü47#È[äˆÃ“!¨v2[dÿyWÈÓ/ñ1MA†Ðòú !/ͨ]¥)dçƒ:Ý¿Ý*wЧ,‰ ’ÄQkâÌ®ôÂ+§ÐgyŸ/cg¶¡‰á Vîüs‚ªíl ƒD^¤¢¯¹ù7úR„lc4œjÜP' c ȵÖVýü1¼Fy¥´™èßse>†ÖE›ŒPæfÛ"Çc>†f\Iר·F£eBK[ à²]†‰¦î]h|º2iaSDyuhèÃÓAAƒdSD@ж1™£ÅE ¬i²Žî¨?~]´èûd¡(kö[dYU] $²J˜1½Ímò‚g (·Àœ®M÷7WÅ#6 á#¢©EÓÔPïwˉ{yþZqc¿Î 7“;Êã©2ý¸Óm—ˆ*ጣ%|#a:Ýš<™gžjи“ÓI —‹Ìb ²*n7á¼?žƒ1‹)P(ªͰ8—ö Ú€w6‹)P¨ªÌÀÀÓï€1 dS ÐT!ÉIA=äü¶Þ’ˆ€fYÍ™¥´™¸^Zä÷—Åyãén¦ c¸tÌQçÄqa‰p–¶(ˆ×^í‹Bý®TÃÀ²?HÄE¥>ÿ½( ŒVW£4•Ùáëàîÿ|ós&HDkQwÎ^¦¶'jäiѹŠÝ_žÔõ§§7¬^˜e(p*aÂþõpyeÖ"!©Z±_¦Èï%VV1A"÷ÈuWÞŸƒ_XÅ(Ä[7¤a/pekC T sõ’t—ÙýÌÁÚÄ á£ IU‡>Ajâüô—-<õ \"בåFr7hûˆ¬  ¥@¢ª„㬩±îyTÈ «"è"ò݉DØÒ×ÞS›-ùœÆi¦ˆvh¸¡™ƒ'Þ¨me‹A%ªŠãN¿³aE`†5δ¨è"IEÌL®{pÌNä²¶ÙQa]#«†©qþü¬Ù1dš-¾îE5â;Ο÷rúA4‰ÂT_Gó}‡O©buA¹Gí Q¼µ‹)¢€h |h®Ì/Å2‡©è®“¿ø=¤»‘‘¼u,  ¥@Âß-Ï_ñ–·xM°Y†‰ ÞÌÇñ[…¶àâ-@AÛ;ñüA@SJg›lwI¨é¨«´‚¬×ˆ}G2vØ}¶:1  5`r2:3l˜ËL‹U–X‚« |K=Ø]†­~ÜÇÚWÒ—ñxiêú×åocB–h$·?œœ¿d•^‚˜UÛÚÓFNN¿¸ÿõ.3I1 QKýÐqÍèu€æ•)†‘z‹Ôéýä4ú¿Ñu1™f8i*b*|'_5[fëŽûù]*áßmöd¶“D½¬]L‚SÃ:žD»¬Yü÷¢€¼X)™rÐ5œy aëú›TaCÈ ýwuõEk©S÷06†LˆD1=Ç:q/a ³E Iÿm‘ˆ¨X4³^øö~æ›ðw+!Í¿­Rñ‹î˜yaÈjkàCL‰Ü,X3l$ê:uÑxœd¸Ãh‰~8‡Ô¬QÄ<òÌ›[ìf«vµ)TV ‡mE úzSYÞV¹ƒí€|ØTs‹’áŠi‹m…º™Ÿ%ôvà”F»¯ÈpÌ Ã—|O‡Ë2Z‘ÎV1þ œ•æOÉØÄ ðƒò¥Ýò‡B³Í%òÖ&†ˆr³1ˆgÊG”œÃ‘bhB¤uÚxÑa`–›Wwã3Ò¹Ñb QUÃÝY„OL]¾²¯ ˆ¦Oå‚‚x&–‘mÌ.œ /€Ó¨{`´60|§ü0·…Ðé ;¾Åø^ù¦EUö[>ê©È$f€”Ÿ9˜÷×'¯L²aÉŒìmìÜý´Ô¤@ÛKQʩЦӽÒ(ó˜4ÝÐEµëªeWdʪÜ5Ã-‘FÞ’r´ü¡ÞÕxq2Eâ(ã{áxuÊ‚h0¨*±¬u¼VÆ.ÛK³d4ÏhˆØMùK»çõG}N0•o©Ÿ¶ßt á†ZåDw‚ú…)†#"h wÿäJ£Ï®ãêþ/Ñoÿ7ɈÓÝÌL·™»ÊÚHˈ¿E%¼ŽNšîZ G4Yj«ýÓæxÜÔ[ü6¯Ï4vk–LÒ*[^ö_e…êjoföî çÒ:pL=}Ñ$¶ÍúÍ2üCê´ °»Þ ^%ÂÜgG£bÛ+uY³~P¾éG[Û^ %c“íRÛùQùfú*åv÷O³61¤ t.Aâ7?îA U*eîË÷kŠg^<JÀüL•Vö#›é‘‰^(ö½CÑ@Ìd¤ÞS§’SúÚ¼~‹šþv¦ø± N(ÍÍ;2GÐÍ?ò<¿®‘oy6˜{ù¯4ìD¿j5Šjøw¤ÌwÐÀÔ:ca QU"˜QãÇK…G‹ c $šJħüˆí•2†1F$à¹iÇÁ³£¿0†1F$!÷#w€Éú›üÄ%´ÝŠ= Èp#MJµ{(Ìá|íX¥Xä…«×”³"Ÿê††–WÚkâ@$©ˆÿ½1¡áZ˜¢W#+ÄNÈðé`¨´åÃ)Ñ–tÁñ0mfÿŠ6­KúÄd ¯Ï|(¸íærA£»Â™» Z”èˆÇJtlRÅ(oßÉ\aeŸM«(âÃR•öù”¸ïTÒÂ:AÄ«Hà?®ñ; ²9Ъџçùs5ZˉxKL9 è}@|6Œ0"!½%Ò…œ¼9ûìî2çJ‰#9I|Nº§£€,7rºŠWÖ2Êg$Úª³†‰ªŽ»ç­@ £·îø¦xÿ”áâ®­@38Ãèüz]ÊïÏ-GÍÖ½ýú$›§fÂñéek“ºÜoܘr5'¬Ž…^etÈöþÿô’×'Ѐ‡6.üzÙe÷4?ù/ŒûÝZE áfF”óy»ßx»FhÄ[ƒ'z×½Ùø®²]‹Aã¥&Ü0:ï6=ð&¤w›ÊÚ^h r}–ÞåÔän¨éR¥;úg¨&ZÙ°¶VMþVáþ­?ÛNÅ-zrYT‚ªô77ynÃéT4Am#4¢jxîeïâI#xkc ‘TBZdÌ©·˜¥µ“ÐJÃÙ0Æ@"«DÿLƒÛFêäö,œ5Œ1(*aX.ÏⲆñß‹DÆ@çÌÎÖ6΂’è¯þÑÃf> Èv#M§˜kÏ|š n’j¹Tí÷?Ïwò¶iaÃûŸZœJÈl·Å.n#¡ÙÛ³]L‚WÓt^ž·pÆýRKP;PÑ~ˆ´hÏnÓ»j‰* IÒSV›¦(oNÁ/*Î(¤[÷Z§#È,þsQ¨xŽá‚¡ª1ꈺ~ÉÞÉcªj-7’Ü÷̶¢_×./F­õ`gAM[ýôž}µ6U0éÙi š0d<&g»¶ë Ô=ƒîéªGk3ÀwÊï:¯%rØ_!oMbø^ùñ]çq®{~°&1£óÛ…GkÕ*I=äù©í£® ?’ÚMÞC»Ò 5®‹tí¡šïÿÅì¿®’o36à:©¤kí½0Eqí*ªÒ×ñô‰?]ý°mÌFUÀ;@Ù¦/—±Œ1h*a‚ñít©®`íZDã›»n…¹¹ÈK×лé²f1 Nµ1k¾n×ɪdš˜5g N<Þ|hŽfå 2`üo;i³×h>ÜH®Ê©½Ôì°¸™‰¨&ç#…­Âhñ?[µHDi>ÝmþcŸ’Í—7 ð³ò…4eI¦ÃUwÖ$f_ú$lÒ®aDH›ÙûâÝý—Ÿoö/M:Ž(“§íÅr`º…!‹)€]Ãß…þ<]²0Ì` nÏO©<>§óH+à F4¤ÇFr:xn‘´›„㙘”ó9[–›^4骡LÎ`ËáÌ\4r²™u-_·F#˘µô¨‘D‹†S ÏKÈ’~aS àU!ÌÓ2¯{âÏ£‚ÖáÏV1D¤ö"aŸïæ$‹ M¹ˆ¤yuuÿ óÄÉM¡É!†Š G¼•Ö5è™2ýL™c“¾¿ÊäMY>1Wõ–«ÝbƒoÖ¡]È\Ôð÷xÒÈ‹ý§Á@¢¨„çæZ#Rü¨ ïÈ.¦@¡ªB0ó'üá$ã7=¿Lƒ´o­CÑÙ´€?_&­µ#»óÏO½nz<éäâí¯mþUâÃßÀ>½Î 7“3òFoóg¦_²È ìQ5—”ƒÙ%-ìb ’*˜ö%¼µÊvGèYÂüÌx]Cí=¢qÞ%äæì~†…Q @UÄ•g§3ÈÅÅø° ›ŠBQ…8Ò:ÿÒð9ÊÚ¡N¡Æ%ó‰Õ[b]U]Âßs]¤ÝJ¬\hDBPÿ¦ÅËXË>+ zIf1E2nϺ ú:-EçV/Œ€úïÆßÎ,7“s«ß"GÐÂ{M–eרªát¬Ù3³./<™p˜"œŽ-qOÔ&îøÑÁx[iNê’42hM9¦¹}¸h±Þ™éfNÅcÒ;`Ä›Ÿ˜wÃgn‘Dˆä[„Ýöã ô¨q¥…eŒDQ «<M„ÃI\Ö*b_ȧwÜ3_ÛÒÎË4Bßn< 39ýÕ[“"pË9É^£dªvø‘l!£§¦”¶í€–¬M¶¶ó½ò-)ìo¡Ea®ùë.à¤:#ùÅS¢‘üÄ;_yÂ)‹7þúérR’¡P~C oMyýt™W•ƒKQ+·ç—xM²JU·3`ºDR \Ç«l'Q—3`8äß²*Hå©åŽß>ŸD\Åüg Š*HÌ4Œ#Ÿ~м0‹)P¨ª`X˜Å¾UÖ,þ{Qª‘ä5€–šÑnÒÊÆ0¤ ÿ\ö8@Ý M³û+´O¶„1ð·Äì?ïß¹pÒhÖ0ƒ€«ïk«r§%ÏF^âÕù›‡`×xNºõ*rnæÿ×&é‰YV«Mƒ xËКÂf5oF£¶ËDóº‚SÏ阩±¹.ÙÅ ð½òm·ªpmP G6ÙfU] ¨€D§D·çkªéU5AÀÊO¦e‰?ü—±‰ÂG8Õ¯:Çõcõã5§t!fÓÀ®#Ó4¥WÝ!¡¸è`gJ.»FV ëTž‰G‰E çÂÓÝÊ­À¹ŽãñzRð‹’K›çت xN¼[µ= ¸E’#C ÐT ßJ8\£ËÅ@Ò©6Åñ$ Ôg£l‚cuXXyí,FñŒ1´‰’µå…ÝUm|OŒSŵp9ÚQüŽ˜VF,B0]!ª‚›¾K]œÚaÙD`føIù¦OM¹vüà­E¶{NÇgųVÎ[óçÐRÙÁgé1QkNÝn[ëQÏC1øªød’?ÞY‹˜ÑùqM¯©Kó˜´„ÌóRAîÄNá×€G SãyìçÈ[¤Þ’dÆ"xÔ%¼J˜×R9(¬¬Z¼+}ÄMƒV<äNŸSšB$ï¸×çÐ`Ö>–›És¼µ'ý3ù lÈb¼xרªáLùùx?Ûý0`œ7@>6•ïºJLÛHŒ´³aŒ $˜¢T™:÷—xV0v1 NRÿã¹òêx¢5‹)¢ ==RXÄkÔËÙo:nš#áÚ¿)é&ÊÓ‘éF&Ù¹-RÃí6Èû.‘U°F/'¯òŸ‹j!VEs22"ÎtZ à½ÌQ %š6»!ˆÅZa[ÿv¨žªN_>‚5Š!H*Þ‘®‰Û ølbHÈð«1·º~]ü{®b\8Œ6‹ƒÖ”~†þŸŒÏ¦M”õשí¦rÇÐt`ÞµE¦i1E`û³{©†82¦ÜÞæ:»k6Œ)Ppª`XÕŸœ5‹ÿ^Ô¸8ã;ï•:›ÂßýÑ®Ò^zéB0j©©Åoõ[¤vÊ]t‹¦¦,]¢ª„ãSüõÙ¬Ôíχ>„€Fwsfo û«R¬Mvj{ ð„çf/mÙ_u4‘!“˜¾S~_ªÍ;uÄEžù%Y“˜!|T HUô<‹¢jƒD7§î´á×½W5|áêÖ7)edMüåޚѯw~˜bÜ™îfJH'æ‚h1Ððªa¶#5÷QB3ƒL2ƒÙÖlÌPrEö”“‚Ý&¢ Žä¦²€7ògÃDr6fZ è>w²¯Tg°0Š!È·ÀÜ•C;†ìª5Š!] ÂG–ù¿^ß8uîá(Y•Sï ³ÄŽÈ5 šþK9$#›þ‰ Íeö/e‘ÔˆmDL[ë“Ȩ°ŸM[4¶î"NE¼ü•†ílm¶¯5M.'×éÆ.¦@!¨B¤f«_*YLBT…dšÁ}¡`ÌbŠ( G4h}=Õ(]£8—HÒ×|> Ìr3E,›Š?0Çô²Äp RoÚ\¿—Ð()®5{žè›*ø¹ßjúí ÿ ïÅ á#[%,*ïGg°'>:’I¶ ¿óÝÍOÔ’Òí/RM €WÈ¢÷?Ú8‘Q @P4·ɧ_ Fk3„x@t‹7ã(ž+t#b×¹}EKOEr{Õ»xl‘¹hüÚ5²jˆ÷hv½‡½Ä(ž3%ž3E%üìv¾ÎºƒŸíb ª*ô¯5¥£ø³‚1‹)PhªMÎ鼊(ÀYÝóëywƬÕëIÆh2B‹r­7ÍÓ$üšÞÏf!¥¯¬2?ßZs‚ŽFf¶R›êbºJTgzÃ\é$‚ÛÔg#’n©èˈó™ Hšl[­#à—Ò¢âya“¾9ÕBÂ,¹çmo;é°—H¸èW#¢KªU/ºÞe‡êXïþzaLÙ|gº›ÉÕ ÚŸxÅ'ÒVÍ›:Š.âUÄW”?hèJјFhÕðüÑ«'‰1Fa2Œ)Pˆª&o–<§³Ðž°ü-ž)¢€`MT§ÌÜ{F<Ëò:£_ÌIþL‹0½ò:´ÝPö¯Æp€¢}×¢Užñû&xŸ£±ñ£ˆåY÷žõüò8û.áT¢Ãh­x’H »˜" HÎŽD¢Ü‹ïFä°¼mª¸Â­#ËœG¶¹{*̲­ í U%°Ïi« ®É*†@ Ý‘R÷W%/lb†ðÑq$j‡È9×w„@éÙìoNy}\w“tœBº™s£/¬Ë·Ìöt4Mz\RöVÇ­3d»‘™î€ìöÈ•†"p›ëS¾X(<+ ÎÊV1î°é™;Œ5à’Äß+¿‡©wÆþª‹<›Ä ðÃÍo³ÿ¬ÔÓO`LbøQù4oGçŒGû«5‰Ÿ‘arnUùëÒ›·çÒÆj^ &6:#©ZÓéoiϼ}zÜ5ÓÆè2|æ K‰95âv(=ihpÔéf š*øwœwì§³Ð{}¶Š!"ïyœn×Az²Š)Pp·uÞ®Ç"Y³˜¯ ‘«þºo7÷1‹)¢€Ö Ú% êØñr¥ê4ÿXß”ÑL!i;Öy½^¯-²®Ì0Hd•a®tÞ­Ó&¸¡ A PTÀ›}ÊþòÂ&f€_•8™&íùå²&1CøHGØÓü¬º 6kòZû×Ï_Dû»"'Ì© Ij£‡ËºúeMQS†#XÛjPyðAb´{eËì‚<Ã1œàdX|7eaC U ð”dík¹HÖ(†ˆÚ6$m@E増öÍ03ãÔñ×È…*2·5ý’ëFGS_Luw‘vhåv÷ðâm\FÂvÒ\³9–{oã6Ø+¬wr3IdàXK؃QVÆÑxÝËq ™8Ðp·…=G½ËNà ^%ü»’'ûºŽ ˘ ÑxÊù¹¬iÌéSIñzOçît3ë(-½Ö€˜ãM74R Ô˜þÈÔ 6Åp ’o‘ö¹‘Ïv<ž–1E%, )`ÛóˆÖ°…³¼ "’õgê-—Åí|rh«ö±ò´ù²yñöÀˆñ R_*æºØwP# cÔ-©êV!/›È›¢] ¨€ç™e/‡5ÙÄ ð£òGÞ'€!Pd3ÀO7ŸÆ1FÖûIÌ?+_º•MówK÷ÀÖ$fEþØÀzúµ’¶Úâm'&j|Ì3³÷ Šþ5÷øó÷qíî5ñ„L+3 E$àßÉZ59ÿCÚ[½Z $œJØ&û“ia•ieðÿ²Ìú5•timereg/data/bmt.txt.gz0000644000176200001440000000763114666545364014613 0ustar liggesusers‹]šÍ®å8Ž„÷ý‰ÜwBâD=N¡Qh4P 05ï? eŸ“«¼p¤m‘¢Èôùù÷þûçÏ?ÿõÇÿý/þýŸ¿þøûÏ¿þü;ÿüã߸ð÷¿þü믟ÿø9þ¿†þ#ÿ˜Ç×ú1þñS¾./ÃqY?.Ï_¦b—íûòW\öËÿÌ¿|„áúúúïÛ¦×;÷×;Ïœ"¸ŸO™¿Nä"qý<×gþ!ÎÎÁË÷1ZKœóûúZ¾v ò)`™{˜ý˜©è÷-&ÊWÐÜtÔ¬WëŽE¡ žËp9ÿÊëA¡,žg_#Òs'J)£Eû޵—ͺ_×c:==ËjYrµ²—”Seü¦Ì¹g½CÊt9«”ùË}i½DÊô\J¿eî½k½R–kúù>kÓ‹b¿ ºlÕ.IÙnW4QÖ§2óY!åyÙ¯P~ ãÛËv[“š¿ÂÎàëϧ’–è´Š4-ãí<~”Å8Ö²Ýe½– /ãU>ø'N9Rõ·[bs½jßwøòCÁ{ÔvúQËt÷ëà5ãp½eºiCäH¯7^aâå~tð–²}‰÷³ÆP©—Øød ßnó[ÐÃØ2ù¾aŒ_ÓO!_~ÂFYheúò»‡º\ø¬2}gG¶Ñ'V¦o¹gᬌ¡ÊôôPß‘‡d3‰”é;®³B;¹œÏëÿÄÏ®Èòñ*å¬ÉÕz"Ï!Y¹Ú<Ñ^–‡?æY§½Lˆ~¹íÅ\åö)L¸}Ö²¼,?òD©ž5xËúMÁ-TÊöãv¶]¹â²ýÄ.KfæžÆÏÎ?{¨×bWÚ7ûsÔ5–•GÖ„2óÜW¢–2çJ)>ï~ìCg-ýÒîYµ¬„°Ç»;÷°‡"óná0Ý k•÷ÇQOǯ zafß2pE)!7gN§%çûºÈ¡°Ço‚õªö|…Z¯e&.ÛwÙn¶¯‰^Ik—í>ßlªá¼¥Œw»9~®CKvÙ¾¦¼åÂéá]Æ/»ÇÊL+èö~¯Ožª><»l_;n ÈÚ4¥ŒßóîIz”…$Æ+Ô²|2¡D¿M¯L&­W˜5FC¢lq›»ð䆽B­Wu(…2=ì9V1÷=Ö«T&ÏbÌg•íg<§GOB”éHH-œÉ çS¨º¾J8eúÙÖØ Y…(¤é’çòÙÝ‘Þ*A^¡ BT´}Â1ÖYT ŠàTÒ’Ì[¼„}·*ãwW ÕÂ%¨ÁüpöÇõÜZ7fß¸Ž¤Î ïRuN z«ÈÉëJ¤¥¬ègÍsøŽ9æUnÚòiTÊxŒÑÜÑ–ÊzÓ'5ÏmÍNö©à`£:—Ræ?!¼D‚œ2Ê|W½·¸pë3—rΣœÝö” –Þ#¬gÚ¢R>X/A­Éê7gù`ýä¼Ìl-Í/)ý3„L4§¼¶3‹iôMå„}ÙnÛ´t–öaÓ¬6ýSÊÜ¢­”ö¹é"|ßÅ•b][Gá(å…H–ºP±å†#Qp cóÔr‹¤üp΃É'š1e^¥“ïTÖ£)ò­Ì0àS¿¤ƒô÷*È£>F¯;JÊLЕUfW½ LiŸçß³´é|mæ§ŠÕ¦‚ÌÖ«Û}ôA†6¤ÓéÆHZRŠÜF6ƒÞR餽7= La?D‰ô×Í`9¡²>O]¶¿´ÔË þT¬$`Ö¥éåÏÂÔ>XÇ;F¼|à[nôôkVy`!ñ ž³x¶Vy`ë¾YDFU Hå‚}`£vB¹ pÖ¹ë´ÊgÌ'ÿfn sVùà¼õdï®4àAßÑ1 ôêŸÛÿîÄó LåsÆG[“)³'õ€Ìy>ܯY1ûQÒ¥æÊ=5o<€»WŸ¦Ü"•,²ç$„ XS8ôäG춬)Jö#Gæs9pS8žj¬[ƒL%Náñ½$6­â%Á­ 'iRß…FüãdÔ,'z!»´·Ëì¹zQÒž×Å{­c€§0ú{TÐ3|xŠ>å±38ÈSØçtmÎÆ‹{Êç±HêÜö”·›©‘ÉìO%Féµî÷ð)ìAŠž‡“U ð)·áàfó–€>å’þähŽ÷D Ï!Ç$Ÿý*ø‚è~1*÷„v?¥h»iiéèÏ9pƪÑÝ©lÇoPÙoºE‡ôµ´µìõÔîÛàŽèö·9ø~<‚;NÙ|qENßµé©ß]b€¡z‹Ý䀯Ç>U~gèÛ0Že €EλÛ2´ýU-:˜«Jš%½EK0å¬çFõ-ZÅõÀÑ”.ï¡Æ„6TH•#µÞ˜‘Lß祅œAºúHUkç{°¸ÔŠÒ”Täe§½ú#\”†¤Ó_²±]t1˜TÙ)wÑÍ3Æ/[€Ò”l?Ç%ÐÅOHpÈÛ"N³\òkÀT?béâ5-­†”!=W ©Þ¦gò‹“9ßæ”ÎèþAÁ¦©||kÊŠåýÀ]>ݺŠ(ðTW}¹õ8#$¨Á#ûsGà™¾€úhį8ý鄚ZRЭ0‰6\&5¥ý4éž‹JJi=9:tß—įúˆÄ°KWôm^¦V=E˜#zðÉ-ý‘d°R€ªÔnsAøR€j+]Åí~,©ÚýR]ñ8­} Rµ‹•ýéÌÚ@Uã×É‘k1³+PÕ²Œìuû=0*HÕÞ)n3í»ŒÒ‹æ›Q¬àTó~W³9Lœ Pµõ–³‰3ßÞ¨¦†ï3¢¿i+@Õ6†gÎ% ód€TmYW Ljjù UH/ò,³þ-PÕ¢Žo°F/¤šoEv*Œ~€ªÝ®h6{Ťœ.[üüläC©ÚÅ Þ6¼]TýÐÐ`ŒA÷ƒTSÂܨ#<[}Ö4©úè™)0Üúü)'»rŒÚá\ªþ ÙG3‚ÀªÆ ðà—ªúe ¾nïÅ+PÕ?>â Î|¤šJý*¦»™ÐÕëðÒpÖú<Í17¸JB+;½c  êœ*Sš÷ìSsÁ[’{®ÀTç`°—±‡õ©î¯«0T"¬Sº#w†_¦¦„3ÓTiýíSÁ©ÎŽÿ!ës(8Õ£«7mõB¼$æ—ÊÆ'F¿l•dq{±µ;€©©lâÄ-¡Sý%ØúHHüV`jJô "}˜@©ë#ªª((”ºøCœ{çì´L]üÇ;úì_„SQÀåoŸ£%£q9ý°ïPpêú€ƒ,¡©K*¹ßEîÑ¿2¦®ì[ïO@€©Ë?OÌXýYQÁ©ëŽ«ø¹Sš¤ºÞ¼„/ñD¨®¨¯,ý-eœG€êŠçCÕÂÅ<P]§ò—²ï·+©¦¶ô „W‡U÷×OOÒ6î(Pu¿í."¢‚T÷{–ê# ¥`Õ­Àä–,3x¿ê”D¢oH9Í@Õ­ô2øá]ÁªÛžT†qÛýõPu¿ ‚Ÿí®$ ÕÍ‘ä=‚IDý2+íAåö. `Õý&~ mV'9°ê>H:ó81Œ«1ñí–ëT—‘@W—xjÈCÓ8i~VD³q»‹Äze«†?“Ž:Vã[V‹Ùo¬Æ­M|[>ª5+­~`ÓéeÜ“X=„ƒkv& F8põ$w>]« ´Ò%í’Ö[”sQÑff›&ï®[«ç«ýÈÈLgàÕsšWû[g,6jl†_¿]¸Ïv{TLÚjÛŸ$³{j`£Æf·)¨Jãƒan£æfŸœ¾MN¿¯æf^­÷…Ž$´~hMÎ8} ì/‹j…ÈÌËæÅÌ[¬áÙS!nyçÿ\ñq@*timereg/data/cd4.txt.gz0000644000176200001440000006552014666545364014504 0ustar liggesusers‹½m®öº²öÿŒba`Aü&‡“ÄFp‘lÃ㫪›”D­“{àÍë÷YU$¥¦øQl6ÿùoÿûÿøççŸÿø/3ù_ÿñ?þãÎÿû?þŸÿöý×ùÿ·ÿéÿûßÿëÿñ_òüÿ(ý¿øïÿSÿþü_ÿüëŸðÏOø WŒ?×ïüï'ÖßX~Rÿ mþ ¿¥þ¯â??ÑQýŽJÂà×ÐþõOúç' ž¹Å$ ò»þõϬNv\}”ZˆÁ¯1ýëŸòÏO.þ–G~A˜ùk(ÿú§þóS…KÜÄKþ¯Ú??M˜üî(ðSˆÿú§ÿó3iW³ºÈ*ÅßÔÊOÎÈFo$ñ_ÿúgüó3Z_МşHóµ„k¾åKàð‘ë„…ù¯ „9‚ùÄh­È™Ði“/`,„Í·1ë¦QB2à‘ç|‘zIÐi—}?}¼¿Ë0 Sø•gâÏq¾Ñ0mª ṵ̀¬<§B3à™g°ìyN3³Ó¼c§‘‚Y©yÀ 9³‰OMnñ²FžÓoÿk?åúm?¹ÐÊøþ= ÓVh† „žÚïP“'sÂñ Eƒ³m½òh‚ü¸“0í6?â g‹àHæ„OÛÅlðß|J˜IäŸÀ„iC4Îê¤Ah"o‚§§ þÈ=gš|¦¨ù´dl¯RÐù'4ú8­»àù#ot3€¢æ³‘ÆiÓ8¯ì{fc›_òÕSbÆÃº-@Ó´iºvA³ú<üµNÓž)ü†– ØäLà´dŠ¢R¯\3»“<9Š19t¼¡öPöÒ´`šÙÅàqî¿ï!ã}¡Õ£ÍMø´zÁûŸ­Û»ft¥iZ0UÀ‡·¿ö› ªR2R³,èŧýf·dÐö‚ÆŽÌñ6a¼åi?v¶að-½à…@üÌ Ÿö›V2ø8rtþ=RžÌ—ÀéÈ;tóžàiÁŒ~<Ù££ýŒÀ†„Ñ"×_oø÷$LKÎV`„~_”½D°'eZ4'QÂG±øpˆ¡nò'£]vÊYJ@¤Q¯“?)Ó¶¹ˆ?J xlÂA+Žò´o®Nù(ýKd{ïäOÊ´sn¢¤“Pi¶Ž=LžvÎÝàì _o OÌ¿€:ñÓÐÇ€×ûÄr*ÿ–ðÔe»\N(ç»%”½;¬W¦¹‹™ûÌa`§™ Ì\‹÷óuO,¡³Î†YvÃ@»+ÓÌ%9¥”ÙG7kü$À™v.°óèVÌì™ñ­£ÛøÍƒ˜}Áü÷¤`‚SœÒ?(³GZ_1žyZ¹Tø že4k~ÓÓheÚ_Š_%`Œá×ÍÙ¢àêûžpL&Ù3EÎÛÚ4hK?ë®ÝëÍߦI[ü¬9Áìñó4h+Õ2å ^ÝÀÓ ­ œ¨ut\b4,Dš!?²ÕD·þ ²Ó–xi€–WQÄ_žFl0âh{-'ðœU`²£åÜlP}°_m/hÊ«cÃWÞ§ùz8ùFƒç<×£ƒûœ÷8‡œ§ézX‡;ë ûÊñôi¸žüÎÙ¦´òlC}𮓝78ÙW>sìÓt½ œ âa6æ>­×›ƒjÈ/zNH:–“]àòõêüÃŶOûõáà·QfÄðêÆ´à˜Ì©›±çWŽ…Íì”JvSÏV1¦õFp`{¯eè2ßð˜¶QÐðÊ3µeæ2[û˜–É¡Ï\±L ‘שcÚmdAã+W,÷üSF]§ÕFqè3WÚ,òg cÚlTA5/¼Õ•(vîÓ`c ±\>øÏoȦÉÿÏÆ³i®1Í…aRÐþ†îù4ÁXÿÙo^“@ ~á¢p9ü7ÖöaP¸ \AðxæÖä=f¸ \ÑáGîuu™p(W<¹Û2Y š‹gÀ³Ãܳ  ðQ¡ à)×@x‡ó{Ò™ø¨Ð®*x9r‰Ðb_T¸ \ÓžÕgF˜Ç„55ð¶ž+\Ð 0ߨ6$½Àu[”UZp ÁÙ÷Ö°2Þ UÈ:‚¹§mÓ8µ x„"‘¾Kâl+K…ƒ ôµ ¥¿HÙÔ¸¡†½(pÄÄݓԖ¶h[4ˆFâ|”–l #A5 @)Ç_Q3(G¡§üñ¶ Ç_¹á¦€Î´_^ÍFgBÊü^¸´Þ³ûD4HI"öOb*Ï&))@K)üUZÙÍS€ÂM™â¤ï’ؼlVBš%â%¥=7a訿_Œ}”´åFUÍÊHé’bXóí3¡=@céÏ’|„ RS€ÖRþëí…5Tˆ„6ÍI¤?ìt­1ƒ3iHO¡Z«(=SÚ 0HP¡&'ýi'­÷¤ÞHQZT¯E¸•€OuAÑFü´èQ"ô!qYlãØ p«®ŠbëÂïm—JP€4…¯Æ(íE‰¶fä_(†èS÷(ÉwNËþ~¢æGUß„©eJàþSÐÿÕøÆI¤©m u¾Âõ{ëx)èÈSúÔ(k××Ö’sâ:»ÿÁ]nþÉ ¦‡NZ ¼ý¦qàMü# ©*@«¥~•” §€ÁrU€^5(ç}–Òm+Ck›â…oæI…þO\Sžê«¸H滛Ø?‰±>¦@‘Vp/É>Ô“TöÇJ71þJ"ýYÒÚ³çsÁÖ±‰µS}Ö*nXI°9ümþ)š ð;®ÑÛ5Ú˜_;$‹f€ùd¬KÚ’wÄðÞ"ùÌy¸ª!ÊE| ±.}ëÉ¢€£Á®àíCš‹Ác]דqÛrÆÂ,B ‹ØÍ㣌%sirÝí’ñ«Œ¥ÐÛç .r¯ºËÍ»Œkûà}A¨£éó9úv@À§­.b*ÆWżº¾dÈu3AsðÑ!ÎIŸ[•_„Z#þšÊ¡ŸzÙ»Âz„dá!ÊÚžºSÒo[Ó¨@_«ÙŽ-M¤z†+Íø[¢×!”»™À0Ù÷ªs’å7¿¸nß+”»H±;e߆8‰·ý’Ðr)ðƒø yK²P¦ße)þAâ÷*¹ ÊÝLD¢³ÞWIÍô´¬ïÊÝLþHî[™¯4ûžV{ˆmN8$@Æ‹ØÈøw9äkåGÍÈäÙ¾xhz3AƒYcûê7õáÊ,ÍU÷ø6¨ð›…7ÁÑ·ï'ù /Â1Sðö†ïmhN‚ àEìZ¤î>u|oEGÈv3qø;÷µ¥Ú ŽVP²àé̽¬ýŽD8}o‹Ãßo&îí7vïéf"xþÊ}IYh’ç"”9Áßuçœ7òÊ6-fÓrä>ˆ¤—z=(r± GF]s[̹ ÄÍ_Uµ"÷`¹LÈ>Fø/ ¸58q|=OÈø~¡ÆÍD$Û=HlFZ3ÒPãf‚ox9´ß¬Eáeû-jÓÖ"”¸™8¡„×7B‰ã‘órx–PŸ-»ÒÙº:%ôáÚk:> ÉùË=K¸ûÒ …@„›‰Îg{1‡ ¯!n&è®›BÄžÁr9¡û7¬Þ.÷°¿´(p3<œyo™[pX¹E‡¿s_'HìÛè6Áã™ûµÇ)Âa]F‚äî¢6_$Ķ'JÀÓ‘»û“­ÜaY ¹¯á´Ý1Ó–l‹xÍ?]ê›û7q{\rh‚!ÁdÓ¦“ôtÖ‹ã"Ä8‘þ(©<'Oå"d9´©ôY’Ï?9–@ ‹è@Ò¡‚R_ƒ J‚õQˆH”´pNÑ.B´û·$VH˜éæšb5”˜¬®hÐòrï·qÏ]ýÞú¡åE ‚¶'Ô7õ›Õ ¢Wm»ÁùGNW¶‚…ž{sp‚“-^»f§§*ºÀñ³·ú,£C¸‹î zNM2mþ´3´Ö‚X!Ö(›Ý·a°Ø„"]„Hp,¥Ò~ž‘¹œØ?‰[ÛOÜ´OPÜ·ÂUjùdù°¦k ª[‚êÎwÓ[«Àãð d7âÿ(£XÃ@3NPÞ”·Â¡Ùöuí;¿LÓ|áúåÃã ´·’×”ó ˜‚Šö” ½%hoeЃ5œ! oüèe`«"AuKP݊л³='F‚ÚFßõÂÓtá Å«J&Ì%Hké­ï\“)›Dµ.óʾ‚(s <ù ø~¨Ë´ÐÄNQ™g²c‹<·˜V7,ý¬ƒÍ˜>äK窹 3¢·n-YÁ±˜#e*\ÙùÚăSb:ÐÆ¢t÷½¼pªÉ—ØPLî/ð:Ýu‘g©‚¤Aô · óCH<³ˆÕBy½6;‡˜Ûo`’Ö:Ö~Á‘NX–éÁu¨“ȃ¨iéP ªW‚êÕƒíH|•æÇ ³¥BñJP¼zNk…†ãÎ<n ,rԃΕ s Ú^P›ŸFBy&5 ž¹Ö? (,Œå¤ í ]Z Fv(Y J ñ™kxè0 ’U¢ú““{34ô­Á -B›JЦM\ÃÖ_àë™ L% Ë‚>êêÚKã’-A•JP¥ÍϺfÛÅ—î’ H%´}AÛó±–æÂ³»°V1k•g®q .|,(Q©$‡Ö;t¬ ÌT¨Tò'´® ÿ+•Zb ×…™:·Â£ÄøG ¾-²tA­DH‚ • H‰ÐBzn…$HR ’ÔðÍž7á¶e»C”J¥Dø(a»×sf]ŠgÞF ?ë°÷ýĬº ÚTÂ"˜ÓÙAð£È]o šT‚&5¸8K¸äH=*AáãÂÖîñ– E%hQƒí峄uxmZT‚5ÊÚã[[Íã«P©‹ZÎ@‚µ¡Gæ¢Üœô**‚‡ýHê÷*W‡ö'4­n‹±? B%ú¶¶µ)¸ÀqŸŠ|û°/(€ã» ìTÔ¦¡<%(Oú*Às­6ýg ;%èN‚Ž'´hi»_ ªS‚êpr·Q‡-½ã•AsJМ~A;aŠa‘ 6Í‹ ¬ôÙuGïºõYðg~К܈ohw>k ›q¹hÝñ ‚v•)á©.z€Õ8*‡ècxãqìVU×ôS÷V×]ÚÝ¥\”JЗx8ÄðI³•cÐdÚÒLŒ ¹ÍY’¢œt-¡,Íë“îµ/×ïZ$þ `Ø´÷'xOµ6…Ä“$Òix¹P4ª) ÒL¶V¸ÁÉÆ¬¢ÎbQÂä9X€‚x7C¼C¨EÜ¡{3|`­ ³öêÐw¶®x “ö&hþ€Ê¹šPFoÀ¼;–ÝØI žŽ{¢Å³ñ jQÂa™Ëîî”´g4ðHf"Æò‰â»;Y]!´£™ˆ?ò®wÇö i&b|?†|/Ø™CCš‰¡ýî+iCzØtdá¿jãG|•;¬:Š¡¿j#¹ü ;#HI Þ À—Ï·Ã"jŒP’x²•Ç2L0ÀºÖv8eˆ°~VÝ)åM‰¶Š*j•ƒ1:†ÃÇ º­Låñ“/Fé€y×qÔ9›Ö* œåj‚(Ž2v$îoðÞ”Å&b†j4ÁÙ÷W°Èfâðö†ï™hfÍ›ã‚Y‹Ï|¢»&M²UsVQ9pRàþß·1oD个àÁ·í¼Ý¹XÍãj‚YÊâv@1ʈI¨íãÞÀ0¨ºDf4€—¼‚`¾€Ò‰Þ µh&ë¶Ï¡a锣¬À~Õ÷0"½J—ŸõŠrQ|¨ÈÐ2Ì‹TÒ:äSyZ/C?š‰jã/‚ÅÍ‚âÅØ/°$=EküYaîw­Ö¹ä %i&"ÄçH¹&ò³ËÐ’fâ„ÏÖ9@Ddš4ÒW }o ³Ø»ç[Ê~Ò¡ÚCö8 GoF:¡Õá>²ÊXyÑUà(ƒ.¢>ÍïppÉP2%;Öú` ¢‚д‚ž–F.F9žÜlÆ%#é@Kš‰3úQ†¹ñý2†ß.lM™©èPÉó94ðÛ¦þл‚±1*‰Ñ^eCg£#V,žÌâåxò¾š…o bRNÁñí]§‚€hX+ìü]~00{W£ÍuÙë'ÆMJ¯3а…•âˆ])ÃIEðþ‚‡›ÿá01…å¾T°gîk“ ”%ø|œ¹ë;¶á ÚRæhÐ/óÓ|À“MÓŠåËÒi²_¾Ûx‡Gk :&—¡-e.ÓûåÎÈwx°éZ¡¢› ¾àïÜ…d¬1¼v†ÄB¯t92v,®À[#3VŽþ¨x¡›ó屇~Ì)­Ryüñ(Y1°²ƒû¼Ï¿é!aOèóÉͱ0ï“QÑÏ:EVÖœƒŽû¼—©˜gF½‚§J ·ó~;JÍà]°&¤à'3pwÅ\f½Âæ å}½ð<4sÓ6I†º”Ñeþ®{°U…-±3¦L6¬À‹w¸ Åà0(NTË î±3‘±Û˜Ê¯kóø7(°jI¢„“ 3¹ÅÛ‡æ4#|•!µœ«ÓKÁÍݬ8¥öÉÁzòDŸý Éi&"Y´˜wÕêörQ· Ù)ãä HõûHåQ Á⥋”|Æù.i ²×»—á¤ñQ’ÃËÅ=ÌÖÜs;Qß”t·Ÿfâðþ‚£´=ÿLìÏ!@eL%r[Ççâm*!G¹ßeˆO3Øzèøæ§Ì®žfâðñ†{P'‹ãÑ)Çpë¡oðà§”%¥æÊhvÕáïšÇí†ÃþÒS¦S/´—³î7aŽ•…kwø‘û–åØÿC‚š‰àùÈU$ʱ € 5‡¿sc÷‚C]†5(ÇyI>ŠØå»2™þm*ÔL„ÔÎÙù«_9ÞBˆâÓ•¾ÂAõ; çyžèçv #CʤDj')Ý¢Þ'ʦ©¤ðU7=H'?P¨2*q> Šk¥–8ñkŒVˆ©õXJk {DÐÃþ¦ `¾•ÄwËB"P×jÝ>pQ: ñU¼-ª=”h†•!D <àì¾uC QtL8½söÉ…Û3„¨ !Jàú{Dºª¥„¨ ! `óÝànî,6DC‰ÊP¢îïœýà3;#hQZÀå]ç±¢e(gX®7÷÷z¸ ½:F™ì€år:ÿ»féu¶—ˆÄžÆ„,U/ßC4MúÊÛ×·„ˆ±V¦¦2¤)±Ú+¬&OEÒT†4†-M_ û@ ÁÀh¦2¤)1êÉHumcS—€<•!O¿ÊH[ q†@•!P‰ñUF\ûüüJ ReˆT`X»{2¸bmе‚Õ!S‰ÑOï:ÑN UeHU`ä¯2BZ½'¼2”ªŒ¶-ÆGm÷Ÿ4 ÃŒÂìaE÷Ȧž¥þÛÜý ò_ˆ2Ê0£—úA˜«[ìÜ BB³ªaÅôxRúZÛfòABØQ(W5 ·È³bɼût½\~Uðvkpg );~hz"D…Š%R;H¡ýsR !ö(Ô¬ºúĉÕ.ç1íyÎ' ­EK”vR<¦ñJ¡j¨Z ØÆß“ÂIòm#¹@Ý*P·D9K c 1êU#)4®š4‰8J¹––w¹µ« ±ŠðQFý{{ù…áfƒ(飌ÀEµo3WF´…îU°â«v8ï,gI ²KòUðU€’OÂe‡üCàÂò˜€üû¦3>lŠÃÇ +¶J`ýañ`/_ùïÈ*Xph^%4'œ%ÔV…x’W-î~i{k>gºG͵^»@ø*hìu9¨|ÑLQdä\È_òW-ÅýŽÞ”¼4EQ`rÌEù,eûaFQ"c GQâg)\ªçÆ|±@££±(í‹bp‹~X ‚ˆ`µáCdlåblæjc.æŠÌtذ~ ©ˆõ“˜,OÓb ä°9¬]Ñg^Ý1å™ý}ˆ±É ô°= ”5)¼Q"÷t~µ‰/§ÒI¬@©$©{ëÓgIh PÅ@:Ë ü²~é±Fq¯@+Å@8Ÿ%Re'`´Nð®h î.iOQ£a}Hb€çìÛ˜1¦“¿òN~çš $±‚Å¥àã+w×~xwD±‚e'é]wÿvUìÌ`Ÿ—ϰ“Cþ]ç`ÿ4Lœš£Û } 0t@+© mªË ýô%*ÐÄJŽ~çýt'*Äà#Lt|ç}“ñ…†Ispt¡óÏ=jQ&Vr:½ßIÊka ¿@+ †r) ð«IV6$ƒ…gCJÉyäkN·0$Ô08(§|ÂÉ8зw,í„x,ŽU¬@)$ßó“·J.V ‹µ´¶Øžâ>àÀ¨ßPÄ 1Û ŸÇ Ô0º*·tù臚É1"3ø;”0A_¹.{ BkéòÑÞkzs#æƒÖ,äà zíÝ´~†|‡òÕÒ何0.•0Œ2Ò;:Ê––®îPq‹·6Ex/½W ä­§3WX WóS"óÝmÇÛµ)µ6i|0dŒ÷Ҝؾ‰u›†‘çaÅÒE ”vû.Ÿö,ÃIõ›ä1Ÿlà…ÎUê%Rüë¹|9…jWÚÕÚdžÇ÷¿öÆ,ö. t®KàþßÎE¡Cé*PºGÞ·-e¾^(]J—àïÜïq^™;,¥ ðè°7ªwHR¯ ”®¥KðãÍø~¢ (]JWëÙG€ÀXé>à1¡r¨\‚ö'´mÍý4®«õüÞùúûN2=d®™Kàösòdþ6¬l «õì}ÿç=ëgΰ$ô-€Ÿ•0iJr’VA_ÜÓåK£Ë㹞ºÜÄiô¬=K„úI0¿éÀÂkšá„ÛDÔÀ0"ä,‚¿r—À^­ö0"D­Î.î3÷uHH[Ò–gþc ÂÚP·€Ï_Ùó,v‰ Ä­q‹X-€žèhC²†9!ètÎ =ßîp K×."W=Eé%1@“ïT®d!vˆ]=WoOÒX21@SäU y‰òQNý{·š+Cø%~•rýîî iÉØyGwÒ8H±ýÖ­ 2löU¿8W÷}~’x™Ä¯V®È×wÀî¾D*'‰'«|§;óÍAý*P¿@²Cr¯êi’˃lü: È_¢´ó5°{ãa9.пʰvP>ž'¥µy 6(h#;åÃ>aMg¿ý«@ÿêÅý`©üh/Í…ayÈ^öðîè‹Cï*л]Q¼6tŸ5*º(â úÊuù6Ê‹V† ñ™«·åZ/^³r9´Ý¡;„>:û Q«BÔTRÓz~ƒaJ‰ûA eU¬€­7(}íÔ+€ V `Ë´oOß«Lkç!û,¦BαDìŸÄ|;ßE.]ˆRø£´Ü֛Ϭ"._Œ%Ò%í»* úVYBHñ¯çÚQO2_1.cÁÂaìS™•æPyMåÅ,°Æ>‡¹ ñyÍb…|U¡ìGæŸùúö0/Ó nOðž[+gX‚ÕXç‰nà$*Z…TU!U üÊ9¬æ©ªBªªªF¾~Ò;缕3\顪B¨¹¹ä°Î~Î^EMÿJýa[Vcü ¦ÇW[!ZUˆV#·ŸðWi·@M, ¶ ÝI”ô ÔT¡[Q¤yÝyòUÒÚÇÆ›ƒrUãå¤ñé~qZ…vUc)ý]Òº@$^¥Tÿz{¾Ë$ZAL"Ù.Ó׋ðÝ&¾=(X5f'ýñLÉv†½´Šh­¢üQRpUÃKB‹@ñ~F‚G½ }̆¥ðM`´_ÀB“ÀP6¬#?Y¶J¶•^…zU¡^²â(Œš&¤« éj”FéÉ»?!ÚU…v5Ø•¡ñä=,Þñð7C ƒùßUkÉ-÷¹,¼tþ«BЪ´þ¦‡E9¥ÜÚ| 8ƒÍÒyÛšÆ:j2;M“6±ÌøíûÆ—‘«B䡽 Üt2] lPÐ( s¶¦rÏ2üîßǨº*„®Ñê%Ö»Û!Uù µ«Òk·ÕÝýß*¶ UUš/ÞO†¯vñ$¼˜ ­!"ÚšÂÝ i÷Ó· Ù«¢/¡¾ î¤X¹OV¡{Uè^<Ã"w½;¼þú'šÕt }U% ˜;Øý-q”s-¿ªJ°7#üúKƕѾ~ÕÕ‘foÂy¿ZvxÃÙA®u$&ºZXÅÝ™Wξw§°EÙ>ø ÀÚ˜y^y¹Ý)ãW¡(t- 'ÆI‰çsðóÞ®F|Øwóˆ2^”Ðãî ƒJÅq䟔º¦ì‹ •¬BE¥¼+V}EOT jÙLD9ÞWå Ÿš4ýk+³ŠÛ2?KàÞ«TéŠÙ}…n6×âù®,8*Ý•`¨gµd'ÔÄ+²Ed…x¯,¾Ž'a:¯“ë+`xäVÚL\_àÈB§:*”³Šxï:Þy÷µÄ94³™8<¿áÃUH©PËfâðqæ~¿Î¡ò†Äz .×ÁüúY®ƒÈw$Ö xzƒÃEAÁ°Á+l:ª»¿X,˜âW:*ÐMåýˆ59´?¡[Öᕎ¼±f%LlðŠ­P5æýˆµß•ð æÉ®GäýˆÕÁ¯jøòWgà+ïGäY™Qm“uƒ£G.êsx?bíç7Ô>š֫À¯‡‹Ãné#ZØL-T\nд» »µàà磭Ư°ÿZØLp2cê~×ÉÐ&ýºÓv°W"Váy&J?(‰Â­-'À –D˜rÞ æq}ž¤9?Qy©É*†>«fÙ Àª}ÂòQyQ¨ðO‘^_µñîË&J: œæýòÒ·,ì‹«Iø(#pºbÓWvª̰j”ó…ú+g©d|\³ ›Ã;ÐOå|cAÇtr+hRål&"­@7R·˜ˆÎ ÚLp|&ê\Pt¿ÒÈíÇ–µÐÎfb@}whôP9ÌïYàô†ë=t¡(ÌŒH‚„r ãÆ „?CòªPÉf"p>*‘•C¶CO ÙL¿Mª"Ê䵩L(/6íè:Ü9ì]À¤¸=Œ·`ù4ÁÁ‹Ú\¡ƒÍDàø„^Þ‚yM*Ì7‚ß¹V‹‚-¢ Ík&‚>+é@£õtPºfbÀ³¦I'¹ÐÝBᚠέèqË?ÿæM¿|Ü,BM…Ò5ò^$wl6–h—ÂæÕ‰Ä}),L‰¾/ ïHÞ¬Ûµ50>Ô¯Š‹1ÁŸålïzŽ Á*ü ÃX ù>”r‹IB(/©m¨·ÛÌk¯¨½ï|=®š‚„5aˆ‘šwxê[Î7M—`\O‹x§Žïj¬e®z…ÖÐ?üªóÞ€T5p5í•N¯œÃ>*Æ[o!|µ«8øÈyŰèãrÚ« œß9Ÿ{‹¡k&~æ|‹ ¨AàâvK§]àgäÐ…k&Ž}f¼¯7E¶Ð·f‚ãj~éB\Εå›órA7ÙoNée…ÞëdƒSbÿ”ðU O5¹hËŠÁ ¸ N”Rn²!¥ùÝ ûí¤,ÉçN)·ÕÛÔ¯C”ñMY[<¼Õ |ÍD¤ôñ4)ü–µžpŒš“ÚA½X«1i·«Aùj8XRþx¿2Ù Àòð{'á·œ¥à Ÿy7ÚÞLܾ÷ÊÜ.”Ä÷ ¬a2·Æ žo'jñ‘Cÿ¢{FLr4>Õ¯þ…üÞ ~5·àžGÝï¸7ˆ] w¯Ç½Wy‡×uuO¼y< þ[ŠXÙ kµdö,gÎöÄ2'ZCºŒ˜ åD‰•ì¸îX¿ Ûâ½Åjø¤r+Уê¯y«¡IŠX¿‰7Çn6ˆ\3ͶšOZ]ÛÍ‘•„Íá*ÒeõµçÌ7±«qN˜u ä“T¶g4ªÉk&Nú£¤º7°ð* {5NU× 8is!µhÕ]ÿÍ€7e WŠïø´Ã–Ãߣe^@Ÿþξܶþøh лâpøQ›}²õ6h] ZW\ëæ|ÝL8Ì+Ú”ãxÖuk0á074.ÁÜ}ÚÑíQahè[ÿ.å8•6gšy¤^´0hº½k¢ŸÍô•Ùι5®º[Dý"l¹+Ew†:‰KÈh3`sˆ^)­5s¶C‘Õ£­iê}VÝ |5_Üuøéóˆý „¯á+™\|n$Àøx#)­CsB¸]VÅç€ù!‰ðYÂ:8‡æ¬AãîåW » ¨4H`"œ%´ÕÍ6 ŒßGûÆ^¼Sh` ˜àgöaßÀˆúCkÁ€/Ù·¿{ð JX«Ññgþyù°:01Ô°´ÜQr³ø •W9ùH\é\Ü ˆ5(bi9£< ·%SÅh U¬AKÙ*? ~¼òYL e,-7”'Áâ⬠Ա†'KË åEØ—}q\ƒB†«up–nÑ`c(e JYÊÕ¶_×à’Zô²½L„ò:FÄe4³Í,eß»x@¢Xh¦%ùõ¢:jÞ!ÂuÌ·Di”è~ê;D¸”ø×Ó,/"\‡'Êg)Û“LCK€'äAn@ÅN«àgt6òâ(¸¼ÁéÇ#ß%VmÒàö7x±ïø7ÚÃüÝè}ä^¢yã« ¬ ¹ín®³ó?„OÁ²ëJ\£¼Õê6ß9Ÿi!¯£!û`v(o Å} h‘yÇ" iAwëÐݪÏT9’îža¤Ö' ‰­Cb¸=Á·H`zZ;×þÌùW'æá{Ò!Ÿu,ÔNpôÃòÉr†‰¡– <ž`¿çO>djYG;¬y–Ü` jø«›:´²­¬f¿âïVÌwùöu(eJY¥ÚßuöžC`X:™Àã ^ш¾:U‡NBü.aéá‚=¡T‰ðñ ·[WXl ­ „ôUÂ>ÚÃy«ÅJ„gH['äCÃÂP­F ¾4—ø:õqÉνÄ:T«ÕJàþï›Å!ˆvèVºàJýÞ— ÊU‡r%x}ïŸ Ÿ4«Í ðxæ÷Æ(ëëB­ü{Øñ»°;Ô¡Tu(U€§#÷Öfh –…F5j–†ÃZ³í×ùŒKËlzÿì ¥J´úA+õgÅ‹Á UuhU „Ï’Šœ°¹JÇ·­ªá”¯Rò‘†õð€V5.ZÚÏõä豯NJ~å+ûÄbpbÿ&Þ&1¤RÉB$WP*ûèÉj\I¤ï FW­0oЬƕÀ!胲.‘àÓPŠSÆ'%Ü.?) UÐÚ:^—|“ôÒËOjàß 4PšSÚAYŸ†øø”.Jø (˜fÇüÀdª™ d˜Ë˜Ñ3ÊeTï˜J½r@¢š‰ÃûÎþýw¹9£Í@Ÿš‰ðá™=c¤­ƒ“å—ùÃêˆ{,|»ãÙUùš®ñA˜š‰àñ™½Î©§mÊÆF¡•¬„íÔÒwx@™š –¹Ä>Ô6§Ÿxªò$ñ«ô ˆ0ö\Á±ýI¼m[ (U3Að²k»ÎYúÀ­µÉ×ãþ ˆ0:¾ð½¤Ëæ½ fo«r¶–“cÆÖOÂÒ†tÐn@¢š‰ÎÂm± ³@¦ÂJ$įnçZñMAª¸aU„žg[ä*ø>J¸†C3‡b5 ì…uÎò‰÷yqýa}`z8 – _õñ«iÑT [ Üø%ügýý¸½êkãìAX+?¶]F¬aå¶¶8WοՎOÿ_°Øo ÁÖ¸µ ´à±Qn4lmšý‚Ö€ßHr2z•~•[T$ØÂÖÀ‰‘ÚéÇCªå ¬Ž ÷ ¬Ð*wJ\V̬¬ŽnV„ó%”^þ3×ÀV"ù«„¼9…%Àðz*Âùiïzbè¹. Ž—ßï/Û&Š}_Qˆ™Ø€Ä5°Ý)ðxƒ÷ò„ƃÄ5Ám|‡[  ~¸8Í<ž±ûLð˜·p*\У"ˆ£…ªqk`A¯¥z¤í,¸Õò‚÷_@„}stâø“È~pp0 w ܦ-nÙŸ$ó§# vÆá¶x­“/Ò]ú¾TØx­½“ƒtÛ= öÎÕIý›´~Øn!vñu¼úÍëëƒd¾_H°~†õCöñhzo­JÓõMkàvàn^ÕÞâ@ÔP´®šˆa]ƒkЗ@Áj­™÷}01¯)z|Çг7_,ªÀ­q}ôœ _ÍDÐüÌõúñà(Ô”+­6h¿C½ÖiñÉj@߉ –ŸïU^N ä7 WÍÄ¡÷\C·ø›ÝÞ+¬Uh­u!ìЊxö1뮵Àò_& BÕLKò2wL%ÍU› ú1ó„è€X…5Šë¼o­æ\5‚ôël ¯äN>®èïÑj&"ø¥ÂÍ  é Ë ¢/OîµÛ覇€5'Ôƒ=<§Íû!ca:NBú¨RlK"ã”bÖÀ×—ö-wK¯Mîs*qw@Κ‰ƒË \Ü·±P°µf"¸}÷¼«üÐWâ“€¸5‡¿sÏv}篎S\3<ž5·›ÎmOy@⚉à:r‡'A‹g¹f‚°xx"“ŒªBÞ›S‰‚ãH\3qèx@ÙtjŒ1$®Áƒ'õvÜÑó½¶ÒF0¬‰#ð¿rKic7 ‰ Ë‚ã+g‚µ½È–™k&~æm’K+€aÇ9 8½s¾~ÖUø>!t Üâ"ð+ç¼¶ùÉA蚉Àù•3ã;Øö"L‘k&~æâÞ^D!pÍDàòÊ9Ä:ïâÖLÉOv¥bnþ·Ã¨en† [3ؼ“n`.g´C ‡ 犥Ô0'…퀩ξ!iÍÄÁùÎî¥+%v@К‰ÃÇ ʳ…@Κ‰àñ¨ ¿:êѽAК‰Ãû w¼RÈ5‚ÖLOGî±mw^Ô‚ÖL~ä¾½y9^Bи1ð|æ¾§¯‚â#;üÈÝ'¯Ý*›Ž"x9sïË——ÓWZGÉÚ Ûn}I°F Æuá«„]GsB? ·@‘h¾²®!h+dô“°bÉgn@Æš‰Î–ë‚|pó??HEÑU9ÇSÈ=WûûH ò·¶½«»Ì\§Q±1'0Þ_ðÛCãµNh"!‰Žü—G²fqšIÈNx—àgQÌ#yB E„x>_Õ¬S¢ZI¨NhoÂm†îoB °õè&zdßÓ.bgô/R:)ÁýÊlšRò€¯›®¾\;ƒÁ/ל¤Aêpêø¤ú{ô–ÅF0XP¯z ®ÈFFÄ‚„S‘æÇÀ€JÃC¾Âfª)á׺Ýá·ìõnzŸ` –(ã ¬@Íìh~¨X „¯RlµhQ£&˜ sMQúIq/môM0›ä¬¾®®†/¬^ÙüÆÓÅSÿþ¶íRÙ hõš|Î*g1˜·v]z˜6 HZ¢µ7-ýÞ¶gxG„³Q`®Òm³ôIŠîÚHO^QØ hu›/¼)6ò»‘ÂÙ iuNŽRÒÚ¡SÈ‚ f[€¨ÕkrW²;¥ngP>~dK€¨ÕmJpüZ:u3‘í¢Vë¢Ö¢=òË:(FJR§â¿‘Êö}«n#èA¥_íû+fÒ¤°U@éñ³L›ÒMAœ¶^ ÅO’Ga³N.²5@ò"ÅïKy’øÒµáÂÃpÞ$­‹–>H¡úJ€|’Ø" {‘¤9õ›†ø@fHâ Wb«€ðÅÍ”/’oš*:гU@ö"廤âWùîÛd/P> ÙŽ2í"Y»(•aûåü$Û„/ˆé+rmU5úÉî3¿ú(ÛÄ/‘ÚÉ»ÔfãDbC€þ5Bô­§'gþ\7L4[>qêǽݫ `‰ÍZØ~y웓~< u’mØ ˆ‰óñ<é,\™M³¡ü Ù7g,Q2ñ»ÍlÈÄéŸÏ³Ü.ØB3´±aSøó]ÇuÄFϓ٠à¼81­å@‡ ÊØh+E0'¿P¶l§¦–Ù ‰ ÞÞðkÙßžö‡6š‡Ê¿B[ÆOœeZ˜ïâ¾48pðÉ´£$œÆ¬Ãáý_Û 5®F{¶K„päï!–‘MÚ‚Ú‹p   .©Ñª-ŠâÍ7˜Í·Ñ°-9á]B¸yìèhÛ–EHG á¶[)ÍKg Žvˆõ’nU„|”Ð×Ѿ@«5Ú¸5dz« ÑÊͬ¬ãXw|{(KI37˜yØz‡óuŸ‚?i.¿+¦?]DÃÕiê~9©Ÿ$ù/xD<Ía; Þƒh᫬ë¾É™¬4š½G§µƒ–vXRÊÈ4~§ñ{-~”f·ÌéøG²‰vgèY4ÛR~–Ö~u3n^÷ÌMB/N«giÈ]9ÄÆÐ«H嫬ºCä©zl½9å,'¥%RßYg“èhc-ßǾ5eM0õáw¶ˆ>ÞßðÛ‡OÂ`k—áÌÿdœl#8¡½ ûÃÏ|¹ƒ-`DL;¾Šßf‘mÜ´ýHNø(A3…Æà˜J«,B^žY·‡Ö=7ÁK ½GqB}WéZÖ¶‡¦­G¡œïˆv6ejÐÊ£øÈÓ2þlï‡88ß·d§Û¿«g¶‚´ñNèÂû¶ä¨ÅÍTøð,๠žƒˆŽ~äθÙ±ï1q‘è(t|W~ë]‘èDtÚO—â1RÇíHÆ <žÞ?àÞK©6…„"B8ò_AK’* Õ ãMˆ?~Ê*é]6šòÚxÌ;ÙöØ&´“ÐP_„[@®ÁE7¸4‘ð~‚Ð|ÎêPk›©9AyÀ‡/¾i[*mó‚çwUü·À·Om¦>ón·kÜ&¶ fÛr¼lüU?i•¡uCv‘µ®°0äÆ„Òº˜BÇêw0ähñ_V¤?µ4Ši3ul»c‹;A6khÔÐf*txæ\âÚÝgw(žÍÔѼóöT.ª í9 At|ÕzOz8 ”Ìà›fègÞ{mhÚsÚèôÊ»l·žJ4 ££Ûëýù\‡C Nè|äí3½AJcõ8Ñ~"QÒ 3ø¥þ; bP„ Ͼë¿àQN7³{BiÏ{.ʵ‰Ré<»#ÆVÆqpš56'õƒ¤é‘õ—…1c'ö]´}­Ó­¬ð{;T¬ R 6S§³4MYÔŸ Ð(‡ÍT´øõdœ8ÚæYÖ”%P›©h郖ʯ¶[®ž²ØL Í3#à¶P £ìx/l¿È撈ჶ®ÛÍz.¶ˆÙÖ¼^~Ql™Û¥'?Šã·¥L[Æ%I[¸Ýhe/Eô­S›©S>Kòa‹Ct 86SQâG)· h¬¶ ”È˯õI¹íYª+§46SQÒG)¯}ËÙ²5äË)g)aüÜ÷.'˜-a~4¤ä¯RÒÚ¿T×N]l¦Nig)m9àQg”Åp²šÍv_¥ó¥ôžªØLæ¼ù†FµœŠ‡og°…Q›©ÃÛ¾±‹ž‚vŸ" ëÀü"ä¾T±Â^‡ª\Aÿ ¬ÛÊ¡M¦šG™£ db~ß”Èfú;öÅ.1åˆî ꓞŽmaö²µð$[–Ï£¶úòò9ÎÖWS-›©àáæµŒÉÀA¥l¦vÊ ç]læ|2´þÖo°/¹ÇMí^’ååt‡WÛJÐWB± —ížÜö^s¿zÝ”V/Å ýý^÷íWµ§ÕK!Ÿ%x̤dZJf¡4Êïñ2•KñÕA nJwÂñ:ƒML|ú@é,@:Sà Nøµu›ï[Ût?P9 PÎÚrôŒ~¡WZ¾¬Ñ&œ”Τ³æg7×Al»û G4P; ÐÎZZþŒ7øÍ^]å³ù¬%?Õò ì}®>´M„ú&xä‰j]E´­¥åãx'l?Gu5ÔÑt´f÷>¾Ù§ÌÞRJÃWHB9:HE¤%õRia¨i­®£ŽëhøåÇk’}TÓÔ4Áû~‹sÄü©¦¨i ÈÛìNˆ~‡@±ÞjZ€š&Âx—öÖª´3Ô4âñ+âC¢ËÇ„ÒÎPÓ@(~OÊ"TóPËffŠib‚S™?ò:$f/LU'rš(ý Ü§25µA ”ðQJ(?Ïõ)5µM ”‚ô‡¨½–@I-@R#ü·|•`àAM ~é$¤®ÀFÉò§š ¦þ•÷5?êh:£~}Âmó“pú™<>ðý‡‚Jî0;~ÄÅýÒ@õ,@=©$cøU(…šÚêYÝú‚'-ˆ&¯!c˜ÚêYÝ>ðͺšÓX4=䳞WØŽ %!›ÉëÓäÍúŽ3æÐH«3 f‚Y_a¸°Í­‰`£¿ïÞ“e+¤h†E¨QúAñkîÖÔŽ²Y€lÖÛr–r Ê^„ÂY€p&ÊYÊý~DŸÒY€t6ªŸÕÍÁ§Ý]nÌë6û…D6Hh"öbŽ»×b«¡Œ £å>z\.Ê6àSJ ÒF½m>«¸o„ÑòrÂ¥“?KJ;f½ ¶Èj£¯³[—FY÷B.×Úóx¦“ÂMÄöÑÆE­(²ˆl£»·Ø›”oÊH‘J[„Ò6º‡K9Hûxß`¤à!¸î^coRºé…¤HRtÒ%­m÷NR")‰”¾Ÿ©nÕ@%e’²“ú÷‹X‚*I…¤"RþËV+ò^D%©:éó™êZ—Ø+o$Y«(ßÏ´#ö[õ:Iw)x§:{38èÔßÜG7ÿ…¼AÞp^?yeq\GJt3'|•u[Ñ–Cn¦Îù(罤”ëfŠVpõa~ ©òì¶ؼÕl‚ÙBrJ?(i÷®Ü”‹ípü‚”`‹ƒâ÷é¶0GY£|–²âžˆÂ–0§m¤Ä¯Râ{…í`.[2Nʵ ØÞ¨ãÍT”5t?KYô’ÙÂ%û¹’ûKnv&Y)Tôfê”óñ£àÙ糑²ÞLq_…ÖŠ Oš_ø÷‡f×Ddû…,6€Å:9AËK’‰§õç,ŽÓl©à§#KñIpã5%HËÏå€â«iÄ»Áo¡zj|'ŠEèoÂöÐ÷Oo¦"Ø¡‹7Á®˜gû¥¾7S'Œ7aßjZ|.ÈXN²ãà>%Ù:?jz3uÂQÂ>rÀ¥`¤š‡hø$Ø!©;¡›Ó@Ðr6RÇ›©ÞVX[Q¦ùF*x3ÁÕ.8·(X¿v‹;ßT§a¤v7SQ,\ƃb‡ <\ÆÓÚ);壔±Ô®ÈoƒÊ]LE”ôQJØjWÐÛ¢Å-~»Ä”ëäÈ@F;ª~!vOÍiý“æ½0ÛÕ»™Š¾JzÉŠ‘êÝLÒʺ¥iŠ©ÞÍ–(0ëìµå:ˆ[ìp@Š­:蟤Ðþ9ˆ}x¸“’ýå çüv)àÍÔYãƒu¹7;<Îð#U¼ˆè]à™OÕ“Ê­Ï£Ö)äÍT,m—¾¬Z·Wµ.ŠTóp?Á¿á í°þÖÙ^©×>B¬ºxRÙ62ÚF»Ý¸|j³Z†¾Tj{3uxÁoþN2/å¼™ŠŽüãÞøN*í!'¼Kˆ7¯'¾6jx8HBD‘ÿ&œVžß°ÁûÎEÿÖ´9©éÍT„ðÌ_îF~™ˆ•@+O‹á^B ¿ûè9Ejz3Á1'´5sÐ]OH+×!¸Ý4¶òô·ÙÛ¡ž7Só£öº6C5¥š7S‡÷|·ÿªG¥–7SÁË£æì#;TAo¦~¼—‹À²fëñfŠ Ÿ–Ò<ÜIÝ~Éjùð°hðö‚ç½HN"Ъ­ŠŽüosB ïfê„~–ðœR¾›©ënÂMpËf/vmC„ä÷öîG–ÞÀcÜ|ûðfú'ÁËc['—‘ê(%5;#©æ!Üæ_ìºØµ¥T棔| kW÷fú;ï²ûè­§’RH&Gª|3ýOÔ<ôžë•G/˦²Ù6zþ“]vÍSsˆÎ-Uï/¨ùÍìÛ~¼$wÖkt¦U(ö!´ŽÁû wŸªU%?3o0þê³Í â1§¹ÅMÒ,€âßLE Ÿ4S…±Íôá¬v²býk²§¯œàLÅZ}샥`J ”uÜ-Rœ©xé‹e slê«(ÎÔ_%%®ëå OQœ©8ù£”ò»b^V36‰‘£@™GÝì‚àbucCEœâCÓ£n77HÕ­aTÜy¶æjeiI+„˜wëë7’Ù2FÙF’“¼}Q9kæD€BàLEý“h1™˜ilcMËñ“Èsƒ’4oN”g*bú¦9™i´€;Þtì’žªÒÓñn‹ÇÃú'I‘¤(’­V^$ËìW±°&:‘“ı`®/NßíWÏ”ÉɸꬻÃG°hÙyÐÑÞi†K›àBJqJ=)~X³êóO”g*ŠöÚ_Eíã‘=L#¥áž°ÛÝÚH€#‹r‰`‚˜ûê¾vp=x9íí­Î Ñ&|4œT¿I¿ŠÈ ®Dõ/Aý§p,þ oŠ%ª ê8á³r;ö7YÕ¿õOœrRXckäK¦ü— ÿ?Ë)k‰ÂN/QÿKÐÿÄi''ø*Å›ÀœôU·àWîtùŽ$*€ 8ù«n·•‡ªÆP”¯W°æ^*„­ ôÃÐômþwõ«DÜ]PÐÆd'¶ˆyÛeÃ%ÚRí6Û¶ýü²~•¢`‚(jø$FÝ£#øÌVQ”?J‹ ͘8$±Y@)þIùå¨Êa«€,HÊ_åø-.Fb³€8Rú“¢a­’ÂVyïUߤh7E‰Í!Hß” S@ÙZ9E‘°\×Þë÷ð ôìý]çË+»üD¡0A(,× .ð Å~ÛóW¿M±×ó‘|‹ýM²£ÁX%Ê… r¡(g9a_{f¶†…K»óy¾øŒ2[¢d˜ –hÛ· !Nwº5ѪØ óÃ|³îÖÀŠ´>ÄBÂA(yfH¬I” ¤Âb—m= ñ²½?ÛåI „£5~–’¿è¿Ç‡DÊ„ 2aáó%oùÂÓèЋÝ40 Àð/ÜÇL”$B1úG¢T‘yC¢F˜ ^%>J‘øCÝ—5£H˜ ŠS?ÊIû€ ëF‰0å(Îdzäb§4$RLËòHIa._)*´þ„ÑâPkq7R¸˜jæ0;ÙŒÉ~¿ëð‘ýF2­iPäñIŽö±ò ˆ( âê;õ}”ê·Àf F‰Ò`‚4XËÍ?ô]Þ¾T›ÂZüÒGiy}lê¢(&È„-,Ý’írx bsšNBAû z×+Ù•SL|o¾š QL~ä×<€5‰¢`‚(ØÂÒ)wÎkÀ`‚ (ð=çàþé+gZb` KŸÜïbmðÅQL¾çóÞ`ÖÛ M!òrt÷Ñx{j¤˜ üÊym¾É(´_1û•Gï¡z˜3¥¿T/÷g5\‡TÏMÙ/AökÙÕ˜ì~2©ÝögÙQPôKýïoøÍ™Š5§è— úµ¼Â•ÜÁwfMzMýD?Ò;}+ɦW”ü ,Ÿ'ÜFj¶@ ~ ‚_³èŸOx²S¹®4' ~ ‚¯Öîÿ=wb6o†DÁ/Að¡¯×WÙ®¿&)”ü$?Þ%Ž›µHÊ~ ²_[÷¤Î¡Ö‚P÷}æDà e¿Ô‚Ãû¾coëû§ð-‰„àCù&¸ï[²VOñ/µä„£åBùŒ/•`jY„x”°‚0Ù–j¢ˆøäFx—Æß‘ªa†`jU„t¼£ž{~‰`jÍ ïöÕQÐÌfö ÞÉ—‚évf,){¹ ‡÷7üvw$ó§þ—ú%B8ò/a͈’_êÁ ã]BüÙgœp”0VÐj‰R]‚T‡«UlýÖš´&Ï>ÇIËy,Q­KPë@ ŸÄ}¥Æ@¹.A®#E³Û“”Í)_Ëêu zݸÜ%y’ò"1 WV´ç‘(Ø%v#zD!î[ÙW_I•.A¥°màv·ÚÓÚçjé(;JKCŠœ•ç Ík¦n‚Ò´ƒî\×½ÎC®•‰r[‚Ü6ö¤º›k¼>ñ2¶ møŽ?|ó¦-;”»®lšà@Je…Ò¹S’ Äv¼"SZËÖD©'ÅÂèñ7)‰”$Jü(%{Ó¯2…µ aM”RÒÍ*¥RDIßÏâ—eXÅ*)Õ)¥ŒŸ¸V”FJ%•Òø~åá>¼¾ó[‚ñ–‚É’D ΞÞHã$…käYOKCÎ ¿ ºE ã÷Gul¦¸nÙŽ{mŒW̓åNQ Ï ú[^àìR¸Zõ°™ ¾.]ð8̇¦ÙèJAl¦Ô?Ìÿ®J #¥Ð¢E/ÊTÈfúÛâÛ]cÌ}\±¶Ü­R"›éŸì]v.³”+ÅŒ(ö¨l suõ÷£:»Ï±sþ< Rlþž)—Íô?Qöœ¥5„hëgöU6ÛÉ|¿Øi³'?†6[/X%›-f6–ŠŸ:Ëî·„skõ×·å*‹£„6S'ô7¡ÿÞøW õ™RÚLER˜;)÷ß½èC$±ý”è¤wI¹ý†½úîÝ(­ÍT$»ùêNº®1§—ñ‚ߣ½ ¶ƒ6þ3…§8§¨-äS÷zûÔñfŠå=kª~¼2ÜüÅù"©âÍÔáýO{ذüÙz!ùÇíê-U¼™:á]uû˜ÙF©âÍTó3ºÂöuÔl’*\Œð.!(—è^™JÞLEHG ýÇ£ej¥E)o¦Â¿ÑÉöÙõ´´}ï=²ÎÖД/Mݧ©áI$[•á'†¹ëÐ~—ÏqÐLo¦Nª)S0ÿ›ÔŒFC šŸMW{Ë™yFsè´³´ÄÎÐdŸ,³Lo¦¢Å¯ÒÍǤŸ¤ …¼™:­|ЖǶ©õfê¤~’¤PX¢ ² Œ*Rúxõ™ÿ¯ß‘¥Á˜RßLv–Å+îöµpöòÙ*F-•–·#.¹›¶aíããeÈ‘‡¯ »P„?„_ï/ÙˆM¡ 8ÓIÈ·Ó%&7÷±²í8­ …À™:©nwsFr9Iœ·Sˆ87¯•“ÉÉâ|Wh©…:àL /!ìÅð0-V«JFÔÃ'#]K:d÷T¨ÎÔ9壟-ÚyÉB!p¦âäÏrâ_Æ D¡8Sq>JIr(š4Ê€3ø²ŽwÜ|‹órrg•(ÎTðø ÿUaN eÀ™NBÍ?ëb*ê-.]p#¦Pœ©cÇ‹àáÛs&OKXz ðý>ÒØwDgšÒßLopò§g+¢ä7ÓŸž/»6ˆ.¦¹i %˜Æ#LÏa £kÙV$¿úy«_åOÛN´QúI¹Å˜Î¤Ð´aˆ>JYÓ0ód(ûfê”öU±ÇúBÁŽE¤ÄR¢yÁ¢VŒ²üdŒr–ý¸£]ÅR(ýÍtR’^ïÝž÷ÜY@'•@KÇ,xxƒ·¦çŸy+ “÷öfêðñ7a†1…ZÞLE°“¶7Bð ½’hëØÐ_„½jz:áÓñcM4ø.)ãÍÔáïìCXÎÂÓÂ)Ÿ_çN ó -Tôf*ByÃ/N LË&³l9ގ·&)V…’ÞL'ºû1€ÙbÌUÙâ9qØæ'LQ¯ V´àí>ã·» ¥½™Š\¬xLbÆ…¼'BvD-#иö@ÈG áæOÃÑ–º^®‡ÁЦ½¹¢°+Çtø¸PÑ+Pô¶ý~'ƒrªB0 ‹™h‰˜!®Ð¹í¶ÇŠPÓ+ÐôJô€5øõÜÊ+Ôô 4=ú‹@oK­Ò4€QÆ+ñJìîx#¬+,|P¡rW Ü•Øýô½JvêÎU‹B±®@¬á]¥Û]e”² õ¹}®ØMcÇCßo+›PÚ’œí]ÂŽ©aMûB…¡%ĸ=k8zP…+PáD8ž¡lå…]4¸®dwÊs9[-¤Û’Ÿ-”Ú[öV²»ãÞá·\³©»ène]Œw'¬ Î,œ}¡æV ¹‰ð.á~¸—Íšz[ÞVÖ}wÂ>Qoïˆv†Ö&By–Û|±>—:B ’ 9Ú«µ$‹·X¨±hl"Ô7!¬]+v†ÂVòe³³Çk½Ö¾®Æ%*l ›G ·(é, [¦¨‡véœJ˵OŠieèkŠyx‡Æ@’í‡Ê._T/sç›Ý žï…ªZª¦†ñ™s1ÝßçÔÔ 45ÁÛ¾cðª!PQ+PÔÚåGIòZøNïé[“'ü@­ ]M´rÒÖAãÂÈ¢‰!®>8îÞ¢þŽÚZ¶Ö.ß#y3n›Å|]× ÄµÆ®OF´bó–/× Ä52¾JÉÁvØd?ŠkâÖ¶_Œ¼š7›By­@^ç«”´ÖšuQ`+ØÚ –üv•Ìé¯{Õp­+46‘ÊAŠq Åc+Šmb[k.4¼h”E~-Z¤ÐP¨¹hn¢Õ“F){ÅT´J²%@k-~——Ðu»Pd+ÙD;Ÿ-´ß¶¤äŵq ´ôñCû-kdC¤±a@d­´úëyÆÖ© ´ü]šòSà=7p5Z?_É>$ØŠn¥[ )Ÿe=Ên¥§|”v½¶ oûnKœ½_Du‹J§ž…ê[ú&R;IkËÁb»Êp2ܾäòÍñˆž¶ëP¨Æ¨qâ|•³£š«“¤W ÆéæÊôÇ®ç }¨Ä(qâôϺ-÷RqØ Ã5nÅ•ãA.’×íœ8_ÏSmÜl™I®@€kã2ò7gX‹³ÍÊBý­@g|>¼ËíR«Bù­ 6Êv]¤ËíTXÍBé­Œ&ŠzxPbZÞvÔm e7ã躸“ß]{VƒÒl‰r[ÜÖ›ß<‰£“:©º"b¯ ¨;\w¥ðV!¼õ–lê¤Z¨ÁÕ*å· ù­w7û:»¯¸å—P)¼Uo‚·¸;1 I„pæ V%B&!;á]Âý:£HB!¡ˆ¿ª¤ÖozA¥äV!¹õÞ|ž/Á×qÝ«ÔHh"X“¼—Ð÷²L¶è$Àêkÿ`<ÒØ«èŠO¥ÌV!³õµyðDûÞz°J•­Beë#ù‡xƒïPp*›àïÜÝÍiö«„ÓÀÐØÜ‘3ðÌÇÛ‘µR`«؆KEô¿v1X¥¶V¡­ –çÐ…Ç8*uµ ]MÐë}ÇUF3BU“›æ-׸füAPšš{t®\]L2=¶RK«ÐÒÜ“óöX.ÃrY©¡UhhîÁ¹rÍ{~ÏÇ¢v†‹Ä»Ü0w]Ýa3*DN¥dV!™u÷,"±¨++~ËPÒ±‚J¹¬B.óð¢/¸ŸÝêN Ù –1àç nûà¦ÐVJeRÙXׯ>àɽµøB(–a—ðwÍ}•dߥ² ©l¬ûeðìQTšBàù~© ½n"ÁgÞ—ßPªzÓÐȃC5/U„ Y…BF°ÎÐßàÝ®âÁ•J}¬BÝïOEgù¢kÖç¬R«ÐÆnðí.RJÖ•êX…:6ìtúΕ¸E|á §ÞJÐRÏŽîTJZ3<Ÿy³‡÷ŠÐ®½øÈ»ßOUªX3úýŒÃb]ðíQ¼š©A?2ÖdšŸ4U«™þŒh!)àôê3«»hØêJÁj¦oxþñ°jôT«f*‚½¢¥´³•RÕLEˆoxqÛ LcŽbà3÷ák)U†æUð÷£F·½¦±¦fjà3ïàk)ˆ¢ÔLÏg½m-Å%©™øxAGÂì¢îFj¦Á£Àó¿kÄk´8ãh*Ùl˜˜Þ?NŠßFØüœVOШFÍÔáã ß½('[jÔLE°{wB[&æÐÚ¨FÍT„xÂeb«N!¸ø¬}¶°t¯„W‡µO«Ÿ´Ê4šéÌ_¹$÷œnÔ¡p¹•Žö5ëYï0DÈÇûáÙ]AÊY~£5S'¼K(×:bÎyP£…$”óÊZDq/²Qš©úY‚–QÝ«DÏl "Ør?¶k½Úï]ÔL¦ð7JT3uRÿ m?dÊ‚ZÕLÅ Ÿ½\‘E«™:§žœyÕ¦²êÕLʼn”£ý%›ó7ÊX3uN;97?*+‡ÆŸprÒW9±¯µ{žFak¦Îù*§¬m%™×LÅÉŸåÔµ§$ûPç™.ã|”úržà´¢Qêšé¿ã(¾Iæù«†˜°½ÙQU”"¢Q¤Õ’‚Ç·N7F~m”¿fêðþ‚ßîÜÒ×F l¦"„3ÿ› { Š`¸sÄG }¯#øµQ›©ñ,áUPÌ6‡ŽÂ^MÐ0”Ãf*B:JXRŽéûŠØLð.á`ˆóþFUl¦"䣄X·— »Iêb3uÂQB[+ 5*c¸°Ž„r”nÁ†hjc3uÂQÂö²QK¢:6ÓI(ÁƵ”åJ§Ôäº ÿI mš(á¤D).œë‹Ac§.F<ðáîªÜ¨“ÍÔК‹¾ð6!¡Ý(•ÍÔñãÀ»¿Üp-ƒéã ®5^qbÒ(˜ÍÔg×°8£nÔÌf*Fþ(Æ7AÖ(›!ìÐÈ¡ìá+üå䫱ЂYƒ`&h{A}£‹oŸ"éùÆÛF¯À4.fÃ×{λÿW{¦(†©ǽ6EÎ×>Á Ç£Y!‰ |Ïy]×hnGrXƒpzæöv ¥°)ìw÷À}­ó¹(dÛ%±I,×UÖŽ´½|I^×b¹QkÇrÑ™Î/êrÛOö(‘5Hd¢•ïÓN‰ÚZ®Q(kÊrqÕ僷›’*IËC.­}Óv0VõkÍD3œ Û«^:·¦ânËÞd(™5Hf‚÷Üç:¿Ý_;[$3‘Øg©7Jf ’\G­˜­bÁkå¶àÙŽ9pMØ(–5ˆe€§X×ÙÚJ¶Q*kʈ]«dGW[̨45”2€ó šm)Ãnž2YƒLFè‘o²M!U‚F…Jp9­c!PâžÆ„L–í6ï¥vW]1´BU]»Ø¨•5he „ƒ¢ƒW¿j¤vÒ¨Q2ý¡$¥ƒé—ÿk›º:xÕ¨œ5(g%Wëm²?KVdIìÄþØÕèAs.Jh Z]éÌ=†»]–ñ_H¢¡!¤U»€Ï#—Ëg8 J;CD«ëšé½ùðÁ)›Áˇà m7ó¡ÕÁZÌÍF¹ !3×=¾±Ý£e²™Lð{î÷^SyÓÖÇN¼C{õš”Ä$1˳"î$T ZBÀùm÷Ey£Ö øÌµyì æIñ«Aüôì¾±) -áK×!ÓC4ùqœÙÒñ??¼¹!•–„Özv£w[4%ß³Ñ “`†åŽu5ìí¶(Íx)5H`@›ÙWÎÞƒÙ×XƒÖ†_O:;`í”æî3õ·¹˜ß–M£"Ö ˆý;²{=ÿö«Z!_çU’îiÔÊ´²›MXÙàNܘ˕yŸã´íß>G»å1j¡Œs±ú¼¨­Ájt»F'ixç“q¥½§áaÖU6KÚ>´iù¶¨å›£ÒÖ ´u;{”tÛà`_L­­AkëvGÌQʈHµ­Qmƒã•Q>KY»Ìzl=ÐÜúº£$}ZxãÌê+©»5èn}Ýñ¤¤íÞ¢åÕ·õ­Çb{/Š7ÔàÏÂFN”zVÌÏ?Xð¤F®A‡ëÑg/ÊdÆÅy§סʼnòQʵû¶DJ eZXŸx„T–.˜Ö…gÂ#áÑáý{–=\§×!À Ó?^ù÷õI³§ëà:8ÞÕ‰¦{¨³íà:8‚ÏÜ‹Ÿ½¬„W«àé ®>+)7‚›Õå>knn,Ê»ÞÏ$žUñÖV÷AÂpÂ;ÿ˜Wœ6UˆÒ[‡ô6Vè0”uî4e·Ì®åÈiú™f¢èÖCü ÚhþwÕ^¸ú©š F§סÀ’ÖÍv$àú¹5èÞ:„7aû~Vhw¡i`Hn@ë âBGc¾‡b[‡Øtô»+„qmÄ«¥QfC×bèGÞ~K‚ ýëÿ½R]Ä[timereg/data/tTRACE.txt.gz0000644000176200001440000003466614666545364015063 0ustar liggesusers‹]]K²l¹mœko þvâiÛjY=ÐH-ÛË7D‚¼ŠvÐOÝçUÕáH$à¯?þúëóëÿñ‡ÿüó·?ÿõOûÃýýo6þöß¿û¿üýÿlüë¿ýçïþîÿñÏ?þáÿþþöë/¿þc¨–_?òÝŸý)Ÿ1¾"j°?~k›ŸbÏõZä×ÇÇOµ§ä3æwŒe°ç¾«/>ÚsŠÏ›óÛ§½}â·´ñ{nî_û—òøeÝ>t4|§~GÙø¬ÖšþúøhÏU|ÀhßÞ7ÞÀ~¥ž7Щöi>Úsó¼ƒÚ/ïø¼ùUÝñ¢þ¢˜ÿfÿµ ž[_õ¼C™ÕÞÁF|¯ÞªßU:þнƒtÎÜÂÌÙd}%Ÿ³O9s'ãÌÝÐÞ}%ðƒð”½m|ëü–už-öë|¼Ÿfoky¾u¶óëtùzùhÏõó¶ë;êy[_‰3+­ÚBØ€õÂSå;¶Æo+ržš[}!OùõñUâ³z9OÕ=ì |Œ™ßKª-Þ¡K¼©M†½©±bge[‹Ï[¢±²²}eeÎS¶G–ôXWõï[ì[}ÌÛvðÀž³wXØJ]§?f£ý»ØègûvÛ çlÛÛRùxÞÿ£’ oS¶FlÞÝ|ónßä-_s¾fò-›ý'‰·¬5>l¯ês»jœûÝÝV{âKm?Åþhºí9c6ìCl­|IìŸn¯s»íMmÀÙÂWU[wî6ѳwu,Û>æþ°Ý6×y®}GìÇÙx­C7ks~¨ŸÙø¸ê_ë£}Çà»J~í8s×›ø ´1wˆ^¯±ü%VB¶Ø÷úˆ3ƒ/³¹¨+feÕv^WÔæØÇØJçDoèbUÿ8?gõí@ÏÍWåºêô=2¯õ­ßæóãÿ¤MRí$ø¶Ë~vûî~~™ýÕ8ÒÅ·¦n ÎŒØíƒö·…®~ì}Œîk9#5ì¹l_±˜›×š6sŸ™«'¿ãäÇ2ù§Äc£´øZõÇlüäA…©?˵OjÁI-X.lÎõ-….©›áÁ§-¼ÄÂK ̰Ú+¦QªaV¥ºY•š‹jf¤ÆÔ™±Ñø´¹ý´Úèþìü:;­…fzÄ©¾7mH+bŒŸpŒÍ>Oévcîc|«øsu¶8Ö½ôXþ.¾þ]âDØõ À·àÖìµ¹i9½]¿{ó)ùÕ݆«OéwòXϾy¬cNú(6'>Æ:Lýê¤_ K2ݽÍy)þÈè“ûMèü$øxmï²Í%Ý3~Xu“éc.‚ÍÓPi }Ò:Ì*¾Ó&´„%þîØ»¶KÝÂÙx~ŒoŽ.œŠ)qÖøoØý óçk\i®Ĩf6Z˜·³F û¬EÆl¹µ×€*- ôtذý?pgÔ¯Ž\I:ðíûÑÇðöË0_ÎÏ—ÜG|^9«4dÅQ%ÞtLqo4å·ñm3O•„±l~’Û¼¾Èþ[,ºÁ‹˜‘ªÃœŽv÷£-Ï:§% c/ïn”2x¢âEû€-ÂG+¾ÔJ‰“JÛ±ütw*XûÊòGíºEG/òä¼u‡AìÇ Ü÷wjã`}¸ ¶1?ÛŒpi¡láñª8_5?Î÷^‹-öm±÷zULïÒÙñšiÒýj»; µ1¤ï„–€4,É*ö 6„iÅF^UcEj8¯VÜ’ø˜ŸfG ˆ%ŽNد>a‚oÞv³3„è¥Hmþ¨Ã+ÝcfS²Ã wƒa«<Gç…UÛöU«\–§c68kØœX ;†ÊÏ ŸÞÒ€qÂð·¹cµêˆÃO ˜±hÏìÂ,-ÛU6„•¶__¾¾]‘à¬Ió—lýºUý¶Cì\×p—sÙøÈŸev¾Ñ·BXàí‹n^fìJTÇP< ñ‘öÒÐQe<3æ$òí@¾ô“@"­aÔJ}ù¡öñÚËjþ>ݸÂÚ¯ŸçÕ¿È¡YŠðD«-‡—íB=ßt „\ÍWÛÇk|í3â òÅa5«c_éã…î;ƒ¨õGNOuv£A©6Wîžy|ýœ¾äó ,]s.檱1€»Q¹­ušós>ò¹j³¦Ê-´#æ‘éÏÙˆÛM\¯<ž›1ªOœßÜ"T:ðOµé`ÅÇt¹gmDRfÝœÏÑ®íèé h@$q¬êãERÛ9ßuÕJŒ,ÀÈ´šI½ó¸3nêçÅÇDðÓ§˜îÁáœxq#^ܺ°`‹6½íÍ?ÎÇ„¾vHe·‹ôí·—ª†Þ„[°–aŸícÆ.8ÿ’›áÌÂÇ=&5ó¡ãñÛö·¶º«ºi>ªá@µÜg6 µ&hˆ3lvÐmKYûèN+m7–ÓUÞi6#PÙ<- =|ÛŠÕÜÇö©aÑ­hŸ{l¼ÁØüV±ˆaÖ€žˆí&b»Xó…C&&8˜V:øã!E'uŽ Ž<Œ­ùœ6­ÜáMõTìÉšo!nµfcX< Ï•ŸßE÷芮%Bì¦c€éèix$¾ÖТ£T3¨0t6:÷š‘WqDnãݺü)=‚ÖvܾËëÚÔé"2‡GÐDqun×`ìËÜ‹Úx§dÛç…ÕùÎ0ƒÕOŸoè±:wb°f>^¨dÛi$ ÆÎçÄ)÷kýlŽð*ç”VqµÍD3¶ÙÛÞâm?ï4+'XIªéYÞ1-ú3Pï5Ù²ðÂö€&1ý°t,«=Ÿ‹Ðß¹— ”‚s&Ç2x´èãµÐ;°8Þ5 lñó10™™ñÙžjxJ› ÀÊ'F˜í•i ?ûâ[¨GÛÖ]h4ŒÆ[|¿ •„ó3w&pjL|Ødx´tùuŸ}v€¬Lr¯i¦‡#;²/cö¬žWѺsY]r ԟxÝAýúVwžV{hÇ®mß®`€ññZµ_­ñûu©ø*ùx)MO¶^®›§ ƒì‰WP³Ü£Úi4„a»VbªÍÞá½WËevjZ…öÞ\‚Û³VÒ nvß>¿û¦±­mõÕ¬ÚHœo>c“ ÝT‚‡*>¦mñ -U!‹ Ž #È©dÖÂf- ŠÏZôÈ[…Už…0è¼ÃöÈ®4Ç]¬ó¸d¦¤*vŒî¡9Ç™Kx;‘ܘ¬ã]í<¯ÜYdÑ8dQ†oµòœ92<¶¢à¹"×(:n!"Üf¬ºûžÈÓ‰Éôñëïé'ß³éÎdpOË:ÏM±/r÷½a d¨¤0]ˆ@ýïpQ•èqή‚{ÇÕ9ìÏ™¸åÖzÌI\h3³W,£<ŽZR5@ûž–:eÓ¹ïŠüW¤AðžžÍâäg“ìvf=y ² ¶C}u¸Xã[öŽE]=v¯çÓÆ*…ð(IŠÄtÔOÒá˜fNo¡©ÙZó=îãû­2”&Yȶú“­´ÅÜ't0—g«!{ÔNöhÒ7í ¡'И;Ú.Ù¾¹ìÏ–sV<“×O&O™Ýêv©U²f´Ù¸T‹çòjR-aâG>}6¡ »“Øžy̪×bîz$SOr·Üm+³P¯‘•Ü+¾Fs£© YJ07‰‹0¾Èx–Lp½Üsq¤g§:¢µŽ°©Ÿ°)£ÿÙ#wg蜑äF¶%­9ÿka ‚,~ehL‡™AÍwäG±ÒêÃÇÄežfd‹Û?3éž@Aò¿-¼2‘Y8ßêåºr³µ3lwÍu–R±oêýÙ”+ÑàŠ`¨Ÿ$ŠÞ\¬¹©º ózÛS±˜`Æ5 AÇY?$÷}ýüüþ<–µÇ¬‘3‘áÆÀÇ °eT(úL:ê@®sÜpNŽqÎp u!“²ò™ìMóˆàþ„ôˆè_†”ô¹}i=­žÒ÷ñfÏSUH6 ¤&s™)èÈß5íjŽ Ç²ïKØ*ìÎXØÙ1Ê "[°-2£ÿTÚ Äyæ!.«;ÎSªjìc&TØÁI–´sÚ¹ÉlKñÏÚá±5Ḁ‹óÑnf[„qÂ\§†OœdhÏãoéK°/³hv¬â!2Ÿ}8FðñÎX¾ ö@hý-}ÌÜc€°Orxü2Ä'¢51‘mpRtåèÀªŸYZú@UÚíŠ]9Ü·£¯ßI~ÆMœ=½Ga¯L¦’k÷Íáã…M¶TBÀ˜B!ò1‰§:åyíæL*’&5³&¶-NXæ®leý ŒÖîZléOv\`åÁ@1 ˜š¤B|ërŽÂÇ»ú Ò/;×Öp.j„°k®¢Y-Èû‰ gcl^ ~ãÇщm_¬Ž4hhjÜ’k ¨¯ÇLt€îHÐ=þ§ )ƒÛ×)K ýÂyjMÂfdgÝ/¤¸ag_ñiu"$ž5ŸóXqÒ—‘D‹€h‘ϓ–)DOAÞËv$ãcB ?—Üó¸kÇ¿EÛ–,³ðƒ¸ÓÅ<>&¸3H|S„NþdäùßQn¦†¦ìÛ¶a¢Öß „ÁæÒÖ#AJúŽÈ±ÀØ ¶ 5?»[¬jÆz¶YkëyòÎÑ›Wr±~“ÛâÒipiÍ`ä@;P®v…ȳæÑ•AçÒÇóœƒAï±ÜGõ…7UÊÉY^}I};FJ€‚á/[°|u†Ÿ*©˜„ÂÃ#ǽž]H“\3FÕ›wS·Ž>æ;uœk¿Ê˜Ý°ªín-§p“•[ÁQj´˜wÔÏÃpƒT:f/¾´!QÓàÜ+'d‚Ž–tyy´zvºó¶ˆRez4îã5f‘‰ÀwΞÉlæMp ˜ú’< `äÑt-I² ®‚ÁÕvÓŸ6ÐÄŒHÐp6ÖÇă2†¦W±C4¡Öz°dI{s%¤µzʬ"Jø§¼™yŸ¨îãÝÂniéákKÿSÇ=¬;cí'Ÿd/!ãéÔ<Ô”a‚™Ÿ´ï@ÄkRâ\h¸á§*ýTp% ¼“U“³z´>‰P b;@‰Êq¢“ñË ÷h±²¦n*©l,FÕ‘ªL†ûM #qN/l„4ŸbsÉzÿÖ+x¡¾«AôûÄLÕ-gø<æT4ÉÚïF™ÜÄäwlžäë%²l†G¡)¡ ZŽVRâeÆP”n øø!áÐ~ÄzÎÚqñKø5©pïu•KÜ8‚â:ˆ ûá-[¼Ë8ecévÕt³ºáØP‡$¹„S;1÷ÈàÎ ‚x¹C–á1a1*T õU%¨ ›/iͰÚu»C¡r8p„ì®.¤l—Üj‚å¼á±Èõq+Þm½ B[ Gº(¶?æ>^ªÌþB¡r¨T7B>)KF…ÃÛ¨{dÌ—y%Q"¶ñG±¡›w&´UÄú ƒxì/¥üg”0Pyùèw&Ý0ó9¥*nÁg­v³R`V(×Úámó-d¯Ö“ˆv/”€ªn-²ŠEývr£Ã¡>~2ñ¡9D©x#¹¡Ì*"Ý@­v…gªÇ5Å5„‘g‰˜’±EsP¹^‰]IZ\R9dŽ£"6ºÌ¢Órƒ‡b &¥;ýn ·Ä©dÖßNX‚¢Ÿ”R¹z‹t`ÚΆÀ¾é3‘í;å–8è2têgûÑa*(Õz(ÕMÅJPjš%%c4Ðäîä@vz+G½€4¬åºâhÉ–„çLûxBje>ª¸Ô^[Ê’Éån#ez€N® ÈÈäôèär«2¨DÀŠá ù_kO+ÿÓI©¢J¤ž2‘ Í{hLåÛ-í1ñ"à0b$x<ùîãç©Ø(WÍ>ƒÂ päľ+ƒ/ÛBwàdÅÍ/8óªœ:Np“[×#\.…ãB¬IQ6tuúØb'#GŠ¡‚´Thþ|¼A¦”T¯ÅAjÝ!ƒŸ'¯Q¨!°‚S×CªGÐÒ¡¥>¿Žò™>;r= ´{Ý¡+<ĵG2[ZN÷U“Ç’”@+ìcxåÑùx÷ñn46ÏNe3s.V°Bü@øHïd¿,Ã$2ï2€?ðG²KƒÆŸáª…[ò†«Y¶Ó5{æÒã9sKPTÛfMÑÉLÑ 3´£¹vÆÇ ®A̓@]<ãcNœWrS0£ç×)’ZÈ¬Ž´+“9ß^gûAÜ)¿C2ªÜ–‰¹G×£ ÉF†Ž†ŠØVYÛŽø ㇣“ DÛRî?’³4<¸‘ÑßÞ±rŸRE3€¨ÆATgº»ÊMÃËÐÑåØNýïœn=¨ /Ôƒ¨ÑÙPm×®²Ãe"ksº#çkÿß]–4gG‚{ž"±&:nJΦ³¼h$/¯R×ê+ |O´5&¥ ð»5>m@ñÐBösT?‹´ L¨4u¡žeõœ2‡EBÐÆº—VœŽðñr(÷8d“ 9ìŽ~Õ•Ôý,Pè£÷÷t_ ÜDW·M>Þ[ß–üx‹ª¶=hô1qKoˆcÕ7u©Cûx£Ë%2‡[„.qÃ%î«ÀiÁÎõ¦Ó‘¢ïsLH–Œ-2Ì£^d®¨¬ ~6"šÞ™û˜øÔ (÷×€M3© cRדb#ï—VO2"RÜê®Ï…¢5â½åp÷sèrY¨®'*·X¤ÒÙv²È2åˆ~#ÒPÑãºë+N‹3ÓqbWÛË ²ýªØˆ½C–Û_3Ó¿ëÈ”œÔ_^dð¶QÓi@®ƒ5¾åê&•ßbQÛØ¥Ûùmž" QUÈõ¢[^d¦¨]sÍÌŽh‹³8g|ôÜ’Ñ¥—>) 2y/2YŽ29 í•‹Ú^˜xðÀÁÅý.û½ÄQôÜð¼&ÛQ2¶,ót…ãÑyíeYD¬ÿ5ëê e^ÚiD ›Rø ÍR .ûü–yìÜ4JVÐsÓ2þ²-¶å’ø.yÄ^Á+€õ‘¯P¿¨[ñÙKSؽPÅ¡–ÖFQ 9¶æÌÇPÁ{H‘ÑõVZÞqiæ–½¢7•ˆ-À`:½ããÏZW’"Ô‚ ”Ó Oí0å±-•FjÛÅyÑ)U­—B+ÿC*¯4€PYäúí•ÐV¨n儈®á ¸wÜ Ò5LÍú†©)¤ÖTÛøIeM–­¶,Z8y«¼“¥õ"ÊØ@ú}|ƒyd|ñy¨áä÷ ‡WË̤¤ãüfAáÌ~ÜfÎsøÆ(¶È5n¤Ê)Â²ãø¸ßXÕ~š‹‰Ž» 6I7Ø E@Î㺲®@P'/È`а§4cPÒ×ÞÔ#÷ìÎŒcŸÌ-”¬¯þº©zËW#ïÒÁäøx3Ië€'L0Ó‚rï{Êè8Ñ“ó:¼:P?¹¯ú$Š"kRyR ƒ¸*ÁK Ó]ÒP]™ä[óÆÐ¦ÅlűICu7õ¬NlÐM 3M”`i׺ø%s¬)ëÐü< Ôáp6^¤E%|Ç·öò¤-LgÅ1µñ 䦨`câÙÞ"%jVq?X¡Õ§¬¦@¹'h1USA8Wù<…&- 2­ZœQõñ“ròý¤(%6Ä]GÛÎVb&Á$fÖ®ÕõQÌyîB‹©´²öÁ-“bJ©¢„©¶ÏÃŒCõý9™ ÚOR?ɉ6× §c"o3ÑÀ8Eh0f¬ZCåÝÉ<(wÖÊj¹ÂF`~d¿âlïwpVÅlCæ:!mëjw‡ëÁ³$—ü5 Þå¼{¬ñC t2:4@ý&ERÌ6™±#µ9Z›“o39“‰Îx®LÔÍL:–PR°X2ßåÒHÚºFŒoÊgzOS×MÄz!J‚Òç*àšŸŒ ÷"'ÁP‡„¦ Í¢oÙ-EQÔ’`éX©ŽeÂÃŽS(Z;ØFs3{ÂcÓ72>o VÚÞœ‘9Àì²tÔ¢48´öt×°?Ñ_š\<÷Sð|LšƒÜì=P#ÌÛn™÷£ÆöúÇŸÆÓ0ëÐù†­'‰3­»™bE&y_ßbpT©ÉÎR€›Êƒ›Ž†>¼AJA¡xº‚g_RMÓâãÞZhOs~R3t¨õ‡·ÇÝ*·[BDêÄú€¾Í›h½:,¥À”ä(|¼Ž‘»×+x ˆ 2 ( A-;Ùâg|Öâ¹Ú!>—*gU‰­G«»èš­TtÝ8F6÷ÊCÜ ‘ÐÑœ¨¢ÏŠgåÀ¨Ù€ä¯Î…zu ¸'37ó«o› ”í¯fj­`no%FOëÂF?Ñs§_†Z§Äú•R”&»³ëÏÉòÎzžêæ2²û‰˜!2_>@>Ýõq˜œy|~”|ýHù&cöQe­Úî^Ý6ï,/VØi‚ mYnUvÕît¤yQÙñEÛiÁ µr„ð%ÕÔ3{ñ˜íGô|TƒNÃ?ÚSN¤¿ëL÷[Ü„»zF­¨u­òŽò/J#&îÄÉmüy+³J#I  G—€…‰Z£`àY¡óòñ.Q-PóÓ†€Ü”TÆb"ËmÂE*a‚¬›íi,áÝh¤x‚u˜¢×ïÀ‚r«×8/@æ#¢°Ï½á]XЪŽß|üÖI¹Ÿ­¼H5o$ã e’Ü+àˆ}è››¢üÆKõYÖ¯—D0‹´­^¬p–%#.“Ä õÙÕP–=ì“2Ò3›éo¨³¾MUž‚¤’‚‚PlYc¦0.,Lc øí!7ž÷N.™*‹¢)ƒêû;A-e ‚¼Ž7™mŸ·¯ÝãFÅsµý(j˜+¥!kèáÕ@!ó{ÍÂäaŽb:Á!¿UcC³›¡+Û\}]I¸õy-fç<í0Í4„ã>Úi¯Ñrë3Në¢6ÐÖŒ8Ù%›)zs”p€¨4ð‘ˆíîZ½¥Ö¾v“ôÏæ×\*èã4 ± EÝ‚QµØ¥åˆCޝJ4´Gª¨>©§ú$+/H2Ÿ¶Èï;Ky„]™ÜÊ| ËÕ{«ÞÊ-“G]SÎÌ©ô@Ñ![.X’¸<,YÖy) ¾iRu‘k-è{[¸€gŠÒòŽ1«A…iOP^4mòs?ÏùêÙœŽÊxâ㈕ëf„IsÖó ȯhPIøPâÑ+¢ÐúJF¼Ív&´™aipˆ­]Óäl_ÊãØVNwޛ؜3;N¶LêèDêx>õüž‰©ÜŒìøØÚ@jê)™®P<ÏݨÆðʦËUü#eåp ¥&jµŽ`‹¼vÔ¬ö̯ô ’±Fx9E/‚@0ñ®ZÐM¤ª` —+&æ@Ø(,YÑz¶t™‹²<ÔÃeŸÃCYï\þZüGiÛ†#8áUMÄV·žÊ¥¸)p¾$¦{I»~+óÍÅ–ß›%©Y‘ÙØ:}@»‹¦‡7@hY¹KŽÕÒ£GªqG8‡æÑ¥×µ&«4!ªG¥©Éˆš)o°bvΪfPX‚ÛQõÝŸ*+WîäÜl–O6ôn{d­˜«)(ó;³+w¢ËM€²wÆè…ÝÈúÌÛúpœ®á— å— }š²ŽÍ(ÂßÔ‚.¥>-6®ñœyœMé)šº…ιŸw§Úœ¢çlH<›¶”­ tðעϦ0¯² y¶“GÍr¢^¹£Ù1BP‡-§;Åš}tÊ0¬eÐÉ-œ™w6!ÐKÍdÚ‡'좌¥E[]I^.¯ÊÊc0H‘ÊŸ8<:až J.YÚd@^vP[Bùͬ*ÚtÖš:zgœÁR A ZêE¼JŠ¡¨°ô”ã5±lU&ËÊ…åâ«&• “¼b5Zt5h­Ï +Hx±ljɲŽPÄ¢7äm y’g•VeA~ѧH(åZJöò#êãz{EPšRóß0=:w'%J6 ï´¨º]Oï"„'½ìf´õíÜì ]`Ä’^Ê•ô’\† uüíÔñŸµpžê­ä*7&|—§ö~£Ù׿Q³ düéWEä¥QRó•øu†OrV÷xhª,äbÑt«È׬ 8³#„DöÚb·ä]n?ÀåËËjD‰·•Ž˜£¯Ìk:B*X¢NÁA¬IS³ã-^'Öý—¤=Ek’}òÚeÍníI ¡åôÙö:´;ô÷1Ùï RÇ^ƒÙH4:‘ÍôɱÓ#Ùo’hµP”›žõž²$'* ÎAy5ª ˜g§>KØÁ¥2çÃŽK³ÍÚ“„VöjÊÒ.Ÿ·’ê’©JÎËMKo¡M…Þâ¢jÇ|Öœ*NÏ„³3«>~²þoNGp~ÙŠ(¯RoÂð¥d`ÑFteQô›šZ•Bms‡¸¹ÿ85»•±»°"+¡'+qÖÅéì!™¬«ª’Ö‡Z÷Æ ›b ƒåe›?´×—¿¡vˆ·NEZðLƒ9ïl¨Höû”ÇDK&üN¦n*@™ÏXšØÚiù¼¸ÇÜOàqÃ5(÷›äª‘'ïÑ5v2>9Ë#º ‹VO%NìLÖ‡C×ÖÒ÷eÞćØgÌfÿfta úçÉ,¡,>4@VòìE4¸±Ú™[9eÆ? Õ‘¢¯ Kjž&›ö4œÛVžœÄîÙ?¶¢oŸŒØBœæØaè0\e^Ÿ8Yi}‚ñš-bz>SC m›ø"eˆ£{í@›º 9,?‚òËåÍ™[­;K†ÈÒVk…—Ù°:¾BCëãe-r€‘™`ô–Q.ßz^£áYdNðŽ>’?ÉìÊ„Üãì„sß•7­ŒrÉšUˆ’óÉ9Íô~ÔLÞ[HΉF¸Ñõ*_ËÄcéz- 6ïq>¡¦ Ýùá}‰+D`„€}jŽñ¾\ =ZcÀ<6e£L^ Q²WŠ>ôvcF±2¡_Ü­úxAìÌZ‡ž}Hø˜¿ÎÉ÷Ë ²U Žš¯7g÷J T ¢þ’íÐݤD“%Ò9³\93*ô.0íÙ B=J%üÙÚ—â’†«{r-Œõväê`Y(ÙË…¨ÞëG4—?ÜŽgžköŽ7eèÓ™¶÷iŒ[KÞÞ$.&«ªp·Äñd‘6fæÀ|Eãû–ë €„H.ïÎöª{MZ³–ýæÑMÙ¨„Úãó$mÙÕ¨3iaÓ?®=}±]ï)™â¢ˆ¤3´u $7,i€jX–‰ÎŒ¹AÆéôQ½RQ»‘cÚ§ri£ÊìÑ.ÀÇ;¿®SfÄÏ(MŸ©±>›y1ÎkÜ6ª+‘¼»•/äÉ,p¢!l´j6<âÜ’KëhЛ~y^Ƨ¬„wdW¦†Á›ù £Âˆ:Í~ûŠĤ#u}3/(qúYyèQòµ.© zô÷øiüùж#ªc]3]¾©›d»– ¦¶,\ƒmè+»˜eS[˜Ë¡óžy*Hp’TPç(lød€;KÖ>e+@Àr|ô£èi.³Ò ôb;ôbôڪߠ‰…ff4+r)ZW¼æ½I3¤Ç õª>}ÿÝù§½/Ù·èŒú$ÞʜηJ„HÉQJRkNÈ*'¤8ÇtîHg É£¼‚­.z!yë=Å|Lïæ¼þe­iw;=ìÚ%Îýš¡ó”Ž’:ßÓlçî!H–-³ ”£Ð.µyã¨Fu‘ò;ë^/ѯ<ùŠ  ¥T»¢>´â%¢Íâ,díô6Ltá@pI’-/ÍõÁÚ×»-]„¹síÉöCCVˆlÐe. uK!0h aôj;ÃãÞÒjõt•Y\‰Üi­Xhð+“…à¹/´0"ÒRlÆ[¸†‚?Ò›TôŒñÌ‚tΊ „$O[ˆÒÒø²‡ÚEC•ž¡¥’]Ý;Úÿµ6¶.V¡ý ¤Ž<·~ëÇçà»)C^çU³öÓM3öÂb\ «ç‹££$˜Å¨YX ¬yÅDŽØïõš¬ÂÜv'u\iÒ"Y˜1(¢q(¢™Xƒ e²¥]Y¸OpÝþ²^ØUóêÇp%:Ü`ûx?Î»ÚÆ¶"\ ‚Ž’ì äló†~,¥ÏÒl²g[©·Æ}§¾¢·E_Ëh ëlÑ%ÉÇ$þûÊ~Šýh½Ü›y6wV¶Æ/8{VãPm£åM›øVÉšHÞ‹* LDÞ[íÂ~÷´ß ·F¶îþ fÄÌæm:­q;iy½$%×¢í/ÊÔ«ì«!@‰2ý [ ›E˜° Ù¤BPtÈ“ ¢^@v:dÐ<—oQÊ0x±•ýjpLsSO^e¥S›¦ÐW šÅUÞ#‡ª'æë[Gk ®2ó dÔ9 YÚE/µ7˜0A¯ÆHovp ýp =m׺™®gnÈþ<ù©•-¸yƒ LÜ7€¹¥´¬@²6)àût¦pÊ3Ñ3ÉÎ,VtMÔyù ¯™YçgJÞt5ðÜxŸóÚ‘”Ô‹÷¬Ö«ÅÓ…Bd 2”3ÔrñIõŸ³ÚѦ²_Y³^!À¸óˆ+,}¼ÈÕlljf©â³M à÷Úöìâ™Ñ{¢]hךÛÁ/Ì%³/êc—≎ÁvúƒòtS÷¥LMqË®` Ð}ò'#b]¿!‡™‘›M`{_ͪþ*€Åò´ÑrÕÒÈ$ŠÜ€TŽº)Ë©jRÈÙ÷†|LÑ*¾ný 5Zh:€TC ½jȧ—7šîˆœ)¼YçvÁc»³:ÊŒv/oõÞ … &s1èäãåàZ*)f"³6 ó ~–f–B²bNA™ë¡Ì“ºÍ¹²ï~‹ë—WPqíyûÝ8]"îîò–yúóÔ¢áýä2ì4×¼ƒù;-(q,L7œÆûÙ‡×÷z’c>ØÌ«hòþ¤ˆÅZ9·¹|ž<_쉫Ѓ~šÞÌ`ßã,É_²M ôÚw::]l±À;vT@˾Ö;,fw¶y‚ZNqÑl|­®L¯VŸ¸h>AT íñ±¾Á×àzÔ~°·ú]yGÇL‚¥_^7‡†kìò×yQ ®éçú,Y<ýBe‹Ð8òþÆŽæ¹%YäùIbÖlï-(â 7E }^Kw,¹Ð©óš;CÁ¸U“N¸m¢#ÞDƒÖëÞyý½§KÎÉÞ^Œc1OÏ•ÙQtÑŸú¬s£î%ùe„™ÓÓ7ÂÇsÑ×Q„ßÔ0P¨¡lÞ¿¡’·Û²Ç"㎒ö4W]5y”šå; yóxÇ¿¬ÀL¡H‡è´Cë’÷ñ æ½}fBq…W®2œi0Є×{°Žæíâ iתïr³ß‘Ý·& QÅäã'áMÐ4ÁK/Š2aµŽà{òG¡ŒŽ-LÛ‚à{Õz)ĸräsb»8~hž¨·y¢œ{ÉÒ6°ažºHÁÇ++ïUm™' çi•íÁÞܹµÍê2ï¡? *°—Öçʇòl!ÖãLçu§Rˆ ˆý]¬¾UËå)A›Q¾€·^Ä÷Réù^ühV8%~,!”¼mÉÅSí¡tä½·Çè¬oÀM'å8×Î)¸³³"3«ÎÆÝÜ u¾Ì_Íþx®.cõ¹QkõlÜ^ïõ–h²°$Ôò»J›P&ƒn|%#J¨©f¹IŒØü@u>÷õ“ôæŒ_Ž[eû¹U6ùÞá¨æ~â[b·Ùr¿Ï™]*ˆÇC†.4%Z·º„CRŒ9P'?4¢ÉzoÓxO×yç„6šãé l"¿üdÇQšÌJã’–qni @¸q9äojÕ13ƒ^T?&ì`Jùá^_©`ÉBý™b¢§ÈÄ·Ö‡4űÀ¸0YôéO×kºØÉK%§g fÕ<:ká*£33yg-šDÉé•ޏg‰D>–ñëx¬%­ê€s(ñ •_I%Žpo~9ý>•28×nA{õo…fêüjâGEó¦ûœJ!>oUVtÈSxi2‚[ o|>»íж…:AÛGq-Óã6Y€­ç’2÷-ùr¶B¥ˆq­ÉbÞ:n(×È‘¼Ìòž›¥È€œí,ݯÏÕÜy‘jË̻Óí*çß;@hG—-&½­~ÏŸ‚v¾·k˜ß*–,H¡¦7Ü÷sÃ}}8ñZµà¡øOöÞW13å4‹.O5@Iƒ"÷N£ÓdåÆÈd5VÚ~©Å:û˜Öɳo=•™DÔƒÈú@²k³}OÍyÉU§áÛÀ×7 qèá9xsTWä g¿ô¸¦r¥…{¬RNEñI;®ce³gï˜ßÈ=·_¼×/2¬®PúHÊË«"Ïq(IÝ· Þs‰n½ÊÕn뵨¡¡)•‡ÉЦ}¾Ö>oÌ`§dAý””·f¢áž×cyVzÁERhÂv›˜´ÍDÕQ(è·Ÿ`MIBÐJd(ï^9dy¥v†e{¸IhèÓä×[çfë+ænX|üämзÓL †©KjFf\b½J PxÇ«¹#ó&ñyzD÷ÚŒëwàýNÀºV°óR‰ñ‚O¯ÂÌ1ö ZëûøŠÿ[öt§³*Õƒ•”y°r;àægá×´<ª»Dö_ú²­¿…湡¹[{›»¹+$ºcšý<ˆiMj®h ãÖËÂ9·hù^9äMˆ jØvÁ^#Ç;ð{ó OCɪmtÕ“Īä9Pqœ†XçÜm¢Äü3ƒ6ª &±’K§ðx_س{XBà{{ðñ’¹žÓÇ lÖ8Õù1ã¶êZlVßÙ•UÑ•UoWV¯¥¾â«Ð™H.?ÑÎŽôM! Dù£•§E”[e .ÍÊÀ•´y¥a]Ø—›¥Ïy‹ùä-м1q´Ò  oqPæ „bë‘Ü‚ î^òÂXbE¹h vb ÛÀ Çæ~­ýXÌ©ie“(äø«\³ÓÖ÷Þ_Ã;·q™ðþ2²mtEÊ&4^k§ñÚA¶.ÏYaÇãâÙQ\PããçQÐÔ)ŠAO2Цr”4±ˆœo}soÐÒÎAQ}÷Û8Õ¶1¦…«»¶5pÄX2áŠõ5rbíöÁ5F>ÞøÀ5hyü…5”àn¬h^!ÝJöជÂ7_ «<ۣˊLF^·ˆõs‹Xb¥¶jFx -ûx×ÄQr¼CF8¢H{{ ­lŽžÊ0µ=ËÌÑ?‚œ¯ÄAO/Q W!¸¿ò`|ªª÷*h{n’ÔßÔ-À_O¶ÅsÙeoò‚€“>¿žy iÙ#ÊÀ& -Ê-÷v&7‚«¬•¯¸§žûpÂXiä¶äQæ";ôêm§kCy0UH¾9p{Ä+šM$$£Ç:pkä˜TU¡ä«ïl#ô±EÀHÑ×1 {ò›+0îÉÝ‘9ÊÄ•ÞH¨³DÜsÁ½]?ømD1î°ëUŸŠá©è™9”@ •¿Ì;yo^Ê› *Š|Ì£íýTé¡ÙžµO´7ý ’PÁ<ÕbÎ^ ˆ¡òÐmõG~,xwÜÈ*5CÆstSh˜U; M2.öí…/[ Æö„€–»›¼‡âÙN÷fvô¨íêf\yÌÐ ÷+YýFÖ4c rسIx[‹T ÕŠ$ò-\jq"-³îºÌbò˜Ê*‘Û©DNj}x±³Z^HíöBÁÈ0Ž-À%»Ý7Üáë#oÏF63Ó+Z@‰—,‚_W+1må÷©ÊÑ©®—vˆoKqǘÞ;ÆZmI±§äåãµ]žpÈéæ|öª’ZP>uÆÞÿ®dJ’ÍGp¤œË ƒw4<™Å‹·ßn,Ù'Ú+/åéëÚ¢?„ _)S°`Ýe͆ÐÍãkÔNÚjãn‘ñ\¨é xç‡×µö(~5|­lERQ†Rõ*Jž {6ýï ó'n˜$êm mxGüZn :ªÆå»Q\ÑZrN¼(‘ñÒ>Á¶<”¶ïìb<¿™¿J2¬Ÿ£!,^V–L±Ä}?i=—Xùwž¥¸XjÔ’¦v ÌY,}$F«7ztŠzSPBa`\Þ߇¬ZڞȖyèì›rÜ”€á®•÷R¤7ªûøaà%ÙàäÞ<ÚÐ+®ílÐ µÆ‘YÛvëtq],$h¸­õëgÐ2Ä4WE›³È±]F"6`E;DôzDô‘xy¹aIÅ¢tPOé 0*jÙ}ÕkMÌüYm>"¯ðPEÎu^‰7o£ab{Ãl¸údƒ–ÒÇ´óTaÒ’vï0°‹9έ4ÓÝDæ3+sÈ®lxƒ”ÐÚåbÒˆ6Œ`ÛÞµÑRfß&¶.ºÈ^!š·ðqO1c{¯+èÛ¯ÈZZتÄöUÇîºú'37Ëøqº]”ÉÝΪ,(TExf$;œ<"ú…DùËÿ[krtimereg/data/mela.pop.txt.gz0000644000176200001440000002150114666545364015534 0ustar liggesusers‹Ë®,¹nDçý…ž»ïÇç\À Ã#×mÀŸïJI 1B±ëîÁytïuª2)Š RÌÔŸÿùï¾^¯?ÿç¯ÿ«þýþÝþö_ÿÿëïÿýŸò×üÇ_åÏþãï¿þücþüõù5¥?ëùË{šïóP~½§ýÜ×miÿ}Ü\æóþc1Ÿ´·Oš®iðüZ¸ØñóçÏ5.ej?¿×ÀóÃ-€¹]ë´^žnïs¹ÎãŒo<–ÎËüÇš.!®õª_õ|Ð _ëU¿jž·õøãD¾Ú«~Ǽ¬Ÿ«‘/÷Z+±.×Ö‰z½ócÙílßzm•ÜÎùú£Ã0í펶óèD¾âãhÄþåªßëuOÛ ëœ<÷óמ>czÛ~ÌÇÿ|‹!ۯχæÂ®£]úúdÊúuó±äϨ¶ë4¯0Cõ Ïu}†íušqÛÖv=ëvw"Û¶ñÜ\õ󾂾G\ÁÖL:mÓçÛ.woõîçû˜ÖNÔÉq-çzŸk\9‘·ù¬³}_—½ùÊÏ6öû¹·;ý4\îl£qKÈãê Nç²Ïh÷Ü{£/ø÷tÍÛçræÉØzûLÇ™|Éóȵ$$_óÜîû3iç„䫞#pÌ÷©—}\Û'ì†?ÎËsMt-Ö€ÐÈÉ—½ÅmÛ•|Ù[ÜÙvfäùq\îw¶/kBžïïó™hkxÏ´yyåYù1ï|Ïg°{Lõ¹Üb8!¹[³Âz>î„ü­Ya[¦ŒÃµ/ÚÎ}KH¶û5lvl Ï@²gƒx~z|BÒñ,D/çâóf<`ãÞGBê¼½?«Ä'dÇÍÆ0?Ÿµ§Ï˜ÞËÃ-WØülf9Êø¸PŽ÷ñ™DÐ ij¨Ì9b ‘¿… þü÷_ÿ6åïÈÖ—›Êx‘}ƒ8q´Ï.w4Ù9ããŸÿž¬ ¹âóŸÿ^€ä‹}~|¿Kø\â’æ•PúC¨¬G™‘.ö‡DÙ>+!5ø_ûÇÏ7 g»Ãmöì¢ÿ—¿#äð@—½”½ÒŸE·LÛ¢ðŽå|>Í-[˜t™–„Ðò5¹EB®É-?\K ¸×½?j!ÐpÙåþL‘ezå°´O%:Ç0ìqq׳|/Nmž Yîç›PXj׿®{.ùÇKÜ€Ð,¡à„Â7 –(¸©qi‚C”‚Ü’ã7<¸}ÚºÍgBȃÉÉP„ '_òqóÓ+97ºùækÛuÎ ¡›_âæ÷|-õæïgéZ¶1Û¯ëãs‹SÜGCž˜šºù6¬Ë~ì ¡›ßÃæDPŽÐFu-6ÑýÓ#&ÃáV’5¼ÿ#×’/zÅ rÜ É½B]ÉW½FÔ^æ%!yÄÖÛK™]4-Qæ,ÉèöÜYVøš¬}TáçÎ:ãòµù“d¦†·ã,+iû7‘»ÍŸ˜þG[Wk’:Cæ$Ct¦~çt|BVä&l×r¾LH¥ðÕŠ©1‚ëte†‚j\úúX´3UãÒ×›>‡a\s3{0yÞí1zÛvg¦M¼sƒ%c»Êwºu šùÉš“mPûVUE'²¬÷Ûš™l#†OÉ÷¿`ßæÌäû_HGu& ”.ñøj²B¶û;3Y¢,§ÿ®²$N=ÿw×Û*?ž¡9aä©ò¼{uU¦ÁR5'Â,þ„Ãú :¶œôw†Â*¥û¡¸š«@‰¡Èš @‰¡e¥ÝàRbjgj”*™ÜcÈŠºÚfX5hIè Ý_^:B·—…ŽÎ—R{X(/ºž¼PÂÓML^(û½OsfòBÙ%ì|eæùùõÞ¦’ª W‡Ø µ“j''9ÔNNr¨œèP;9Ñ¡vr¢CíäDÇOöÉ¢w^3Bšâv>È„Å΃ΟO2bó{¹¯1# ^Š õóSñæð“ÖïªløòùÎ ÉJ„yË ËÅ Kºœ:×wÊêºz|ŠõNôÒ{aj=3C,k½3“/}Æw•À²eFq›ªèÉÊeôÎdå:zg¨lG…ôÎPÝŽ*è!U,C «b[±|Ëô^·§>òà ‡µó¨ÈʆVG^ù¶¿ÞTâÜáö"Ã7§•$eÙœV’”esZ‰2–Í)%Yï6–JK©¸#ÆN`‹±œTâÚ_gò•ÃÕž®T²ÇŒº÷ŒÐÐÅNè´ÓÇÐÐÑIgª°ÙYØDz´\åÊp£éÄX…^ÓìÍ 7Ú—NŒSèó2Ý™q }þh´Ìd×äãÎä€!é#˜0$}“†¤`j©‡P.,§‘›’.œ”5ÁéH] œŽäÍ¢ÎPÕ"íu‚j=:¯™¡š¢s–ÁPÍâvßDâ!\qæûfõÀB¼Û¯:¥x§š|ØKª0kò͉huK'¢Õ-ˆV·t"ZÝÒ‰huK'¢Õˆ–ªÆæD´T36Ñ'eͼ R5¼ÝZ i»3´ÒFvg~ÞÉîL] ¸ÔÏ[Úu±Ü›«J‰àÞ\UJ÷æªR"¸7W•bÁ½qQj%å˺{Ïw…¥n‚EïÌÐRÇÚ ­u¬ÀÐbÇ¢ -vaíý¢k&Ö>ʨ©:e'F?®ò•N@s³BgÈa¦ã^3C&31dV`Ȥ,€HYÉÓ\”˜<ÍEY€©ÓüØæÏçÿXYìNôJŽ †¦ ç¸{¶4¦ O904UxÊ¡©ÂS åÊ<åÀP®LS¥Ê<ÕP˜«–¬Õ§ð·ð¥šèî¶ÎH;¾É–”Zäî´³Ô"w§ž¥¹gõŒR8Õ"4 5燔RänûÿÂU‚ù¢@Á|Q `¾(P0_(˜SQj-,/ù»SØ%Ž­#{÷¬ô)%¦|¢xÙ‹‡&˜µŒ¡Ó˜R Sþý{¦6!©ˆïVü°hÙ­øaѲ[ñâe·â‡EËîĈ–=‹Ÿýý­¹©nË^nïM ÅüÔ᛺½vYáÈ®¨§ŽìŠzêȹ¨÷¹½Ò¹Œ”Gúšeÿ…fÙ¡Yö_h–ý_k–=kÄa ØÂzõ0¬ÛR¯‡¥2&gÜwÔÊ:¸ó(™°Ø¹´JW—+0õ U·Æ„í †Æ„í †Æ„í Æv`{±ÅÞ@ZÈ{šNØ‹í~ÄU结I †¬ö9mùçX°xò‚¡‹300¨ñª3íþ¸á‡:°êdÔû“}|0ùþd eñ\CYüé¿‹²ø\AY<ÅÀ°™ÀÜ™y~~¾WªEË&Çáú¢Dt‚¡°Ê¢ Ii›`HJsÓ˜ÖøÇåJnþ9¬(v¢D=؉õ`'JÔƒ(Q΢ä'Ï †ò}–’`(ßg) &GM‘’`(jŠ–ìF,–ž>éw*V²¨<œ’’TïpZJr¼#k)u¨é, Œs¨¦ À´™2£‘68¬$c™udI¦b²vqå£ÚíÄUZ›W=ª½˜qÕ£ÚŒÙW=ªÝ˜qÕ£ÚŽÙ™¶KÉ´Ÿ®Yšêˆ hÝœ‚˜‰¡u3âW[7Ï×hI)"‚±›ÙµvÆnf×ý|0~3»ì·ñ›ÙǪ¡r#"®¡r'b7b±3$ 7!vªL9êÂØ¥!3Qõ·÷ÉK¡Çª/Ø-vQ=v‹]TÝbgÕcwØYõ8-®jÇm°‹ÊCj•U&R«,2Á´:+×*EcÚç²d=°OfÉz`ŸÍ’õ ëþõ½•xp?¼.”¡3XÜ 0;ªÿ²ë¡ú/{˜¦ ø€£µØâ¤½ý) m`(ŽGŽWÚÀ¸bEkh;³Íhhó¥¡ ŒÛ.«ë ·[V× n³¬­+`ÜfY[WÀ´çbà)…åõåt:[f˜lm™Yg x Ï,0ä)<£ÀP4àžk0 ¸ EîCÑ€ûÀPîÊý`(ÚKQ¿±XÚ*L]Ëú¢h/…ýN•¿@_qi¿S¥è…ÅÅýN™mÅš¯SEí弄òs¤_¾rÉä®åeF¦úf{­Ighddô0åòÈÈèåŸcddô‚¡‘‘Ñ ¦-Œx‰Å_h0_´˜/ÚÌíæ‹öSïo:ïm_ͶñkèrºFªÒ—Ó5Ò–p9]#m —Ó5²«v9]#»ÉñSh’2t[‹Oï#;µæ³•›êVnªSX¹©Þ`妬j€\Ok¬j€\Sk¬j€\[k¬j€\ck¬j€\gk¬j€š^+õWHYÕì1ƒ_¸Òðà®6<¸…ÛŽ¼ÁíÇk&i4Pé(gô÷5—O 9»m{i,êP6uu$BZ‹:DýGÜ[Ô!j@Ú¸"ê@âî¢Q ÒùÃ×QRî/êµ qY´CüdÇêfK{˫ˤD:Ó1ðSA›)HˆÔK\\K‘z‘$©IQ¦ I Ê$ Ôúg*_K2àÊPS8á>˜Â ÷ÁN¸¦pÂ}0…îƒ)X¸ù5?ƒ%\iYå£?ØBä#m¡kKÈG@nm ùÈ­-¡¹µ%Be~`ë“Á´=ËÒqv €´•u(BúÊ:” !eúÒYÖ¡&é\*î0›gWcŽç8¯‹™|ùñøæ½ŸAtùÕ#êÙd¢Ë¯ÑÎ'KuÆUhG”%(ã`wWjìžkÍçû ã‰ÔþK6–3YÑr&ë ZÐh]BË™¬ €HñN€n‚hKV@´‹%Y ÚÆ’,ícIˆ4Iº-Ë_eHѱòò I!:VÜyyó 9—°§¾¨b²ç¾¨b²'¿è:kÏ~ÑÅÅžþ¢‹‹=ÿE:«£,.€¨Ž&‹ ª£Éâ¨ê烜ÑÕo6Ï–®Íe.õ¹Ìe¸6—¹üxM®g)*U€\ÓRTª¹®¥¨TrmK­RÕ_Ÿ ¯  ß·Ô2¼nÌbr¬è’ãu¬þö^žç]~xÎaö‡çðúéOÏ‘²;Ÿ³¼oN¾¤ü¾¸Œc˜G.ãæ‘Ë9†yärŽÁW]Î1øªË9_u9Çà«.ç|Õeƒ¯Ú¬cpVÍ:ö\¬R¯ÍIÇÔêr½µXb%·dÉ‹“Üš%/Nrk–¼8É=Ä|'¹‡˜ï$÷ó]ãÈà«®sdðU×:2ø*÷Ž,$lŸµÝ#íÛË:DÒ°}R{«C‡²å¥¥CÔ„Á(¢. îDéÐóÿ÷x|Ø[Rf{ÌÐ0é\£É0é\§É0é\«É0é\¯É0ç\³‰N5n6¹èÉ¥a¡pEðÁa]|pXWÖÁ‡å"øM羪ÃúSwduðÇîÈæ¬=xG7eéè8¬Ì@ä°2?U‡íoÞ,°Ì“Õ©RUÍ€ò]ªf^3ðSÑЗ¢;˜/Ew0ߊÝ}+ºª}¼+µšéòS³IÕ©}S kö¬Ÿ oŠÐ7ÅЫ,ŽÃ uÄV§ÆtƒqurL7×,Ç´{&6¹ö™¨úÚ>Ó*E«vÃXa§#`…Ž€v:Vة孰“åk‹‹åë‹‹åkŒ‹å ;^?º1‹ÉSÃæmåèXùm¨ôµ£cÅÁ~ÚGêXÙgX«W,)†=›j°š«`V³lµZ®`¯òfU5ÞñçÛú"ý¤!? ZŽDÙ“¥TÑÑRXŽD¢6VnÏíP“Qc,,—éªé}÷Èw—Í?{ Ó0£~#ÈìALƒoüFÙ£˜ßø… ³g1 Ó) Ú´ÔÉ„ å+åþ:•Š^qzRP§’«Ë# "ýÇÏ(tÈ–»ö6:¹¼¦wr;óÓ ó–¯ aHv]Ñ\jÆmíࢹԌÛúÁ;Ds©·5„w¨®]ÏI‰ýˆ*é Ÿ±?šo@W@äÕ²âløi­ô­¢Õ÷l_?W´…6¥·LÈ<±g!©çÚÃÔsíiHê±ö8$'ö<$m&°"i3ˆ¤¢ÑLÈuˆF3 ×! wÎ…»ûãJå±ïð¯éÅní:†±túŽuö&‰ut ß®;b 2¼zLn8€áÕc"ëÇD†W ˆ+¦ê20f1¹¼zð«]uÖZíª³ÖjWi«]u¤­vÕ‘¶ÚUFÚI×a¤tF:K×OÚ¶> ?,q§ýt+Êžo¥[Qö€+Í©í WšSÛ#®4§¦3®ö7š¹ Ë©õæÊŸÃJäÊŸÃ äÊŸòpR‡œˆlO%uȉÈöÎÈÕ{ä—YÊK#ç-—§w}ÍI?šH¤§?c(Ü­>ß:ûC†"¬¸Îþ”¡X•×v»nË]éœ!”„ÃÍÖ¯©Úd¡×È£ófþ’¦áÍÉ1Íé7'Ç4§ß²Óˆ9= Ò#§Tïr{TÑ4ˆ–ÓÛS‰4*Øc‰4Øs‰4þÛƒ‰4þÛ“‰4üÛ£‰4êÓÙD?)@ß ë+`å`Ï9Ò–{Б¶ÔØ“Ž´¥Æu$-5ö¨#Ù ´géV =íH‹¼tÜÑ)ðh±×že¤ûBö0#ݲ§é¾=ÎHËìö<#­HÒFûûæêßp Pöœ¡Áqœ@T©éO’ Ê5$ë–?kHÖ-9mhyÖ‘ ¯_z{ýK×OÔßOÔçOÔÏÞŸ ŸÝ?A_ü?Q_&@¢(¨°ç'ªF•£æ°2îm¿ãC;½%*Qd[v´D‘±§%Êm±4WK”Ûci¾–(ªj±³%*[wô²Ü4Ö™”¨œlˆNJTÛ“-§f¡ô¡]QQÞmŸ(½ ¨)R½+¨ƒ)’½¡lêKKEº z_™¢64HèãfŠúР¡/¡¨-âh}yi¢¨-i}}i¢Zsÿ\Îüj´(Ëm{_‡c›_‡c»_‡cÛ_5ÆØöW1¼7~Ó/c¬±O·ÅØß;C.kmÀ%Ê¥­MÎ&Êå­MÏ&Ê%®MÐ&Êe®MÑ&Êå®MÒ&Ê&¯÷"ŸUÃéÍœ b÷ÛÛ7·ÑDù«oæÍççKÏ»5QeW½òGá†#ÆÕ×n$Šnøµ0E7ÌX'*û=a˜ìqòˆu¢¨n=º™¢ºuD©y (ª[G©OY'ª–Oj.’—í4¼´¦$*ÛVzS•mË]) ¢MÉpét(‡°Zd j¾¹ãÙÎBk†q9Å:ì¼€Êw:ì¼\yb-oz§â°ñb×*˜ö€-ØùvÂ.Q°£3vÖ÷–_â0$™öpœñêl™^ÓŽãÕ9íøóe}­¯ÚSr†Üמ“3ä¾—ÓŽCÎ{eíxUq†=eiâøÐNâÔ™ˆž(*‡µ!¨'¡'(·½Jã ö™©lÜö.éš7¹¬¶}NC¶—j|F5¾Ù>³ÀýW‰r·Z›þäî´½4$QæVã­!‰2·¯ ITö#yoH¢êƒ 3Uàå":?»€‰Å-™‰¢‰Å=™‰"¥ÄM™‰"¥4Lå ª2ç㋆)í´Æ°½9­1T}/§5†zé•Õd­“‚¢z®V}AÑÆ½V}AÑÆ½–ì@ÑÆýàß¼7—ê®OýÜmã µ{¾ÐP°' þŒ!ídð§ i'3ôlãåÇxtY½ó-ÆŸC T¾Õ¡„ŠnUÍêk¨V."á=˜ïÎ×…)-É šÑ"€Ñ„Vá{ç»Ä„Öd %©šlr»®CÒuǵ¹ñB«(7^hUÅÒ\âjÿjˆ%öhœ¡aÇŠöxœ¡ø@äÀÊSPmùU=å¤ú¡*tgU5E!tH|xh"{æÌà3y' #7øLPäYƒÏì/ãYƒÏõµ[‚Ÿùx–]P¨ÓA.SëîÞѨ?„»K¤5{ÉP󱇑 5{ÉPó¡Ip³áQóE•!­ù€¢Ê†Wn\$W.y(ztû¼¤ê{TŠê{VÊèæî‰ÉAúÓy)Û{_òÛ‡ÀŸt2øû/ºÝõµ åÏ;ü<7¼oIO®6ËDaj™òÕã.$ªtŠî"Ü©Uš;Ew!uæNÑ]Hy¹Säæ"b;En."¶SN>«˜]&·ÖêdíYdŠo¾W¦È"2Y;E‘ÉÚ)²OÖ‘Ax²vˆ¦½LÒNѼÿîT}¢ q~~¾L®2޽+…ŒcŸ­¯ëMû ÜzÓÇ<¨:gø¥3˜–É*…¯¶íÕ)ZdÛ«S´4ȶW§¾m{uêÛ¶W§¾m{uêÛ¶W§jwÐ:åW«©ÞY¦¬M~}[ñFß•|ÆÑw%Ÿqô]Égõ\òÙ?:ìyDH£p[–ú9‡ä"ðÚݱaXíîØ0¬vwlVÞÛée4¼ÿ~é|éÂtimereg/data/melanoma.txt.gz0000644000176200001440000000363314666545364015620 0ustar liggesusers‹MXKŽ%7Ü÷)ïâGyÃ6àÁ Æ ·Ïí‡T¾ÌMUwHI)ø Õç¿~®Ï_?ùù÷_õß~ù~ýýŸ_ëçÏ?þõ뿱úû?Ÿù\;ò²KÆ%×Úë’ý\b…ٸƵ& û\¹/½l$æÀ¼¶­Ú–Y˜fmþñ™ŸK¥,ILüÔع>—¯,@G}yyðûý¹·)ŸÂãnÌ”‚²Ž/Àlª8LFÁ‹ºa}».Rsà„y—$\´–ÀˆM^n-f4‹?7Á¢¦føV×sa)v.0|Øx_£èír“]žÆKO2‘"¸7ÈLÅöƒpàð6=µGo.Škå^'o-†!Ö$Ãm„‹aŒŸˆ•ë"ŠÀÚæ%µÃ¤ÅбmO=ÞZÛ"~úè­E0÷’Éá­ H‡†”Êý<­èE‘º(¦,r>pµ ÿ´>œŸºP ó­èñª±’(mX±CPc×9H;`EÍ@þJRö # ܈Òϲ”hqó„Ý œ¹¼í;á¶D¹Ä]oE/à«Z`fœKã—Ä—žìÀþâ8½ñý¸7p„ ‰ X'eÇ‹å2V…*£]?ò=WçmûÁU;ý·ûÀI–¸ íN@/¾s£ˆ]Q†Ø'’‡ç:ë–F G9Ñú³vïýEÎýs0í§/¾µC3XÆÜtеE\Ð)$yÍ9˜œ„À®³YdY,sº¸lLÔ$zˆLí†ÁR`º‚6üe£xî´âA˜ü'k}ä¼D=5nˆF™;Úü²oBÏ@<¸»ò~”ïxÅ¢iIãk°ûUo¬Ý«hš¯Î:9ý 8¢Z‡bG£/¹ŠjdãÈ‹º1£½ YÃh,¦e'ÇB¯õÀÁÞ¶ŠªµwW» ©®¢šgûÔ^TqaâÞåë Z5ÿ…oRh´IukAÏ*|ÙíôØÚ¯c7J5ÛzÐ嬜]\'ë_VŽãtüâ›f6SF•>Û%òÀ{vk–ÍÓ`ƒh;`û«X7’7èÞ ‡mæ.ùw)ŸZ݈ªn⨺ã—(ž:nGÓxfãiOªxnzÞüº%0T:¦!÷À‚yGÐNTåÔþI·Ç„{ÛŽåËȹñoƒ‹œ¤ÛÑwåα Dk|ubc{âš‚2‹5ž¾žhLª±^×OÔª7ÎÑ®Ïb‹Pœ‚í6½4ÜÆ¿û8Ì;`Ïå³È®œï§$Ú0§Œ¤½œœEV7o“þD6!èÊdÓÆhŒIÓµtAß]"»ÞÑ+Ò³ +ì'£d _nºm°OÊ(Âè`GXÞûÁ—*©ð'§j¨à€Aœíø+_8xzAýi5VÐÐf/Ä3ydÆ`m\8$$H¿O%T¬gfãù$¢@#mªKN%r¹5Õ` „’3µ§Þ ›´Xrˆ³Á°fÀV…ýåÉÓb¸±Ø)ûìÛfji±– ÷'pKj«÷3;ö¹zU³ô8ì|ˆ¦ÅÔКXÏ… š¶ü•MÛ7ÁÖk®–{PNŠ*S,ƒÕ'S;í^è?ÇÀÝóÆ¿*N  œwTjûï 4”9èò£k¸ÕÞ0Ë×]QÊíUcÜNŽÙ¸Ó^™+÷4Š)§» »‚Ê…|P©µ€JªIK¿ã«‰¡ªÎìÇ·»!«fg±›|‡µ@VI»Ï9}O™@VMa†9gÌí êªNnOfŒwàZXe/´.í,†²š<ýøE±–<_<’E ¸ŒÝÁ„CïDt‘3ïÔêýŽ($—ëYÈ—û ¹ M°@±twJ¨®5û‹¼'¿@ûf¿7ÓW‘Bvá© ÜFç+q¼pù4³÷(¼X¼…?ÊV ¼¶yãþþ ñÄá ÝÍÚ«õ‘¡mD™pÔ¹RëÜû1·¨Ýä~rq!ï¹õ®-)„k½ßÚýQÈ2c›sç‹äü¡D!Ë6ÛV½âT6¿ÀëbðˆO'Uê²Æ“í LrXš“ƒ¿gàÿùq&Ž>timereg/data/mypbc.txt.gz0000644000176200001440000003202214666545364015133 0ustar liggesusers‹]Y²GrüŸS´ám¹/Ÿºï@i M„H›¡Ìt|¹{DÖ’Ý@Ã8ƒåá½ì¬ÌX=<¢¾üö÷//ýöí+~û×_¿þõ¿ÿâßÿù~ýõ¿ôůÿÇ?ÿë?~ûë+ÿí_ÿüõ¯?øþö÷¯ÿä—¾þýë·_ñû¿ÿöûoøí?þñÇïü‘ßÿý¿ýö?üÂþùõŸúÒ?ÿüÇÿÒ‚éƒ~û/üöçï¿þõõ÷¯üÊŸÿüãÜ 6ð·/ñË#>J„ßëxöVSšiÖry|ùOþ³ÿWžõ‘Z|¤g{ÄŠÿ÷81÷ç¬ø3~~†GLÏô(û’¾`Á‚Eë¶g)-µÙúÈ!U­´*~}ƾø(ÏXµôÑcÆÆsE;E|bÃQ?Ãxà4SÂíÇRxŠ”#^9®B Ö”mRTë3ÈPÕ¥Þî&RÚ?rÅpŒ”úÒqîº)ŠnŒ Üx¤6aÓ½¥õøØè˜¥ÎÔKé›ÜãÎ!´Ø^ÃóãqŠ}âÀ´÷:\>#t ‚ÌØšó «½‡BÍe;l6Säq¦';#®ŠÏ¥Hñ¸&ô‡—±Œn¾Ô'$(Õ¡CØ|®£èö[y¶Òp÷}ÔÞrÚö‰;ÎÚ'„ò3C˜´$©ã ùDK%¡ŠP#{nÝD¿@–K®9ŽÔk¬åõpü8<¬mÔJž/ ÊùÑ\ú„'ïmÚÓãäG.¹áªzîã¦O‰‹v.i%&þŸ)ò];¦ÕÓ±š\A«dk£Ù(htq”ÊäÍœbE —ÙÃXv Ï©gq“cZ¨„ïáºÐ­ L28ñù¬¸ý^f fàºaìDç€[‡táè°ãÏž\Ž&`úÑ&(WÂA’–À΋Y¹ŸB¥ñ×)P9)\0ºX0Ñ´D~V¢ù“KrÁä‚á•A°Úĉ…’!qný£o—F’¦[ ®´©ü0ü5ÓšF;DG…µz¶“…¼^=à¦\4Ò”/˜Ðã™ÆJ‰†™EËô+A¿x(Íu¶>áúb©}†ZËæW;ÖÍÌô¤ÆVz“Fóõ¤ó€'*UÄñsmèdždšE„_NßÕʬµžç`R†oÀEP'±x´ŠðXԔ˳=i ­@W–A='(m•{zш}áâ>ˆþ¹1 €~䤭f­ -K2Áe)D€o(¡ÕF¹9Wˆ i¢¿jÜÌ«‡ÌãÖ h+Üñ4'˜ hØiw+SžAœb9»™‡ÏN¼”Ø)·T ÊP›¡¶¾…É oðÙŒCg@D}m¤Gȇˆhn©L7w‰Ý¶Y|Ä^jÛ­)ÎvÑ­ ï ÀZMýuNû-зÂè¬Z›ébJ™ ¢0c¿ë[³°)Sm'ýâX2S©Ž¢@Õ MX5Uãªcv·tZ•Æ&m@);ðpürYG[ fð¥¥BuÄZn)IØ€¦V³P&kÉáIgËø1~ ù°Â4 ßUúp³ýY‘dô¥˜-•[ŒCIHSéRUTi`ø1“VÓNúP j…qk²°¶¬ÃÚLœT…?ÜC]{Ü'£j޳ûM–^, ãn¡dÙ¡ˆÍ|pÅ¢§Aßc\ V ³Œ°¦Lê”R4l™J‘|¿P5ZÄ·¶_x*³ £¤Û~áÕÇ>± ÜRrÜÿè<F*ØÞ´Ð´@Ópå¥,Ï4¢¥0BG¤G³ðízqS©IöÈ?ÂæSì"£~.‘he(Ý2RÜzM-ã™ú¤¶éšË.Žƒ‚'ÆÞ)º •8CϨ Ü–Ç»†À,ô0Çæ#"‹2Ñ(™1Ðv[8B‹›Æ¡¿jVéÖj>Â\Z¤AÅ£½É&„Pp±2¬Ñ„€Y~îÆ\¢[¡g¸Oø/†Š[)'.ÑnGÛp@æ èÀðX…Q¥\%d7bËF, M“¡ f 6% ¨ÌÚì³nÙ„ ndÚ× ÙS}ý²xP3jxÉ–PeˆÁì#À4ÂMzÀ{Ä7ÊЇ¾qÖ`Äc‘H$`Ru vP›oBßà‹+ ꤆ÞÅ ‚(©ÊéÚ³^‰!j\É…¢ÑÙ/GIf~ &oÖx³aD>/æû¿ÆDgÖg¡;ƒ<·zÞôŒbCÓ¿„¬_$wË}Ï¢)b°,aB¢5ƒmg˜†'IÔ=~ ÷ u«T·:ÍL"H¿ßz;y "pePf¿<ºKfÄK& k•Ž-Ùõ!m} |ψŽUFRúÙRRj QKŠõòWkP9<]á CŽ­,sS‰o.’‹AWáF’™©[ÖšP·FĦº%ýÌÑî%©ÝvM(™`ŽàÁ&¦Œ‰±Hæ 4(#Â0-ÌÃ÷\ÜOˆx³|0ñ˜VËÕun;2º£ÏȆW6(<=ADÅcŒCu·?WÚéÖx´8Ç eeÔ„U ˆ5[`ª€õ²,ºAžô™b&¿È QúÌ%oJ…{ñÆè 3 X“l‡@³kZÑ mø<§çíÄé S>s÷Âøàj† þ¦3°dHqƒK&Æ“%²;©|Ó¢Dès¨©3Èûvµº0‰©›!ãR3È]òˆ3¥¥À jÖˆt,L„a9”wtý%` t˜™– 9i(…øÌ «B½p+…¹ˆA“Ï"æ»§Sл„hAþ%¯ôà+á¢P®ÆÀ¡;ÔHk?`C.¸´bK‹c.„ØeRQMf Ó÷Ãt¨:†ˆãò:Œj,3Å•Ñ&Ô¥it@„iÉ/¬C¿pÖ¸0×/„b°7G6µ¹É$L‘VΰQeTåÎKˆÙ¡aqžAa#ž(RdÊyO Ñ‹©Ó|?œ’êÆ:¬Š™ÁVXŸ××Cïû àè¤`L܉Oñ2= R^;T‹ñÓHä#jIgnvÏðiJn˜m uF †”h„"õ‰whSøC LY K{"“ÖU @œkI¾0([ “©<¶{ZîðRh`!¶ÝÀlf"‰'‰â•‹áºDñ©'†·á¤Önk 2ÞfÂt r-PŒt•¥ á‡ÈaahŸ¦MWdZHÜKš;ïeKKhZ©»x–NÔ…îKËØNùLÕ;Å\üÃó¨B¡Ñsî嵊‘¦ed|rfÖZUÒYP2ÜìXžñRç¨ì<1ú˜,KO®Vð…–­¾“uûYòÙŠö¡Ò4ëf*¥©ÐX™æ#Ôa°0³q¤x-­]à÷ ;ÝŽË=°†FAÎÂÒ‡X­ÔÈ1$HN+˜Uî/Y M Š1}+%0ô$òÑ×ݱXM0Þváa:Ò@Þß{ û²¼ú®àƒ(UhÉb}ˆDtnu£X«f¬NBK0¾yv'˜¼¤%Qơю>X£poF­ê'ðʼnºZc!3¹8ˆXîñ5c4Ëw×C‘˜•3RˆÆ¡E©öãå=4jÿU%ý*ª6KP™N|š3Zˆ¢„Ðdzî棸Kß }øênÚ=æVzñhµðaìj\Úa¥( wõè³…|[´©Ä%$³HUgŸK3h½Rk§Ò‰BØSenC^/µ¹|cn™k1†Î’Š ÒIð“ð”ÊO‚JG†ì˜IWž'Äp«àëü°×¢²«SCU'´åÐO­C„€éüñŸ0=¶½öÞ.Úa! k"ø]ÑùX(4®Vf¬ÚuK$v‹±h@ÀyÛA“¼ÜÑKœ¸¾%VøÞ|`°Q4‘(΢zä '9!'uÔ{$Mc-™ÅŠF?È|ÓRYy$m˜ª‡CÌøpŽ\º0¦ævưèÊE4™F;3J,IT­K¦µQ¶ºN…‚DˆŽ-7±XQ©X´SÄTQR)÷JC"WDÀòŒ+4 ÚI 7’RÖ~T-椄ME;H“¨XB-s¥Þôžv/ÚM‚å*hÞpJ w¨3Ù"D̦C~\¤° v­}Õeß ±‘æÆó|:L¼ø‘,¼x쇮ǀfÇô[0åt™(¯‘—âû»ùÏ®(P '­K…#ôOT4Z¶vH6Ò •I¨n†«°Àáä9”üÙÂÔ7ÆÛm¿òâÅå;šÕ¦!°|ðBÃkTîëj|È‘‡P-Çá„Ä4gÜ©UFP¼°ÀbÔ¢¨#gD–ˆ,Ù²ËB4g"è-@×·ºD³P7@²t°~Éü’›OÙh†Ú-u¨}rh³Ñ‡9ï"ÄpdzL 4dl7GNwZf$S„ ëkA{Cú2k_dSÊRs8 Ia¼™Ì³ á=ù‹/™WæLm±®Òkå~ù,t–‡LÞ÷Û0Wty”*Òh[aÁOäØãÈÅü,4ŒA ‰N0Œ$ްrÞG[(2ƒ?³—³±[/èÉ™RÙ²Œ5E\3+b#Â(GM?^:ëõHQnÔÚvrœš’®A Í2wIJêq¼T8†×Ó‰µù]XכȒŒˆK£í—®5pD$w„W)ìØy9ã´>=\ïMðlr΄ªW¸î5[‘ˆ^b®…©rE*gEÜ^‘ÚBrëhtï:ç [y?Ó;>HCt¯‹>Ëú=b¸Eò:"LzÅN~b>d™ˆDXS_2_‘µW•«^çQ.ω²6Õ,~Æ$ä™(;'a?™{Á–§:®ªuˆÍȚݓ™¡3$é}’·DMðË£ç¼\Å‘nAcÂýàtÄÞ`6°‚å+Ú­ê&%‹ÙÛ>‰~¥t 3»H¨n~!³{…QSeË•ˆ“lÂÆíTœî[!LNASqõVÕÔwÑ?|&5.˜"ß„¬A/ü =!!õ€:nþ"­¶B>Å V Ld$úYg'ãÄz+ÛBà<ÛùÜçT¬Â—ûb§Y§á5,»« XÝ‘vB1aÀ»\g¿Â/0n6öͤ§'Y£èGÁÈ Óáw2OØ%×çÑ`­šª·7m°¥Ø‰ÊSEÀ­…Q;ãCö½˜ŠGòu)gýZ¾N[ Ah$«HÇÙ´e78iº>“|ÂÀĤ_ øc´Qq¶¢T'ü§Bõ‰Í²lXmV­T—÷D“~Ânܘí²¬gTšÅ¨äa{ðnþ¬Æ-´Ž$”Èã]\xœÃ»¦´Köb”e6í0Û: ‰àýzË´‘‰"âX®–¾H§qwÓA„H‰9¢°0±0Ó"n3vœmùËT÷´.FÇɽ=1H±·´ˆ`k2c¡>¤)²l §FÄHÖË­fîÀŽãäô<›Y¬¿nY­ 6~ "“E)µ!*§£…—”4Ø úx¶“Õð¢"Í{Ï“ZŠYL[MÇ}µHG))‰gŸºÛ·ølWºõ«oJ+¸b¢8•ŽÏâ‰x"#…dñ”<‹ÁC½m5>öo“N*0-€íèº&…“ÒÑ΀xâRÇ3‡€žŽ5÷$+†¨6^®íÜ*ÚŒ¸*Á³w¶w‹bzå½yn?’_!NJA>„ÏS}ªeñD2 1Š”<žÀáò Ûÿ&µWRKh DÉ FæV*ë3N¤¢ˆ=ÍtCa`ú¾]sÐDzZ&œò‘†¬¯«gÜšHF!‡`†²ÐÅtá=ÕÍøLÕ'pq¢ÑÆR[–íÜA½ôîìèBF*­ÝëvoÉÂa>q:Œá¥0WB›HFá?ªÁÇs£w}T·!L.^×O—lä{Ê“&Sغš@_7ëÚï*l¤6•8ZWiU뢛ŒR49¦œâ@&Š’Ùx¶+¾cGŸ‰g’?š"ÜÇ òˆV&/?åÃ:‹¢Ñ2ÌdÝÙãrñG›­¬NX+ªÚær úÉVi7½ EÍp« AØ’ Ñ™/^¹X›Sv®y:§þ«ÜÎÝRßd=†ÖབྷõeXµQ}Q3dF «+‡(b<é‰L)Ìötð­'/´ì9’§ Â*¡MDmËèÚ‘p$²P„ã¹åÉ J:óì­«o~‹³Ÿœ÷ãõ.iJÅW“¼Î‹ý% Eåµè(yFðt Há¥TYòÜû ÿ³yKh‘‘3Ä9‘…bÍõÿ| Rƾ7Í7ÝHyâá!æ‰éóÌ{“÷äAh^ 1cº—äwÏ H‘½»8A<Š#Hh¦~èf‚M¬ZŽH~9ib G3X…NÑÚ…±^kù‹ž™UxE‘ð”K›bSKˆ_÷UK#óúh»­ËÈ5[¿fŠÐ—‡•$ñ‘K8ú”’—ÐæÓ^I¾÷5¼Íÿ`ÝïYlL¤#Tù“§h—¶_ª£ñYÌiÀµH2d>M=¢WÒ mM*D§r€Õ¬¥)††–‹RZËŠê$­×j» Ü!;D¼²V9FÕÆCy¨–4¹„~oöq\dx!­{Ž´bˆNaŒ3/j=dJ‡+˜Ó¸óx¬Y‰=Å‚||” r_ä™ìÖØidá§ ÝÒv©r½Ù<²Dd´:Üi_OBå¹\•Òq¾¼ýØ+õL”bd2öÒ*&ñŽÓ+ë”æ—1Ï‹ª:ºJ¥êUiŒ¦Ísìé(œ@Iôò\C6ÐãsdÇÜ­S=K¤)A´„Û23:[>y(Ö›ÛêBòßÑ/ÖªÅ:ÉmcŒ[aš7´b*G. ]—šŽÝÅ Kk‹“.]"}\ô4” «‰Çœ5*ˆãÖ&„£ܼFgµ-”°¨4³óƒ`Gb¡€=ÈE+#ULä¢h$Fw׌#ÎWá²3.JËröƒÙÕ\–ŽÊQ"%YSªÕw2»¢O¨uã3Fk6çLC è0´¢T´€èŽ”|µŠ±‹ÂUú]#òJêªjë*‹ š˜"L—xØ òQ’f²Œ´œh¿¶’oðDSM2%†™+]5o²qW䤨v0ºÅlW„UDgwP,‡,EÚÓ-ñ‰­“€iàs"'…þ6½ÝÙþµ…z Æ’ÁÆHI ÄñP‰ŽÜš8Bh"#EvböpTð÷§4+l#lÏQsÁl–°ôÀƒ¤B‚ƒGíµžŽ8);wÛ1á4Ÿ^‘„Du,¨Mcܹ¤™¤”$î\4Ñ`pz"!?–7SâD§É¬\àÆzV}.r$¦°Š>óÙ7ȶ3ˆ ®iãýˆ­ÑjÑÈBjÑ6úˆºzòÊЦt•Kó$bÜm}ŒâTp»Á‚ Qà’jOÉ'Ú% ê2{A^ ó,E`>ªëZx¯›!jšU¡ ‚Œ}ŽÓè9qqOkOVJb|X²šÓÛ‘K§º@A$'ä°œé­ê<ƒqrâi) RÙ’ë,øËµ…}¸ å–v`<ç@6ãi?ýÀgw‚N"'…8,™ç40‚¬‰÷>`÷ÂÌkÌ1Qé‰h ,ЯªÇc]*k}8c¢#] „„inW§ú”ØŒI¾ªÁ¨rz\rº¥çA’B{sr` ¤ Û1š˜^oNœ8–ç³wЧ`üál}ëÓ¦Òi~ž¾ˆñí“qÞP‚¨øÇém]]ƒâa—àO¤¤ˆ×=ˆolpºÀ`›!Ž’ U8fUã“4Û`•Øî¶Wj[U«­“”Æ>¼íÛ »ö§1\D¡a«ÜäVM*k§I#!%i|l7ù…娗ÜysýÑA¸%#19ÝS•u—…ª±xšíç\­ú¶G÷Ìó Î*­chÅÎýlÁO½`(¤¡ˆÞƒYߌ°èÌÅÓŽ´FªB} ïìc#ŠŒF» (IðRt˜|¼M .R0Ô—©VÇLV Q S:{„ù'EÊ¢™Vo­ã¹Õ¢èD ýq¦ïa6Ð- f&Gæ‰PšÅ€ãˆÈhŽ;*e¯eËUŠab‘¼þ›Ž O"í„̌ؼÑY(¸e/ð¤ P赺%SPM#ÙØÜC½È:Ñè‰æÓRa@/ž±ò%6ÈàZƒP‘ TõÝ0Ç%ÌaE˜DÎ )©ñ 9Á*3ŸÝùCQa_Sû@’¨ƒR~á«R»hY[÷´ rìì]˜Bç”,¸hÅ^Ö€4Îx¬éEå 8‰þ¬½‰¬³ªgÄ€y¶äÙ‹ÃŒÂê­ß‰œ ‡‡IfsêÛxÏD¡*áSk§¨ÀÁÄvè'ê?:T‹z«‘Üä‹*¨5ÿ™yµº21)‚F2ØÉ&Œé£ÏÝìáÍ(—Õ“¨) a„Pb›b¥‘íN!¹w$ÑĪs>qB³ê.­[šE¢|ÖjZ.šnÍàá¦T°÷U©ašj°êÔõ‰>ç¥n´±¶†°Š¢ë!«Y_³b²LĬŽD%ÎK=f“å-:w:¾0>ê­ øe±%]k ¤™¨%¯º_DQÚõ‰;è#lÌkÍ-âV™ÿVË!DM'2@ŽI‰<€C†ï8Ú߸DUZ²MƒåÌMáDÕ˜ ´Z¤—¨³´Vƒ8™í ¤q 4½Cüpˆ¦nŠƒ+»|#k+ì"½$i°t1·õÝ`c¥%Âʧ+K’(ÙLµn«òúI/I]Lôy<¾ç“Å|ï¹×*€Èºžáöƒ”U!¢ÓZ•j%nÉ8Sà3Ž‹/Ôq:‘–j¥–=YLdÀE× ×nÉÜÁ†qÊ;eÙ9ˆ$ôk?°>GCÌT¢‘.Å›³Ùlro¥B"sºK?sPñÀ˜¨àåSÀ¸ «D¡dŸ]Ú~HÚ©*öéTÙýÇa’r²?ã %ü{d.,Å3¯"òÇî^›wÀ±L<­ÃVd`*õ7©"™„õ ŸûÀ¦ %a^Š?jøŸÆERLÄ¡ÀUçAì‡ʧ$2IT (õà­O¨5.Ÿ7”5²Ü&‘‹–›¤ýÚw=„ŠD¤ÙîêSŸJS|ÔÎôTøö`èR’HÄ“/^¶,ãyí°Ü#,öçE [Œœ¤ýÓPÁå]I!IBì=n£³ºò÷ÞPH²'Ä㱇’3ÊÙ#šb[N¼CH`ð™Î7‹š„|)#芺÷ùÙí%ÿ¤Ž¤Ñm>ª‡‚ï¨vWò(J5ÈJ฻U2Iê8S¹¡áÈBN=½0™ç¨Ò[#òi÷s€@`ªØÍþ[™cU°É#´ßÝqQäà׎ñ²M~(k|à”å'C”õ.*”Üt‹Ä‘d=ΖÈA S§ö1…f qÞ2Å)KÍÆy´$PTf0?_œ½‚¿«ðÉ‚ñ&?×F¸ËseÒ@è7çêg¹š\rÛÙü|}J1ì-kþf¶!œTM¡’lYõ'8?—̫ź›Ÿ‡‹e"É6=7íw®ç¡’¹HÝgȰôvÆÉ 5ªx £é²£Šâ«{Ñpu‹QÉJj¢hÆÄŸì¦§Fu¨ç—• ‰]òË¿qjSÁ€…ë”çÑ,“ƒÓùÎUýÅQ–f•ûº¼#OÜ3)œKˆX­ØÙÕûÒõþº] й.ËÔÓË™\¬±ûvÙÄBþ­ñºÝãf»­+®Ž[U²=”:Y˜Ícx×£Û­¿§Œûn5ùÚ—ÅØ¦ _•f廽\Ù}Õ5DWOâkiüeÿp§æChÿnûÔÝ$ß:AIJﴼ;I¿ø_nh¾3YlôIæ.Qß^$ÊUe[¸žÑONz5†8£‡¨îÏ×ô6ïm=ŸÕŸ–ÊÃxÓÞ²Á§}£<«—¢l+…£Ò›IÜPÕ¤ðá–>^ðš _Ö^Îà7LâÙÒåãùýt'/=¸/Ë ›Á cC¥È¤y=ÔÇ]µU/¶kH÷Í•3ZÌäh(^RtÅf–ó‹qvhÏù²¹ã$©*I“¬ýr?™‹uÑ/K&Cã2 ša]Ô:ýS—ãÚ·Ùµ/ë•2”“ûÎFoâ-,îoŸ¾-k-9öÚ½R&k:ýÏ(õSº-[ïG À#¯—¾PgØšÁλôwå“ò'¦Üoª“°²½LFc†¯ûr?i‰ä¼ ×:ÞICýäÛûðÞ.ÓǼ›†.£ÏàBÔúwë^áJ?ö §~Ç»sÚä€nÖËb˜“¶ìŠøÁ;žãåòf6j½ÈUHï‹ß}îC£Û¶F¨ùSSi8v.WÐüб½Õo5Og,ôrF¡eþ ²ðÃË›óS(äá?IʾʲbŸ„¯šâiüØË3/KA EÖ~ÒPXm QçvÏLxýBÈžPN—Ä÷à¢á“ûŸ¶Õ°y¬QëÝHT&Hɵ¯¼Þˆ{,½üdW“´Y/Y"¤ºt¿nh<ý9ûÝèµ[+!9‚½e™”æø~Gát[(q*é¤VW½€êøãóºrÒ·àA-á~ Ô‹¢wª¸Å®ñÇWDòjd¦[Vò ÄѹœŽïÛ»ÛTMò¶·-óÖBT Æá£.yþè•W¼´ûÓyZ~ÒHniËK½^‰•òÜd-ëDÎd8äª÷¹§ûÆåèï[Ã1,“ámdû9õ=Mê]ÕlœÉ$ ›Éoà§Ô折>Úgl¸‰M?ýÉ ä3M‘‰¸ÕùÁ®EãýfX7wÐ5W½„LY¾ÕüqUñ~÷)VÙ1 q&»A¤ûÝø·[m½]Å#¨´ùzÕ ×…Q{HŽ·æ[žÂøñÑ®ƒÝ5‹QlQjORß—üN*”ý½]ç½_:!2I ™Ö¢.5ü”·Ö¸/[L¼(M¤4Ηq}7#ðÍm~ÞßDlOI ›ð‘F}ÆKʲ{*Ϫò]%kì—U©AÔj•ÅMµ?D_¾×-ç(9-*s&…€}J~y“©¦v{ä«/“° ÁTË€Ò˜´bã¼Ëv:Æ™t½Dh¦/} ¹ÝòÖ-’H‹d”IW ¨“Šoõ5ŸüŽrï¾9å£k$“®ÕÒ÷ûÈ&7Á¶5CIPÈ”—õþ°¹¼ÄºßlúWþ<פ®èU+Óíyù`$ËŠœêfÏB:O2é œŸE²©_ú‡(gÅ‹yŽË!9ùQó§<6_K±®gÛ«½ºÄºY2 ăS\bNÊþOx5éÝ–]³¢õžFj+qáŸq—û-~$<í•´L–‚¦ÎÎ…ó|Š[ŽU7 íçÖL–B6–‚›wûÚÝ'Ä3 %1A¯â-ËL–²G@ó;Ij²^þd é5—z»ÃŠC?„‡ãÚ£Òz´²eÒ ’lËŠï ‡ ¢•mR“ê"ef2ð‹÷ý|¶>Ê¢³kã:–Ó³’… t¦ì?÷Ü+=¸›5]÷Bû”ã˜Ë”ÿ);¯»ÝSlÛ*õ†xyŠ?AGÁfU}ñ–ïLB¶*bòçÿ±2*Ü·ûº­ÚÛiÈA!iÙŸþ§ƒ¶MÖUÚ×à˜L ‚Þ!s$ìŸq€n°ã£×¼‰4„loKù.˜ýö¦Òž!_]yšYÔê‚!ì<žÕ—s%±~©ÓÐ;cE©] ó›ü}yÝûæ,z1¸•œƒL^‚½á—qêiÔÂPŠÀh/ž¥&©°ýÒÛxÁËl‘=^‚«'$É@ó6<â­Þ¼E ’:×LÁ½fR ²(’ûÁ‘`øV®ˆÝkàÚ*5G/KÍ ûn"í ‚üNÈädq Ú¸>ª ›Þp3ôêf7l$h¼+~y,IìÜL™8‹Ò:²ëB>ËY¿TOÎ $™‚<õª³u'oBÝå·îâR.óŽ29Yœ¾ÂÒ^ÿˆQöÈo\ S¯QöÙ¶&‡–س…i3ÓôeÞRú^-æ|ì ft:’½2˜TR±fvYø$ÒeyëK'.PÈàÝÏã®ß¨ÆÊcâ¶»vØÔBv@Ñ;Lʲ/Ât_ÜRÈ(z/u ß{Îè«lå8æOÙ¸ «Øù§€}õ‰JD¶ `Šçl—B@`éíg´6»Á ),ˆB€Fbòå/?Ç*.[ÐÙV/°WõÚ;›I(r¨Ëzýt!tË S°ý’ W3†ž~¡YÝô»dÖ˲zÝx´v»Ÿ çWîq?ÌKHÐü­0”ò ®÷E7I(×# é$Ë€ÿ\¼£÷#ܤ6¦ËªT"œtñ§ ªÓÁΠ*‡3,¤u;¯äëÓuqÊØ|ìGgS!' h ÄË~HOï³™ár„Q…Œ€ÂÙsU>€i‡ÑÛÀ?¯‰˜U!#€9€ Íþåg0Õ÷é§Þ™cðçÿkzªzFtimereg/data/diabetes.txt.gz0000644000176200001440000001375714666545364015617 0ustar liggesusers‹]›[®à¸‘Dÿ{µL&_Ë1Ð ÃÀÌϸ Ìì~N$%‘*\ÕvESR>#’yýëÏ_?¿þþ×ÿÅÿþûÿçßúßÿó÷_ÿ÷WüÃ_ÿø›?ÿñçþ+þüç_þï¯?~å_?õÇÛe>[·nVûüI?ö“ù¯?~Ùèµ–ÔÇ̽X Ò(¿~²ÿ¸]5µQZ¥·ÊßæõËþøå(ù*žÝ9fLïñ·éFTMg””æÊæ,ï!ó_íAX÷ÔÜzo‰CÓ}ˆþëÇꥫ¹3ÞÔKm÷Çb¼ˆRS¶œl½©=GL󧌫›Þl”Y†¿Gä‚ÁR`ÒUr-­××6@ù>&@˜ÕÛO«—Õ4g3ïÃ[ÿ%[`ªÇI¼ 6)Ý?fÉØÖçO+WÍ3qVõ™¼½ç`ýìÉé`|pNÅÞcÁºÂÊe¹í>{Êß·i&w>©¤i¹çþÚ70X¸ñ—ÏYkÇ 'í·É ̸15œf·<»ûqŽ0˜¹çŸ:®Ô1OvÂnÞ¾Œ°Ë„] L.×h5•jƒz½?ëÆ`園¢Ó ÛpGkmÅn„+Ìnиª¼ÚfKµyÙ!,b8ÛûåÄwï¥VßWrä Ô/|Pøz¾´éï;H‘lé§Ì«%bWl}¼9åPÛ œê,y¶Ò­¾ï .Pÿ)òlÏ™8óá>ncRvŽ48ibhâš“m¿“@Ø;—òÓ"‹Ýf=·mpœRÒe¿râû­—:©¯Á…‘ÁkRYòTyw˹÷ÛàüJ€lf²‰'uÁÛØ " NBÞJ#NÌ2•a—¼R|œˆ£,õ¤lå>èÆÈÞ½é +˜’"–Z;Õ*˜¶1nxŸ4 >Ô7(…‘µù¿j'–²Y"K»úü±1¢LYêw™JHÆž‰dº‘‹_yñ™óùBž6†„.½6~¾cjù±õ«b›@óÖFþÔ"· ¢î6ësOlß LmÉÊ‹ÂY§’?÷ãËô4_UFÎ0jF-Ùq$¶Æ2ª5%cãÚk¶åûIéí]ê'XgÐj>ʽ@ªÕ¾"Ò)4*úyéþ:0cc ÁO%þ³í£‚]ñÈÕíÉŠ*1þdM µ$y¦7Šÿd•½›+FU„¯¯Ýk>Š›º”-)™(n¼-€Fòme²w£ø“$„u)Þæoñ·ŸB”T_ £tq®+$Ê.%‘¹i,õô]¾ŸVT¨_oy«x·¶¢·R#òÄÖjÚÑ ’¹§Ì4]}¼O<Õ¾f T*Ád“w§LRã¾fÂà´hì‰Å)’„$m§·÷Œ8iéåkÚL™ªUrNû”âK B²¥DUm‡ë¨¦Íˆ¢4R.XÜi‚ãx'08-Ð ¼g2ªŽ1ª„1›/Á„uZInDž×}’@X¼˜«¡ˆ<й˱‹R¡˜¶¶0fÝØH¹Á õú~\€º@C”‡×1Þ*¥ácìøÖ{ "z‰Ë oñ±\ œ:TTrñmRÚu+×õ´@z'EHrVòo„wÜi_éšÅ+õ›¬‹DÏé¶1DJ$]ö»ê¤${C9ˆAÑ X-ýèK¼v÷…QÎÍJÍå?¤SþôÊ.sWšt+qƒßSky)ÞÛÑ¿ámP”½¶vtdoZL-±†Ûhƒ˜¼î?ˆ.?aˆI5îý8dï¡`"ŠH%½T͵îG>´@ÏÁqH’?»€HöžígK#m‰N¿Ù‰ã”a”Ô”)OÄI¿.@b|Lq‚·R'rk'›³õ ¡Ÿ 5ïY'Lf*º¡4¯D¨Ì—!/®0Úå»Ë%³ðfÝö „¹=ã]ˆ2Ý)< Ø-…28Æ!¾ÎW•FÞ Öv1îH&qõù¹k¥&3-ŸF4vx УVF„[C’àd ÙKŽ¿ßV)9ÓˆW¢M:)žÅ©Çûm’±© ´úÍN¥<øäÉô J„,]=‘µ•P·c¾IášãÅ8”Œ¾,3c/Œl=R”Iþ}É`üèÞSê&-”yP‘{vªµ@ÉÜD—M‘ô Œ2£þ¾’"ÙFñý”„I÷)4NAç‰Æ¯r„eÊ_TËÔBrPU¶]()T~¨4‹¯æõ1Û®(]¨ö¢j‚ëÏ ñmGÏ\(ìNæ«‹U±’Eg}³f58ŠT@ÆP2*QÙæÂöPN•zTÄRÎ|+K—fL/ˆþEùæíˆ¿-P$Á^¢i4¥ ê‚úlöµ–´å‹¢lÖdÇnR …åiM’!´Ú‹:‡ÍM ‹ü#y£°8µÊCsجw¡dyX¿Jò‘ÌW¢#Tq[ < sâYCÊø¦kéÉîä'MB‹gÒ¦ ì;¶Âc£09=±C$kÛ±(Ù]†<åéôjØgé‰ÒšBÑ>­dbžJD´.P²<Í©B}(gÔ;Êl¯;Ÿ³l*¹)Œâ“h2Æùóõ’åI· ?2Õ˜oSÏÒ›7ˆ¶ïª!Á#>]=KpVÕçD-&b’:_™»õIpKp T/Óš4 OÜä'0²;Ýš§O’$¯Óe…§P•h –BÿénÞñG dwhCµ‹ðÄàYJ8û¥E(IÎ@©Òª‘ ÄÉÎÂ…Áê-…vƒÜjþA;öäÛêpHs %K9YÄ`³ïú·PE³‰$ß” )‡N©³n³ËÏRBA8 cCÁÞë)_TªÁ$pHD½Ýž6EøIx>(Ì•Dê!t> /—«àçzÑ2€,Ö¼§_k46ŠâÅGöåèð …á›lGÉ!ªyÚ¤ªÞ’ŸˆšœÕsôÌ“,d ÐVô¹ÔRǪçì=oce¡l¡¦糩zk;£J†/1½ËîâKüný gŠd‰Ð%Y¥ÔA®j6P²<­—rD$w^–âe·å—DèªE´¶"úôÕ,ÚjL<ŠFkRêšÂí/ ÔX(ϤÙÀ@V÷Jvo&þíP³ŠÈÖ Še ÑO]C5 稜[ÚGHvGc6b&‹¨“ÍÃmKc¹YBT Þ\kbr¼—÷¤ÉêpÇœ®bëªHíÐjò…Ê*~7;_[V±P²:´Q;|ÄÙ(b«ï[ÉÒ¢ˆ@%h}Ó¢au kGú#ú¦Súø¶BiѤø…CÎ}R€4F$éËÐÄ ÊkplMP_ò({JŒ Å÷Á.4Ú‘öo{²±PYãÆ®i,Æ¥×›† 3¿gIFgÉÑÅ×R%$2ÆV5 …Ýi§*‘Eœ¾j ÓÞù¬8– j’ÎZ±WØ%+PØ· BäQÈôÌîj$MÚ# ¡óÐÑ’ý(YÞÓúF…׉‹ÆQ³b<”Kl6zÁÝÞ:#Y €F]„²¨$É1ß(]¤tÒ\’ƲeX€dr yaGð‚¡›™Öûše å eÝgB3 kíw L>â Çg'€!"ÞjÙQÕ„j EzUz8žkõc l>¶HÄIQ#€Ö§=N©a„±QDBUØùq‹±@X}y0x'§‰âØwÃE—]’¬BAp5™]üÜÓª…ÂêÓRtóè:–³Âë‰Ò¬B)ª`FYκ9ݱ¨"”¢˜.HX!É‹ì¿Uy |¡ò¥›,ÕG þ5×BaùY‚eàæÞ[²¬›AiÖ¤«<ªm>»a`dw˜k¥ÿÆŠ‡÷äO\I±Þ ¸;…ÏFH‹O\I°NWØXU OQï±#T|Ú$XWŸæßû¨…’Ù×Õ°îaøMõ;ÿ¼¿âzÔJ·Œw‚t®©Ã)~M‚jr‡VÒ×uû¡°·\)’%X¢ÝOIª‡[)»ƒHFoÑš 3”Áó,o-Pj D\ͦy/B­å#$«ë6fÐìUŠXg™ß°’`}PtÂÖÐNTÃ’ÝaªjäFMW¶ÍÙž[â´PÒVšš”˜<ÇÎÂ@Éî4ÌhLCÕA^<†Ñ&-îHxbÒœ±ÙÈïHVÑâ‚æë6ÉÚüî˜ëF¹&=dâ!çJv§€¨Ù'%ò=sPøI° Ôéõ°×ímJe|b4®J²¥eÄB Vù&NÜ– ÍžCB8:‹”Ó}iRK‹«~ŒNÍ‚÷0ÝR'õ§LËçð!‰ä~\-)%\ì‚¿®l*m_°°«2ºö'²‡®jÞw‹%í0‹@†@›F9Ë‚…ÜÖ¶ –5i2›‚k.g>X/]Õ©×:—>°ðñ®+ (1Õ^D©mνª¦Ö;A¥Ùا,¼ùkÒI$[Õ˜›¼v‹M »Qá«¡uDc? Â¼¯qåß•ˆÆ÷(Qõ„£xuŠ0N©b;ÇdÑ$bs\{vú=êNÛÞ“ô(R±Ò6R!tDңŀÉþZ!¡ªX±è¬ï$6†j&!û èžÏMœ÷-v f z ñ†KG‡øg“’}PÅ@zÛ £ŽyzÀr¬©4õwe0g¡oj>. e i٠è¡?! /X°ØŒ)U¸®Ë¢¶½›AûÝ|àhÐPoP†s°ð€n]²'þ»=¯7ïšÖn˜“PYË’Æó)Ž*<IGªòúÚ*kÈÌ´9J,¿´qÃä(ôm 6Zæ¾öY°ð¶Mæ¥ûb]‹$‡<Ö3{Ú(í¨x lí²=<'1¿Ü5r®²Ù®hÚ±n7j^ƒ®ªÜÙj>yÀºùH°m׬j…¥¾_)ýeݘ&&"ÁÀ™f}­'Å2Ääï‹î8«m šEo7¬¤‚ʶ¼ë9{X¬(‘°CBÅT°Êwti}0w¢V±A1Ú#`òý:ÞRaÔQÝìûˆ ¹Ò¶†+ ¾º ì‚É º¸ê®Aaš„.ñq°q$‰Û%¹3iëÃóq•09ÁtsÑ‘aŽ.¶»s*žéLwãSr&ÛÖ‘ NÐLQ7Ѧü„ßôﮉv øÊÄå¹px­6ÂD¤–€r\iÛûn*ÑǸQ´Ø'ªµyŒ®. ‡HEuI2×åïi‘y3½0@~ Ë¥m"´`á‚w÷2ç/¹ìöËiv£øzõ,ÈãÁÐÀÉHtq „ ‡­¹Ôm´x¤0$Í£÷eÕƒ hì ñ}WùKjŸ;6â‘í@Y¡)ÎÆ1ܘPteŽ`L)†È(¦µU>—Ò ÔÐ…AI1-¯yï×-TlêåØèòØ ÓMvú,±–”V• E´þ¶YZ r D˜0íõB3›¹Z{“Ú}`±ªñ"÷ØØ ˜Ì_,‹óÅ6šæººF:Ez7P¦>½“¶9)Üûö+P²~Ñe}ôWŽAÁUÛ]X˜vc]I·âª²R9ûµ„ Ó“½u^h¼ªK¤üYÚhÜ ]÷h ê…ù|_*Pay]ÜAC q‘6ç8 £k2=°yѽ4ð#¢«oÞ¾`aü̓hFœbV´ƒ¢ f¬—Xp£òõþÖ‹ ã÷X\ÐU´ódMá>yT²ß¨ª¦ÓE·”èó3M)9Œ?ƒ„êú 2—‡ØË‡”ÜX\u"?´UðaEÂW[¡=’Vx+úæ^™Š•HIßF]ZÁÕ-ÂsöÀfÀt×Béqõjí)ì×#¥}_†ˆ-Vµ¶7$ûk˜Þ(dM5¶v·y°Yb¬ %MDDTíG–aÇ.WÀbÁ}EYK°êÞ"åB†í`¡húÚS%ò±-­écþXvÝ"C ÔÜŠrÇüj€ Â6äuØH=̰0¿è¸£Ä¨D´Øöe íØš‹Šá”D9€=ÕzÁÂú#ÉfcLm’âËsŠhÚÛM7 áškÝ­ÅÜöÚlÁÂ*êhÎá<ÊT=æç[ÀvÃ\©  ˜4Ò^ŸX°ðÀŒê3´®AÏoŠÍäõØ~`¦–ÔÒøñã  ÌX«/Z$QÖt?´~|A»Qº”ÈÑn¶ß,Pò€vIའ¼¤I’7Ý¢]%´ðëZctÕ˜òeg%´0-0n»‘ ]Ûš…ïvG -üÂô3 &)süXƂŶ¶ÅN«tZ'´qk:–¬eÜÐÂŒ¸¨â¾éîw ˜| ‘¯Y-Á"!éTþ¼¬VQZ¸®=rÝ«`Aˆ—X°ðÆ]óšEµ6k‡fÔo„ ‰¢kÚ‰<­~Ç%¤°Ö8Öõ4fÐÓÛ.ݺN+¡…”º1Æmâã°€…4pJ‹PI|˜Ÿ§©`…~`Žî+Q¯ü¸ÎXx€ÏrÍ‹«Ï1‰6›;©¢Æ„~`z3´"ËßÃ*\@µ.¤nÒÊ„{9VÞ´¬[B &¡žSN†-ÛmŽ0¹€‚{¨.‚Šß§D(`¶aih÷Ûô“F©þvZüàB*kRAÖÞŠÈïæŽrUèá–eY­Då~ÜÀ,~î‰>Øë•L›šéß =,XË¥ˆ†œ´ï^·T\09#ŠZ¬s©¥ÅÏt|^m<(Q+âVA¢X¿½šœ uŒ¢ + …(þãƒÐÃB5 “éªÇ{úí~J(âæa\ÚOëÚ28·IôÌÄã b“‘ôÔ”c³«€…ô£]VžÈgz‡P…$~`“DÖdNÚûÝ>Ð>óÕ][˜MVû7'! E|£Nдž”‡²*<°î… 8´QýÄÎs·g‰Ð… ~`¼:\¡RÄàTx kB§KÝëQÖfÙ‡ røA÷^iä=tPØ2KgÔ*TÈÑcé‹ªŽ†~`"ãenzaamá—øY!ý¤,%ï@Sû 1,%~h™Bkpe£¯@ÅÏïeƒ`äY®¥:¬qèt¡Ú"hëZM=©’ñc=#Ç®ÎÀÂMÕv'“ZvHaÁb¾§<ÒŠ¨µ=Z0Y_<ôÍ™­iÖMª‰rHaÁ,6¸5ÕhZ‹Û #include #include #include #include "matrix.h" void comptest(double *times,int *Ntimes,int *px,double *cu,double *vcu,double *vcudif,int *antsim,double *test,double *testOBS,double *Ut, double *simUt,matrix **W4t,int *weighted,int *antpers) // double *times,*cu,*vcu,*vcudif,*test,*testOBS,*Ut,*simUt; // int *px,*Ntimes,*antsim,*weighted,*antpers; // matrix **W4t; { matrix *Delta,*tmpM1; vector *tmpv1,*rowX,*xi,*difX,*ssrow,*VdB; int i,k,l,s,c; double xij,vardif,tau,time,dtime,random; // double norm_rand(); // void GetRNGstate(),PutRNGstate(); /* float gasdev(),expdev(),ran1(); */ malloc_vec(*px,tmpv1); malloc_vec(*px,rowX); malloc_vec(*px,xi); malloc_vec(*px,difX); malloc_vec(*px,ssrow); malloc_vec(*px,VdB); malloc_mat(*Ntimes,*px,Delta); malloc_mat(*Ntimes,*px,tmpM1); // Rprintf("Simulations start N= %ld \n",(long int) *antsim); GetRNGstate(); /* to use R random normals */ tau=times[(*Ntimes-1)]-times[0]; Ut[0]=times[0]; if (*weighted>=1) { for (s=1;s<*Ntimes;s++) { vec_zeros(VdB); for (i=0;i<*antpers;i++) { extract_row(W4t[i],s,tmpv1); extract_row(W4t[i],*Ntimes-1,rowX); scl_vec_mult((times[s]-times[0])/tau,rowX,rowX); vec_subtr(tmpv1,rowX,difX); vec_star(difX,difX,rowX); vec_add(rowX,VdB,VdB); } for (k=1;k<=*px;k++) { vcudif[k*(*Ntimes)+s]=VE(VdB,k-1); } } } /* weighted==1 */ for (i=1;i<=*px;i++){ VE(rowX,i-1)=cu[i*(*Ntimes)+(*Ntimes-1)]; } /* Computation of observed teststatistics */ for (s=1;s<*Ntimes;s++){ time=times[s];dtime=times[s]-times[s-1]; scl_vec_mult((time-times[0])/tau,rowX,difX); for (i=1;i<=*px;i++) { xij=fabs(cu[i*(*Ntimes)+s])/sqrt(vcu[i*(*Ntimes)+s]); /* Rprintf(" %lf %lf %ld \n",xij,testOBS[i-1],i); Rprintf(" %lf %lf \n",cu[i*(*Ntimes)+s],vcu[i*(*Ntimes)+s]); */ if (xij>testOBS[i-1]) { testOBS[i-1]=xij; } } for (i=1;i<=*px;i++){ VE(xi,i-1)=cu[i*(*Ntimes)+s]; } vec_subtr(xi,difX,difX); vec_star(difX,difX,ssrow); Ut[s]=time; for (i=0;i<*px;i++) { if (*weighted>=1) { vardif=vcudif[(i+1)*(*Ntimes)+s]; } else { vardif=1; } if (*weighted>=1) { if ((s>*weighted) && (s<*Ntimes-*weighted)){ VE(difX,i)=VE(difX,i)/sqrt(vardif); } else { VE(difX,i)=0.0; } } else { VE(difX,i)=VE(difX,i); } Ut[(i+1)*(*Ntimes)+s]=VE(difX,i); c=(*px)+i; if (fabs(VE(difX,i))>testOBS[c]) { testOBS[c]=fabs(VE(difX,i)); } c=2*(*px)+i; if ((s>*weighted) && (s<*Ntimes-*weighted)){ testOBS[c]=testOBS[c]+VE(ssrow,i)*dtime/vardif; } } } /* for (i=0;i<3*(*px);i++) Rprintf(" %lf \n",testOBS[i]); */ /* simulation of testprocesses and teststatistics */ for (k=1;k<=*antsim;k++) { mat_zeros(Delta); vec_zeros(tmpv1); for (i=0;i<*antpers;i++) { /* random=gasdev(&idum); */ random=norm_rand(); scl_mat_mult(random,W4t[i],tmpM1); mat_add(tmpM1,Delta,Delta); } extract_row(Delta,*Ntimes-1,tmpv1); for (s=1;s<*Ntimes;s++) { time=times[s]-times[0]; dtime=times[s]-times[s-1]; scl_vec_mult(time/tau,tmpv1,xi); extract_row(Delta,s,rowX); vec_subtr(rowX,xi,difX); vec_star(difX,difX,ssrow); for (i=0;i<*px;i++) { VE(xi,i)=fabs(ME(Delta,s,i))/sqrt(vcu[(i+1)*(*Ntimes)+s]); if (VE(xi,i)>test[i*(*antsim)+k-1]){ test[i*(*antsim)+k-1]=VE(xi,i); } if (*weighted>=1) { vardif=vcudif[(i+1)*(*Ntimes)+s]; } else { vardif=1; } if (*weighted>=1) { if ((s>*weighted) && (s<*Ntimes-*weighted)){ VE(difX,i)=VE(difX,i)/sqrt(vardif); } else { VE(difX,i)=0.0; } } else { VE(difX,i)=VE(difX,i); } if (k<51) { l=(k-1)*(*px)+i; simUt[l*(*Ntimes)+s]=VE(difX,i); } c=(*px+i); VE(difX,i)=fabs(VE(difX,i)); if (VE(difX,i)>test[c*(*antsim)+k-1]) { test[c*(*antsim)+k-1]=VE(difX,i); } c=2*(*px)+i; if ((s>*weighted) && (s<*Ntimes-*weighted)) { test[c*(*antsim)+k-1]+=VE(ssrow,i)*dtime/vardif; } } } /* s=1..Ntimes */ } /* k=1..antsim */ PutRNGstate(); /* to use R random normals */ free_mat(Delta); free_mat(tmpM1); free_vec(VdB); free_vec(rowX); free_vec(difX); free_vec(xi); free_vec(tmpv1); free_vec(ssrow); } void comptestM(double *times,int *Ntimes,int *px, double *cu,double *vcu,double *vcudif, int *antsim,double *test,double *testOBS, double *Ut,double *simUt,matrix *W4t[],int *weighted,int *antpers,double *cu0,double *argmax) //double *times,*cu,*vcu,*vcudif,*test,*testOBS,*Ut,*simUt,*cu0,*argmax; //int *px,*Ntimes,*antsim,*weighted,*antpers; //matrix *W4t[]; { matrix *Delta,*tmpM1; vector *tmpv1,*rowX,*xi,*difX,*ssrow,*VdB; int i,k,l,s,c,u,t; double xij,vardif,tau,time,dtime,random; double ixij,mu,ms,mt,tu,ts,tt,uhat,dmus,dmts,icxij; // double norm_rand(); // void GetRNGstate(),PutRNGstate(); /* float gasdev(),expdev(),ran1(); */ malloc_vec(*px,tmpv1); malloc_vec(*px,rowX); malloc_vec(*px,xi); malloc_vec(*px,difX); malloc_vec(*px,ssrow); malloc_vec(*px,VdB); malloc_mat(*Ntimes,*px,Delta); malloc_mat(*Ntimes,*px,tmpM1); Rprintf("Simulations start N= %ld \n",(long int) *antsim); GetRNGstate(); /* to use R random normals */ tau=times[(*Ntimes-1)]-times[0]; if (*weighted>=1) { for (s=1;s<*Ntimes;s++) { vec_zeros(VdB); for (i=0;i<*antpers;i++) { extract_row(W4t[i],s,tmpv1); extract_row(W4t[i],*Ntimes-1,rowX); scl_vec_mult((times[s]-times[0])/tau,rowX,rowX); vec_subtr(tmpv1,rowX,difX); vec_star(difX,difX,rowX); vec_add(rowX,VdB,VdB); } for (k=1;k<=*px;k++) { vcudif[k*(*Ntimes)+s]=VE(VdB,k-1); } } } /* weighted==1 */ for (i=1;i<=*px;i++) { VE(rowX,i-1)=cu[i*(*Ntimes)+(*Ntimes-1)]; } uhat= VE(rowX,0)/tau; Ut[0]=times[0]; /* Computation of observed teststatistics */ for (s=1;s<*Ntimes;s++){ time=times[s]-times[0]; dtime=times[s]-times[s-1]; scl_vec_mult(time/tau,rowX,difX); for (i=1;i<=*px;i++) { xij=fabs(cu[i*(*Ntimes)+s])/sqrt(vcu[i*(*Ntimes)+s]); if (xij>testOBS[i-1]) { testOBS[i-1]=xij; } c=3*(*px); testOBS[c]=testOBS[c]+cu[i*(*Ntimes)+s]*cu[i*(*Ntimes)+s]*dtime; /* Rprintf(" %lf \n",testOBS[c]); */ } for (i=1;i<=*px;i++){ VE(xi,i-1)=cu[i*(*Ntimes)+s]; } vec_subtr(xi,difX,difX); vec_star(difX,difX,ssrow); Ut[s]=times[s]; for (i=0;i<*px;i++) { if (*weighted>=1){ vardif=vcudif[(i+1)*(*Ntimes)+s]; }else{ vardif=1; } if (*weighted>=1) { if ((s>*weighted) && (s<*Ntimes-*weighted)) { VE(difX,i)=VE(difX,i)/sqrt(vardif); } else { VE(difX,i)=0; } } else { VE(difX,i)=VE(difX,i); } Ut[(i+1)*(*Ntimes)+s]=VE(difX,i); c=(*px); if (fabs(VE(difX,i))>testOBS[c]) { testOBS[c]=fabs(VE(difX,i)); } c=2*(*px); if ((s>*weighted) && (s<*Ntimes-*weighted)) { testOBS[c]=testOBS[c]+VE(ssrow,i)*dtime/vardif; } } /* konveksitet */ if (s > *Ntimes){ ts=times[s]; ms=cu[1*(*Ntimes)+s]; for (t=s+1;t<*Ntimes;t++) { tt=times[t]; mt=cu[1*(*Ntimes)+t]; ixij=0; icxij=0; for (u=s;utestOBS[c]) { testOBS[c]=fabs(xij); /* Rprintf(" %lf %lf %lf %lf \n",ts,tt,tu,xij); */ } ixij=ixij+dtime*xij*xij; xij=(mu-ms)-(mt-ms)*(tu-ts)/(tt-ts); c=5*(*px); if (xij>testOBS[c]) { testOBS[c]=xij; } icxij=icxij+dtime*xij; } c=4*(*px); if (ixij>testOBS[c]){ testOBS[c]=ixij; } c=6*(*px); if (icxij>testOBS[c]){ testOBS[c]=icxij; } } } } /* simulation of testprocesses and teststatistics */ for (k=1;k<=*antsim;k++) { mat_zeros(Delta); vec_zeros(tmpv1); for (i=0;i<*antpers;i++) { /* random=gasdev(&idum); */ random=norm_rand(); scl_mat_mult(random,W4t[i],tmpM1); mat_add(tmpM1,Delta,Delta); } extract_row(Delta,*Ntimes-1,tmpv1); uhat=VE(tmpv1,0)/tau; for (s=1;s<*Ntimes;s++) { time=times[s]-times[0]; dtime=times[s]-times[s-1]; scl_vec_mult(time/tau,tmpv1,xi); extract_row(Delta,s,rowX); vec_subtr(rowX,xi,difX); vec_star(difX,difX,ssrow); for (i=0;i<*px;i++) { VE(xi,i)=fabs(ME(Delta,s,i))/sqrt(vcu[(i+1)*(*Ntimes)+s]); if (VE(xi,i)>test[i*(*antsim)+k-1]){ test[i*(*antsim)+k-1]=VE(xi,i); } c=3*(*px); test[c*(*antsim)+k-1]=test[c*(*antsim)+k-1]+ME(Delta,s,i)*ME(Delta,s,i)*dtime; if (*weighted>=1){ vardif=vcudif[(i+1)*(*Ntimes)+s]; } else { vardif=1; } if (*weighted>=1) { if ((s>*weighted) && (s<*Ntimes-*weighted)){ VE(difX,i)=VE(difX,i)/sqrt(vardif); } else{ VE(difX,i)=0.0; } } else { VE(difX,i)=VE(difX,i); } if (k<51) { l=(k-1)*(*px)+i; simUt[l*(*Ntimes)+s]=VE(difX,i); } c=(*px+i); VE(difX,i)=fabs(VE(difX,i)); if (VE(difX,i)>test[c*(*antsim)+k-1]){ test[c*(*antsim)+k-1]=VE(difX,i); } c=2*(*px)+i; if ((s>*weighted) && (s<*Ntimes-*weighted)){ test[c*(*antsim)+k-1]=test[c*(*antsim)+k-1]+VE(ssrow,i)*dtime/vardif; } } if (s>*Ntimes) { ts=times[s]; ms=ME(Delta,0,s); for (t=s+1;t<*Ntimes;t++){ tt=times[t]; mt=ME(Delta,0,t); ixij=0; icxij=0; for (u=s;utest[c*(*antsim)+k-1]) { test[c*(*antsim)+k-1]=fabs(xij); /* Rprintf("local %lf %lf %lf %lf \n",ts,tt,tu,xij); */ } ixij=ixij+dtime*xij*xij; dmus=cu0[i*(*Ntimes)+u]- cu0[i*(*Ntimes)+s]; dmts=cu0[i*(*Ntimes)+t]- cu0[i*(*Ntimes)+s]; xij=(mu-ms)-(mt-ms)*(tu-ts)/(tt-ts); xij=dmus+(mu-ms)-(dmts+mt-ms)*(tu-ts)/(tt-ts); c=5*(*px); if (xij>test[c*(*antsim)+k-1]) { test[c*(*antsim)+k-1]=xij; /* Rprintf("conveks %lf %lf %lf %lf \n",ts,tt,tu,xij); */ } icxij=icxij+dtime*xij; } c=4*(*px); if (ixij>test[c*(*antsim)+k-1]){ test[c*(*antsim)+k-1]=ixij; } c=6*(*px); if (icxij>test[c*(*antsim)+k-1]){ test[c*(*antsim)+k-1]=icxij; } } } } /* s=1..Ntimes */ } /* k=1..antsim */ PutRNGstate(); /* to use R random normals */ free_mat(Delta); free_mat(tmpM1); free_vec(VdB); free_vec(rowX); free_vec(difX); free_vec(xi); free_vec(tmpv1); free_vec(ssrow); } timereg/src/mgresid.c0000644000176200001440000005376514421510301014302 0ustar liggesusers//#include #include #include #include "matrix.h" #include"R_ext/Random.h" void mgresid(double *designX,int *nx,int *px,int *antpers,double *start,double *stop,int *status,int *id, double *mgtimes,int *nmgt,double *dmgresid,int *sim,double *xval,int *ant, double *univarproc,double *timeproc,double *simunivarproc,double *simtimeproc, double *unitest,double *unitestOBS, double *timetest,double *timetestOBS, double *unitimetest,double *unitimetestOBS, double *modelmatrix,int *model,int *pm,double *cummgt,double *dNit,double *robvarcum, double *testOBS,double *test,double *simUt,double *Ut,int *cumresid,int *maxval,int *startdesign, int *coxaalen,double *dcum,double *beta,double *designG,int *pg,double *Ogammaiid, int *clusters,int *antclust,double *robvarcumz,double *simcumz, int *inXZ,int *inXorZ,int *iptot,int *entry,int *stratum,int *silent,double *weights,double *offsets,int *ratesim,double *weightsmg, int *varweighted) //double *designG,*dcum,*beta,*designX,*start,*stop,*mgtimes, // *dmgresid,*xval,*univarproc,*timeproc,*simunivarproc, // *simtimeproc,*unitest,*unitestOBS, *timetest,*timetestOBS, // *unitimetest,*unitimetestOBS,*modelmatrix,*Ogammaiid, // *cummgt,*robvarcum,*testOBS,*test,*simUt,*Ut, // *robvarcumz,*simcumz,*weights,*offsets,*weightsmg,*dNit; //int *pg,*coxaalen,*nx,*px,*antpers,*nmgt,*sim,*ant, // *status,*id,*model,*pm,*cumresid,*maxval,*startdesign,*clusters,*antclust, // *inXZ,*inXorZ,*iptot,*entry,*stratum,*silent,*ratesim,*varweighted; { // {{{ // {{{ // memory allocation matrix *Delta,*tmpM1,*X,*cummat,*modelMGT[*antclust],*modMGz,*modMGzosdt; matrix *A,*AI,*cumX,*cumXAI,*cumZP,*XPZ,*tmp2,*dS,*S,*St[*nmgt]; matrix *Z,*dS1,*S1,*cumX1,*cumXAI1,*cumZP1,*tmp21,*cummat1; vector *Deltazsd,*Deltaz,*tmpM1z,*vtmp2,*vtmp1,*cumdB1,*VdB1,*respm1; vector *dMGt[*nmgt],*cumdB,*dB,*VdB,*xi,*rowX,*rowcum,*difX,*vtmp,*respm,*gamma; vector *risk,*cumA[*antclust],*cum,*vecX; vector *Gbeta,*dA,*xtilde,*zi,*gammaiid[*antclust]; vector *tmpv1,*rowZ,*rvec,*dB1[*antclust]; vector *dBgam[*antclust]; vector *weightmg,*weight,*offset; int ci=0,pmax,m,i,j,k,l,s,c=0,s1=0,count,pers=0; int ptot,weighted,*cluster=calloc(*antpers,sizeof(int)); double lamti=1,time,RR=1,vardiv; double random,xij,dtime; // void smoothB(),comptest(); // void GetRNGstate(),PutRNGstate(); weighted=*varweighted; ptot=*px+*pg; ptot=*iptot; GetRNGstate(); /* to use R random normals */ for (s=0;s<*nmgt;s++) malloc_vec(*antpers,dMGt[s]); // for (s=0;s<*nmgt;s++) malloc_vec(*antpers,dNt[s]); for (i=0;i<*antclust;i++) { malloc_mat(*nmgt,*pm,modelMGT[i]); malloc_vec(*pg,gammaiid[i]); malloc_vec(*pm,cumA[i]); } malloc_mats(*nmgt,*pm,&Delta,&tmpM1,NULL); malloc_mat(*antpers,*px,X); malloc_mat(*antpers,*pg,Z); malloc_mat(*antpers,*pm,cummat); malloc_mats(*px,*px,&A,&AI,NULL); malloc_mats(*pm,*px,&cumX,&cumXAI,NULL); malloc_mat(*pm,*pg,cumZP); malloc_mat(*px,*pg,XPZ); // matrix *AIXZ; // malloc_mat(*px,*pg,&AIXZ); malloc_mats(*pm,*pg,&tmp2,&dS,&S,NULL); for (s=0;s<*nmgt;s++) malloc_mat(*pm,*pg,St[s]); malloc_vecs(*pm,&vtmp,&cumdB,&dB,&VdB,&respm,NULL); malloc_vecs(*px,&tmpv1,&cum,&dA,&xtilde,&xi,&rowX,&rowcum,&difX,NULL); malloc_vecs(*pg,&zi,&gamma,&rowZ,NULL); malloc_vecs(*antpers,&weightmg,&weight,&offset,&vecX,&risk,&Gbeta,NULL); malloc_vecs(*antclust,&rvec,NULL); // }}} for (j=0;j<*nx;j++) { m=id[j]; cluster[m]=clusters[j]; } if (*coxaalen==1) for(j=0;j<*pg;j++) VE(gamma,j)=beta[j]; if (*coxaalen==1) for (i=0;i<*antclust;i++) { for (j=0;j<*pg;j++) VE(gammaiid[i],j)=Ogammaiid[j*(*antclust)+i]; } for(j=0;j<*antpers;j++) {VE(weight,j)=1; VE(offset,j)=1;} // if (*coxaalen==1 && *ratesim==0) // for (i=0;i<*antpers;i++) VE(dNt[s],i)=dNit[i*(*nmgt)+s]; R_CheckUserInterrupt(); /* cumulative martingales Aalen type */ if (*model==1) // {{{ { pmax=*px; if (*coxaalen==1) pmax=max(*px,*pg); pmax=max(pmax,*pm); for (s=1;s<*nmgt;s++) // {{{ { time=mgtimes[s]; dtime=mgtimes[s]-mgtimes[s-1]; R_CheckUserInterrupt(); // mat_zeros(X);mat_zeros(cummat);vec_zeros(risk);mat_zeros(Z); if (s>=2) { mat_zeros(X);mat_zeros(Z); mat_zeros(A); mat_zeros(cummat); mat_zeros(cumX); mat_zeros(XPZ); mat_zeros(cumZP); vec_zeros(weightmg); vec_zeros(weight); vec_zeros(offset); } if (*coxaalen==1) for (j=0;j<*px;j++) VE(dA,j)=dcum[j*(*nmgt-1)+s-1]; // {{{ reading design and computing matrix products if (s>=1) { // {{{ for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { for(j=0;j=0) ) ci=ci-1; } // }}} //Rprintf("%d %d %d %lf %lf %lf \n",s,ci,id[ci],start[ci],stop[ci],time); vec_zeros(rowX); vec_zeros(rowZ); vec_zeros(dB); if (s<1) // {{{ modifying design for next time points while ((stop[ci]=0) ) { for(j=0;j<*px;j++) VE(xi,j)=designX[j*(*nx)+ci]; if (*coxaalen==1) for(j=0;j<*pg;j++) VE(zi,j)=designG[j*(*nx)+ci]; for(j=0;j<*pm;j++) VE(vtmp,j)=modelmatrix[j*(*nx)+ci]; if (*coxaalen==1) { VE(Gbeta,id[ci])=vec_prod(zi,gamma); RR=exp(VE(Gbeta,id[ci])+offsets[ci]); lamti=RR*vec_prod(xi,dA); } if (entry[ci]==1) { replace_row(X,id[ci],xi); replace_row(cummat,id[ci],vtmp); // scl_vec_mult(RR,xi,tmpv1);replace_row(WX,id[ci],tmpv1); VE(weight,id[ci])=weights[ci]; VE(offset,id[ci])=offsets[ci]; } else { replace_row(X,id[ci],rowX); replace_row(cummat,id[ci],dB); VE(weight,id[ci])=0; VE(offset,id[ci])=0; } for(j=0;jtestOBS[i-1]) testOBS[i-1]=fabs(xij); Ut[i*(*nmgt)+s]=xij; c=(*pm)+i-1; testOBS[c]=testOBS[c]+xij*xij*dtime; } } // }}} s=1..Loop // vec_zeros(VdB); vec_zeros(respm); // if (*coxaalen==1 || weighted==1) // for (s=1;s<*nmgt;s++) // {{{ // { // vec_zeros(VdB); vec_zeros(respm); // for (j=0;j<*antclust;j++) { // if (*coxaalen==1) { // Mv(St[s],gammaiid[j],respm); // extract_row(modelMGT[j],s,cumdB); // vec_subtr(cumdB,respm,vtmp); // replace_row(modelMGT[j],s,vtmp); // } else extract_row(modelMGT[j],s,vtmp); // if (weighted==1) { // vec_star(vtmp,vtmp,cumdB); // vec_add(cumdB,VdB,VdB); // } // } // if (weighted==1) // for (k=1;k<*pm+1;k++) robvarcum[k*(*nmgt)+s]=VE(VdB,k-1); // ///* comp observed sup statistics */ // if (weighted==1) // Ut[s]=time; // for (i=1;i<=*pm;i++) { // if (weighted==1) vardiv=sqrt(robvarcum[i*(*nmgt)+s]); else vardiv=1; // xij=cummgt[i*(*nmgt)+s]/vardiv; // if (fabs(xij)>testOBS[i-1]) testOBS[i-1]=fabs(xij); // Ut[i*(*nmgt)+s]=xij; // c=(*pm)+i-1; testOBS[c]=testOBS[c]+xij*xij*dtime; // } // // } // for (k=0;k<*antclust;k++) { // printf(" %d \n",k); // print_vec(gammaiid[k]); // print_mat(modelMGT[k]); // } R_CheckUserInterrupt(); /* simulation of processes under the model */ for (k=0;k<*sim;k++) // {{{ { R_CheckUserInterrupt(); mat_zeros(Delta); for (i=0;i<*antclust;i++) { random=norm_rand(); scl_mat_mult(random,modelMGT[i],tmpM1); mat_add(tmpM1,Delta,Delta); } for (s=1;s<*nmgt;s++) { dtime=mgtimes[s]-mgtimes[s-1]; for (i=1;i<=*pm;i++) { if (weighted==1) vardiv=sqrt(robvarcum[i*(*nmgt)+s]); else vardiv=1; xij=ME(Delta,s,i-1)/vardiv; if (fabs(xij)>test[(*sim)*(i-1)+k]) test[(*sim)*(i-1)+k]=fabs(xij); if (k<50) {l=k*(*pm)+i-1; simUt[l*(*nmgt)+s]=xij;} c=*pm+i-1; test[(*sim)*c+k]=test[(*sim)*c+k]+xij*xij*dtime; c=2*(*pm)+i-1; xij=xij/sqrt(robvarcum[i*(*nmgt)+s]); if (fabs(xij)>test[(*sim)*c+k]) test[(*sim)*c+k]=fabs(xij); } } } // }}} } // modelmatrix loop }}} // }}} mat_zeros(X); mat_zeros(cummat); vec_zeros(risk); mat_zeros(Z); mat_zeros(XPZ); R_CheckUserInterrupt(); // /* LWY cumulative residuals versus covariates */ if (*cumresid>0) // {{{ { int detail=0; for (l=0;l2) { R_CheckUserInterrupt(); // Rprintf(" %d %d %d %d ================ \n",ptot,ant[l],inXorZ[l],inXZ[l]); // for (j=0;j=1) { // {{{ mat_zeros(X);mat_zeros(Z); mat_zeros(A); mat_zeros(cummat1); mat_zeros(A); mat_zeros(cumX1); mat_zeros(XPZ); mat_zeros(cumZP1); vec_zeros(weightmg); vec_zeros(weight); vec_zeros(offset); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { for(j=0;j=0) ) ci=ci-1; } // }}} //Rprintf("%d %d %d %lf %lf %lf \n",s,ci,id[ci],start[ci],stop[ci],time); vec_zeros(rowX); vec_zeros(rowZ); vec_zeros(vtmp2); if (s<1) // {{{ modifying design for next time points while ((stop[ci]=0) ) { for(j=0;j -2) { // head_matrix(X); // head_matrix(Z); // print_mat(Z); // print_ma // for (i=0;i<*antpers;i++) random=random+ME(X,i,0); // Rprintf(" %d %lf \n",s,random); // } if (*model==0) for (i=0;i<*antpers;i++) VE(dMGt[s],i)=dmgresid[i*(*nmgt)+s]; if (*stratum==0) invertS(A,AI,*silent); if (ME(AI,0,0)==0 && *stratum==0 && *silent==0) { Rprintf("additive design X'X not invertible at time (number, value): %d %lf \n",s,time); print_mat(A); } if (*stratum==1) { for (k=0;k<*px;k++) if (fabs(ME(A,k,k))<0.000001) ME(AI,k,k)=0; else ME(AI,k,k)=1/ME(A,k,k); } MxA(cumX1,AI,cumXAI1); if (s < 0) { // printf(" %d \n",s); head_matrix(A); head_matrix(AI); head_matrix(cumX1); head_matrix(cummat1); } /* observed increment */ vM(cummat1,dMGt[s],respm1); for (j=0;junitimetestOBS[l]) unitimetestOBS[l]=fabs(xij); } R_CheckUserInterrupt(); /* simulation of testprocesses and teststatistics */ // {{{ // Rprintf("Simulations start N= %d \n",*sim); if (detail==1) Rprintf("Simulations start \n"); for (k=0;k<*sim;k++) { // {{{ R_CheckUserInterrupt(); for (i=0;i<*antclust;i++) VE(rvec,i)=norm_rand(); vM(modMGz,rvec,Deltaz); vM(modMGzosdt,rvec,Deltazsd); for (j=0;junitest[(*sim)*(l)+k]) unitest[(*sim)*(l)+k]=fabs(xij); xij=VE(Deltazsd,j); if (fabs(xij)>simcumz[(*sim)*(l)+k]) simcumz[(*sim)*(l)+k]=fabs(xij); } } // }}} /* k=1..antsim */ // }}} R_CheckUserInterrupt(); // {{{ free allokering local allocation LWY style cum res free_mats(&S1,&dS1,&cumX1,&cumXAI1,&cumZP1,&tmp21,&cummat1,&modMGz,&modMGzosdt,NULL); free_vecs(&vtmp2,&vtmp1,&cumdB1,&VdB1,&respm1,&Deltaz,&Deltazsd,&tmpM1z,NULL); for (k=0;k<*antclust;k++) free_vec(dB1[k]); for (k=0;k<*antclust;k++) free_vec(dBgam[k]); // }}} } /* l=0,...,ptot */ } // }}} cumresid=1 PutRNGstate(); /* to use R random normals */ // {{{ // freeing variables for (i=0;i<*nmgt;i++) { free_vec(dMGt[i]); // free_vec(dNt[i]); free_mat(St[i]); } for (i=0;i<*antclust;i++) { free_mat(modelMGT[i]); free_vec(gammaiid[i]); free_vec(cumA[i]); } free_mats(&cumX,&Delta,&tmpM1,&Z,&X,&A,&AI,&cumXAI,&cumZP,&XPZ,&tmp2,&dS,&S,&cummat,NULL); // free_mats(&AIXZ,NULL); free_vecs(&weightmg,&weight,&offset,&vtmp,&cumdB,&dB,&VdB,&respm,&tmpv1,&cum,&dA,&xtilde,&xi,&rowX, &rowcum,&difX,&zi,&gamma,&rowZ,&vecX,&risk,&Gbeta,&rvec,NULL); free(cluster); // }}} } // }}} timereg/src/prop-odds.c0000644000176200001440000005032114421510301014540 0ustar liggesusers//#include #include #include #include "matrix.h" #include #include void transsurv(double *times,int *Ntimes,double *designX,int *nx,int *px,int *antpers,double *start,double *stop,double *betaS,int *Nit,double *cu,double *vcu,double *Iinv, double *Vbeta,int *detail,int *sim,int *antsim,int *rani,double *Rvcu,double *RVbeta,double *test,double *testOBS,double *Ut,double *simUt,double *Uit,int *id,int *status, int *weighted,int *ratesim,double *score,double *dhatMit,double *dhatMitiid,int *retur,double *loglike,int *profile,int *sym,int *baselinevar,int *clusters,int *antclust,double *biid,double *gamiid) //double *designX,*times,*betaS,*start,*stop,*cu,*Vbeta,*RVbeta,*vcu,*Rvcu,*Iinv,*test,*testOBS,*Ut,*simUt,*Uit,*score,*dhatMit,*dhatMitiid,*loglike,*biid,*gamiid; //int *nx,*px,*antpers,*Ntimes,*Nit,*detail,*sim,*antsim,*rani,*id,*status,*weighted,*ratesim,*retur,*profile,*sym,*baselinevar,*clusters,*antclust; { // {{{ setting up matrix *ldesignX,*WX,*ldesignG,*CtVUCt,*A,*AI; matrix *dYI,*Ct,*dM1M2,*M1M2t,*COV,*ZX,*ZP,*ZPX; matrix *tmp1,*tmp2,*tmp3,*dS1,*SI,*dS2,*S2,*S2pl,*dS2pl,*M1,*VU,*ZXAI,*VUI; matrix *d2S0,*RobVbeta,*tmpM1,*Utt,*S1t,*S1start,*tmpM2,*et,*gt,*qt; matrix *St[*Ntimes],*M1M2[*Ntimes],*C[*Ntimes],*ZXAIs[*Ntimes],*dYIt[*Ntimes]; matrix *dotwitowit[*antpers],*W3t[*antclust],*W4t[*antclust],*W2t[*antclust],*AIxit[*antpers],*Uti[*antclust],*d2G[*Ntimes],*Delta,*Delta2; vector *Ctt,*lht,*S1,*dS0,*S0t,*S0start,*dA,*VdA,*dN,*MdA,*delta,*zav,*dlamt,*plamt,*dG[*Ntimes], *S1star; vector *xav,*difxxav,*xi,*xipers,*zi,*U,*Upl,*beta,*xtilde; vector *Gbeta,*zcol,*one,*difzzav,*difZ; vector *offset,*weight,*ZXdA[*Ntimes],*varUthat[*Ntimes],*Uprofile; vector *ahatt,*risk,*tmpv1,*tmpv2,*rowX,*rowZ,*difX,*VdB; vector *W2[*antclust],*W3[*antclust],*reszpbeta,*res1dim,*dAt[*Ntimes]; vector *dLamt[*antpers]; int *pg=calloc(1,sizeof(int)),c,robust=1,pers=0,ci=0,i,j,k,l,s,t,it,count,*ipers=calloc(*Ntimes,sizeof(int)); int *cluster=calloc(*antpers,sizeof(int)); double RR,S0star,time,dummy,ll; double S0,tau,random,scale,sumscore; // double norm_rand(); // void GetRNGstate(),PutRNGstate(); pg[0]=1; for (j=0;j<*antpers;j++) { malloc_vec(*Ntimes,dLamt[j]); malloc_mat(*Ntimes,*px,dotwitowit[j]); malloc_mat(*Ntimes,*px,AIxit[j]); } for (j=0;j<*antclust;j++) { malloc_mat(*Ntimes,*pg,W3t[j]); malloc_mat(*Ntimes,*pg,W4t[j]); malloc_mat(*Ntimes,*px,W2t[j]); malloc_vec(*px,W2[j]); malloc_vec(*pg,W3[j]); malloc_mat(*Ntimes,*px,Uti[j]); } for(j=0;j<*Ntimes;j++) { malloc_mat(*px,*pg,dYIt[j]); malloc_vec(*px,dAt[j]); malloc_mat(*px,*pg,C[j]); malloc_mat(*pg,*px,M1M2[j]); malloc_mat(*pg,*px,ZXAIs[j]); malloc_vec(*pg,ZXdA[j]); malloc_mat(*px,*px,St[j]); malloc_mat(*px,*px,d2G[j]); malloc_vec(*px,dG[j]); malloc_vec(*px,varUthat[j]); } malloc_mat(*Ntimes,*pg,tmpM1); malloc_mat(*Ntimes,*px,S1t); malloc_mat(*Ntimes,*px,tmpM2); malloc_mat(*Ntimes,*px,S1start); malloc_mat(*Ntimes,*px,et); malloc_mat(*Ntimes,*px,gt); malloc_mat(*Ntimes,*px,qt); malloc_mat(*Ntimes,*px,Utt); malloc_mat(*Ntimes,*pg,Delta); malloc_mat(*Ntimes,*px,Delta2); malloc_mats(*antpers,*px,&WX,&ldesignX,NULL); malloc_mats(*antpers,*pg,&ZP,&ldesignG,NULL); malloc_mats(*px,*px,&COV,&A,&AI,&M1,&CtVUCt,NULL); malloc_mats(*px,*px,&d2S0,&RobVbeta,&tmp1,&tmp2,&dS1,&S2,&dS2,&S2pl,&dS2pl,&SI,&VU,&VUI,NULL); malloc_mats(*pg,*px,&ZXAI,&ZX,&dM1M2,&M1M2t,NULL); malloc_mats(*px,*pg,&tmp3,&ZPX,&dYI,&Ct,NULL); malloc_vec(*Ntimes,S0t); malloc_vec(*Ntimes,S0start); malloc_vec(*Ntimes,lht); malloc_vec(1,reszpbeta); malloc_vec(1,res1dim); malloc_vecs(*antpers,&risk,&weight,&plamt,&dlamt,&dN,&zcol,&Gbeta,&one,&offset,NULL); malloc_vecs(*px,&Ctt,&ahatt,&tmpv1,&difX,&rowX,&xi,&xipers,&dA,&VdA,&MdA,NULL); malloc_vecs(*px,&S1,&dS0,&S1star,&xtilde,&xav,&difxxav,NULL); malloc_vecs(*px,&U,&Upl,&beta,&delta,&difzzav,&Uprofile,NULL); malloc_vecs(*pg,&tmpv2,&rowZ,&zi,&difZ,&zav,&VdB,NULL); ll=0; for(j=0;j<*px;j++) VE(beta,j)=betaS[j]; // }}} int timing=0; clock_t c0,c1; c0=clock(); double plamtj,dlamtj; // mat_zeros(ldesignX); for (c=0;c<*nx;c++) for(j=0;j<*px;j++) ME(WX,id[c],j)=designX[j*(*nx)+c]; cu[0]=times[0]; for (it=0;it<*Nit;it++) { vec_zeros(U); vec_zeros(Upl); mat_zeros(S2pl); mat_zeros(S2); ll=0; sumscore=0; mat_zeros(COV); R_CheckUserInterrupt(); if (timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} // for (c=0;c<*nx;c++) for(j=0;j<*px;j++) ME(ldesignX,id[c],j)=designX[j*(*nx)+c]; Mv(WX,beta,Gbeta); for (s=1;s<*Ntimes;s++) {// {{{ time=times[s]; vec_zeros(dS0); mat_zeros(d2S0); mat_zeros(dS1); vec_zeros(S1star); S0star=0; S0=0; vec_zeros(S1); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { // {{{ reading data and computing things if ((start[c]=time)) { for(j=0;j<*px;j++) VE(xi,j)=designX[j*(*nx)+c]; j=id[c]; if (time==stop[c] && status[c]==1) {pers=id[c]; scl_vec_mult(1,xi,xipers);} count=count+1; RR=exp(-VE(Gbeta,j)); scale=(RR+cu[1*(*Ntimes)+s-1]); dummy=1/scale; if (it==((*Nit)-1)) VE(plamt,j)=dummy; plamtj=dummy; dlamtj=dummy*dummy; // VE(dlamt,j)=dlamtj; S0star=S0star-dlamtj; S0=S0+plamtj; // S0p=S0p+VE(risk,j)/(RR+cu[1*(*Ntimes)+s]); // S0cox=S0cox+exp(VE(Gbeta,j)); // scl_vec_mult(-RR,xi,tmpv1); vec_add(tmpv1,dG[s-1],dA); scl_vec_mult(-plamtj,dA,dA); if (it==(*Nit-1)) { if (*profile==0) replace_row(dotwitowit[j],s,xi); else replace_row(dotwitowit[j],s,dA); } scl_vec_mult(plamtj,dA,tmpv1); vec_add(tmpv1,dS0,dS0); if (s<0 && j<5 ) {Rprintf(" %d %d \n",s,j); print_vec(tmpv1); } // 16-10-2014 -dlamtj if (*profile==0) scl_vec_mult(-dlamtj,xi,dA); else scl_vec_mult(-plamtj,dA,dA); vec_add(dA,S1star,S1star); for (i=0;i<*px;i++) for (k=0;k<*px;k++) { ME(dS1,i,k)=ME(dS1,i,k)+VE(xi,i)*VE(tmpv1,k); ME(tmp1,i,k)=(VE(xi,i)*VE(xi,k))*RR; } mat_add(tmp1,d2G[s-1],tmp1); scl_mat_mult(-dlamtj,tmp1,tmp1); for (i=0;i<*px;i++) for (k=0;k<*px;k++) ME(d2S0,i,k)=ME(d2S0,i,k)+ME(tmp1,i,k)+2*scale*(VE(tmpv1,i)*VE(tmpv1,k)); scl_vec_mult(plamtj,xi,xi); vec_add(S1,xi,S1); } else VE(plamt,id[c])=0; } // }}} ipers[s]=pers; if (s==1 && timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: loop Ntimes %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} replace_row(S1t,s,dS0); VE(S0start,s)=S0star; replace_row(S1start,s,S1star); if (it==((*Nit)-1)) { VE(S0t,s)=S0; VE(lht,s)=VE(lht,s-1)-S0star/(S0*S0); } /* Rprintf(" %ld %lf %lf \n",s,VE(lht,s),ME(AI,0,0)); */ scl_vec_mult(S0star,dS0,tmpv1); scl_vec_mult(S0,S1star,dA); vec_subtr(tmpv1,dA,dA); scl_vec_mult(1/S0,dA,dA); if (it==((*Nit)-1)) replace_row(gt,s,dA); scl_vec_mult(-1/(S0*S0),dS0,tmpv1); vec_add(dG[s-1],tmpv1,dG[s]); if (s<0) { Rprintf(" %lf \n",S0); print_vec(scl_vec_mult(1/S0,dS0,NULL)); print_vec(tmpv1); print_vec(dG[s]); } scl_mat_mult(-1/(S0*S0),d2S0,A); for (i=0;i<*px;i++) for (j=0;j<*px;j++) ME(A,i,j)=ME(A,i,j)+2*S0*VE(tmpv1,i)*VE(tmpv1,j); mat_add(d2G[s-1],A,d2G[s]); /* baseline is computed */ cu[1*(*Ntimes)+s]=cu[1*(*Ntimes)+s-1]+(1/S0); if (s<0) Rprintf(" %lf \n",cu[1*(*Ntimes)+s]); /* First derivative of U ======================================== */ // extract_row(ldesignX,pers,xi); scl_vec_mult(1,xipers,xi); scl_vec_mult(1/S0,S1,xav); vec_subtr(xi,xav,difxxav); vec_add(U,difxxav,U); if (it==((*Nit)-1)) if (*profile==0) replace_row(et,s,xav); /* profile version of score */ dummy=1/(exp(-VE(Gbeta,pers))+cu[1*(*Ntimes)+s-1]); scl_vec_mult(-exp(-VE(Gbeta,pers)),xi,tmpv1); vec_add(tmpv1,dG[s-1],tmpv1); scl_vec_mult(-dummy,tmpv1,tmpv1); scl_vec_mult(1/S0,dS0,dA); if (it==((*Nit)-1)) if (*profile==1) replace_row(et,s,dA); vec_subtr(tmpv1,dA,dA); vec_add(Upl,dA,Upl); /* Second derivative S =========================================== */ for (i=0;i<*px;i++) for (k=0;k<*px;k++) ME(dS2pl,i,k)=(VE(xi,i)*VE(xi,k))*exp(-VE(Gbeta,pers)); mat_add(dS2pl,d2G[s-1],dS2pl); scl_mat_mult(-dummy,dS2pl,dS2pl); for (i=0;i<*px;i++) for (k=0;k<*px;k++) ME(dS2pl,i,k)=ME(dS2pl,i,k)+(VE(tmpv1,i)*VE(tmpv1,k)); scl_mat_mult(-1/S0,d2S0,A); scl_vec_mult(1/S0,dS0,dA); for (i=0;i<*px;i++) for (k=0;k<*px;k++) ME(A,i,k)=ME(A,i,k)+(VE(dA,i)*VE(dA,k)); mat_add(A,dS2pl,dS2pl); mat_add(dS2pl,S2pl,S2pl); if (*profile==1) St[s]=mat_copy(S2pl,St[s]); /* simple Second derivative S2 ================================== */ for (i=0;i<*px;i++) for (k=0;k<*px;k++) ME(dS2,i,k)=VE(dS0,i)*VE(S1,k); scl_mat_mult(S0,dS1,M1); /* */ if (s<0) { Rprintf("======================== %lf \n",S0); print_mat(scl_mat_mult(1/(S0*S0),M1,NULL)); print_mat(scl_mat_mult(1/(S0*S0),dS2,NULL)); } mat_subtr(M1,dS2,M1); if (*sym==1) { scl_mat_mult(-1/(S0*S0),M1,M1); mat_transp(M1,dS2); mat_add(M1,dS2,dS2); scl_mat_mult(0.5,dS2,dS2); } else scl_mat_mult(-1/(S0*S0),M1,dS2); if (s<0) print_mat(dS2); mat_add(dS2,S2,S2); if (*profile==0) St[s]=mat_copy(S2,St[s]); /* ============================================ */ /* log-likelihood contributions */ ll=ll+log(dummy)-log(S0); /* scl_mat_mult(1/S0,dS1,dS1); */ if (it==((*Nit)-1)) { // {{{ Ut[s]=time; if (*profile==1) {for (i=1;i<*px+1;i++) Ut[i*(*Ntimes)+s]=VE(Upl,i-1);} else {for (i=1;i<*px+1;i++) Ut[i*(*Ntimes)+s]=VE(U,i-1); } for (i=1;i<*px+1;i++) ME(Utt,s,i-1)=Ut[i*(*Ntimes)+s]; for (j=0;j<*antpers;j++) VE(dLamt[j],s)=VE(plamt,j)/S0; /* // {{{ for (i=0;i<*px;i++) for (j=0;j<*pg;j++) ME(dM1M2,j,i)=VE(dA,i)*VE(difzzav,j); for (i=0;i<*pg;i++) for (j=0;j<*pg;j++) ME(VU,i,j)=ME(VU,i,j)+VE(difzzav,i)*VE(difzzav,j); MxA(AI,ZPX,dYIt[s]); mat_subtr(Ct,dYIt[s],Ct); C[s]=mat_copy(Ct,C[s]); vec_star(dA,dA,VdA); mat_add(dM1M2,M1M2t,M1M2t); M1M2[s]=mat_copy(M1M2t,M1M2[s]); for (k=1;k<=*px;k++) { cu[k*(*Ntimes)+s]=VE(dA,k-1); vcu[k*(*Ntimes)+s]=VE(VdA,k-1)+vcu[k*(*Ntimes)+s-1]; } */ // }}} } // }}} } // }}} /* s= .... Ntimes */ if (timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: loop Ntimes %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} if (*profile==1) scl_mat_mult(-1,S2pl,A); else scl_mat_mult(-1,S2,A); invertS(A,SI,1); if (*profile==1) Mv(SI,Upl,delta); else Mv(SI,U,delta); vec_add(beta,delta,beta); if (*detail==1) { // {{{ Rprintf("====================Iteration %d ==================== \n",it); Rprintf("log-likelihood "); Rprintf(" %lf \n",ll); Rprintf("Estimate beta "); print_vec(beta); if (*profile==1) { Rprintf("modified partial likelihood Score D l"); print_vec(Upl); } if (*profile==0) {Rprintf("simple Score D l"); print_vec(U); } Rprintf("Information -D^2 l\n"); print_mat(SI); if (*profile==1) {Rprintf("simple D2 l"); print_mat(S2pl); } if (*profile==0) {Rprintf("simple D2 l"); print_mat(S2); } }; // }}} for (k=0;k<*px;k++) sumscore= sumscore+ (*profile==1)*fabs(VE(Upl,k))+(*profile==0)*fabs(VE(U,k)); if ((fabs(sumscore)<0.000001) & (it<*Nit-2)) it=*Nit-2; } /* it */ loglike[0]=ll; if (timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: out of loop %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} R_CheckUserInterrupt(); for (s=1;s<*Ntimes;s++) { // {{{ /* computation of q(t) ===================================== */ vec_zeros(xi); for (t=s;t<*Ntimes;t++) { extract_row(gt,t,dA); scl_vec_mult(exp(VE(lht,t))/VE(S0t,t),dA,dA); // if (s<0) {Rprintf("exp %d %d %lf \n",s,t,exp(-VE(lht,t)+VE(lht,s))); print_vec(dA); } vec_add(dA,xi,xi); } scl_vec_mult(exp(-VE(lht,s))/VE(S0t,s),xi,xi); replace_row(qt,s,xi); } // }}} if (timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: q(t) %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} R_CheckUserInterrupt(); for (c=0;c<*antpers;c++) cluster[id[c]]=clusters[c]; if (robust==1) { // {{{ terms for robust variances ============================ for (s=1;s<*Ntimes;s++) { time=times[s]; cu[s]=times[s]; vcu[s]=times[s]; Rvcu[s]=times[s]; Ut[s]=times[s]; extract_row(qt,s,tmpv1); extract_row(et,s,xtilde); for (i=0;i<*antpers;i++) { ci=cluster[i]; extract_row(dotwitowit[i],s,rowX); vec_subtr(rowX,xtilde,rowX); if (s==0) { print_vec(rowX); print_vec(tmpv1); } vec_add(rowX,tmpv1,rowX); if (i==ipers[s]) for (j=0;j<*px;j++) for (k=0;k<*px;k++) ME(VU,j,k)=ME(VU,j,k)+VE(rowX,j)*VE(rowX,k); scl_vec_mult(VE(dLamt[i],s),rowX,xi); vec_subtr(W2[ci],xi,W2[ci]); if (i==ipers[s]) vec_add(rowX,W2[ci],W2[ci]); if (*ratesim==1) {scl_vec_mult(VE(dLamt[i],s),tmpv2,rowZ); vec_subtr(W2[ci],rowZ,W2[ci]);} replace_row(W2t[ci],s,W2[ci]); VE(rowZ,0)=exp(-VE(lht,s))/VE(S0t,s); scl_vec_mult(VE(dLamt[i],s),rowZ,zi); vec_subtr(W3[ci],zi,W3[ci]); if (i==ipers[s]) vec_add(rowZ,W3[ci],W3[ci]); if (*ratesim==1) {scl_vec_mult(VE(dLamt[i],s),rowX,rowX); vec_subtr(W3[ci],rowX,W3[ci]); } replace_row(W3t[ci],s,W3[ci]); if (*retur==1) dhatMit[i*(*Ntimes)+s]=1*(i==pers)-VE(dLamt[i],s); } /* i=1..antpers */ /* Martingale baseret variance */ /* MxA(C[s],VU,tmp3); MAt(tmp3,C[s],CtVUCt); MxA(C[s],SI,tmp3); MxA(tmp3,M1M2[s],COV); for (k=1;k<=*px;k++) { cu[k*(*Ntimes)+s]=cu[k*(*Ntimes)+s-1]+cu[k*(*Ntimes)+s]; vcu[k*(*Ntimes)+s]=vcu[k*(*Ntimes)+s]+ME(CtVUCt,k-1,k-1) +2*ME(COV,k-1,k-1); } */ } /* s=1 ..Ntimes */ R_CheckUserInterrupt(); /* ROBUST VARIANCES Estimation */ for (s=1;s<*Ntimes;s++) { vec_zeros(VdB); extract_row(S1t,s,rowX); scl_vec_mult(-1.0/(VE(S0t,s)*VE(S0t,s)),rowX,xi); vec_add(xi,Ctt,Ctt); replace_col(Ct,0,Ctt); if (s<0) print_vec(Ctt); for (i=0;i<*antclust;i++) { Mv(SI,W2[i],tmpv1); vM(Ct,tmpv1,rowZ); extract_row(W3t[i],s,zi); VE(zi,0)= exp(VE(lht,s))*VE(zi,0); vec_add(rowZ,zi,zi); if (i==-5) print_vec(zi); replace_row(W4t[i],s,zi); biid[i*(*Ntimes)+s]=VE(zi,0); vec_star(zi,zi,rowZ); vec_add(rowZ,VdB,VdB); extract_row(W2t[i],s,xi); Mv(St[s],tmpv1,rowX); vec_add(xi,rowX,tmpv1); replace_row(Uti[i],s,tmpv1); vec_star(tmpv1,tmpv1,xi); vec_add(xi,varUthat[s],varUthat[s]); if (s==1) { for (j=0;j<*px;j++) { gamiid[j*(*antclust)+i]=VE(W2[i],j); for (k=0;k<*px;k++) ME(RobVbeta,j,k)=ME(RobVbeta,j,k)+VE(W2[i],j)*VE(W2[i],k); } } if (*retur==1 && j==0) { // {{{ for (j=0;j<*antpers;j++) { extract_row(WX,j,xi); // extract_row(ldesignG,j,zi); dummy=exp(VE(Gbeta,j)); // *VE(weight,j)*VE(offset,j); scl_vec_mult(dummy,xi,xtilde); replace_row(ldesignX,j,xtilde); } Mv(ldesignX,dAt[s],dlamt); for (j=0;j<*antpers;j++) {extract_row(ldesignG,j,zi); scl_vec_mult(VE(dlamt,j),zi,zi); replace_row(ZP,j,zi);} Mv(ZP,W2[ci],reszpbeta); Mv(dYIt[s],W2[ci],xi); Mv(ldesignX,xi,res1dim); dhatMitiid[i*(*Ntimes)+s]=dhatMit[i*(*Ntimes)+s]-(VE(reszpbeta,0)- VE(res1dim,0)); } // }}} /* retur ==1 */ } /* i =1 ..Antpers */ for (k=1;k<*pg+1;k++) Rvcu[k*(*Ntimes)+s]=VE(VdB,k-1); for (k=1;k<*pg+1;k++) vcu[k*(*Ntimes)+s]=VE(VdB,k-1); } /* s=1 ..Ntimes */ MxA(RobVbeta,SI,tmp1); MxA(SI,tmp1,RobVbeta); } // }}} /* Robust =1 , default */ // for (i=0;i<*antpers;i++) print_vec(W2[i]); // for (i=0;i<1;i++) print_vec(dLamt[i]); // print_vec(dLamt[0]); if (timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: variance %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} MxA(VU,SI,tmp1); MxA(SI,tmp1,VU); for(j=0;j<*px;j++) { betaS[j]= VE(beta,j); if (*profile==1) score[j]=VE(Upl,j); else score[j]=VE(U,j); for (k=0;k<*px;k++){ Iinv[k*(*px)+j]=ME(SI,j,k); Vbeta[k*(*px)+j]=-ME(VU,j,k); RVbeta[k*(*px)+j]=-ME(RobVbeta,j,k); } } R_CheckUserInterrupt(); if (*sim==1) { // {{{ // Rprintf("Simulations start N= %d \n",*antsim); GetRNGstate(); /* to use R random normals */ tau=times[*Ntimes-1]-times[0]; for (i=1;i<=*pg;i++) VE(rowZ,i-1)=cu[i*(*Ntimes)+(*Ntimes-1)]; /* Beregning af OBS teststorrelser */ for (s=1;s<*Ntimes;s++) { time=times[s]-times[0]; for (i=1;i<=*pg;i++) { VE(zi,i-1)=fabs(cu[i*(*Ntimes)+s])/sqrt(Rvcu[i*(*Ntimes)+s]); if (VE(zi,i-1)>testOBS[i-1]) testOBS[i-1]=VE(zi,i-1); } scl_vec_mult(time/tau,rowZ,difZ); for (i=1;i<=*pg;i++) VE(zi,i-1)=cu[i*(*Ntimes)+s]; vec_subtr(zi,difZ,difZ); for (i=0;i<*pg;i++) { VE(difZ,i)=fabs(VE(difZ,i)); l=(*pg+i); if (VE(difZ,i)>testOBS[l]) testOBS[l]=VE(difZ,i);} if (*weighted>=1) { /* sup beregnes i R */ if ((s>*weighted) && (s<*Ntimes-*weighted)) {extract_row(Utt,s,rowX); for (i=0;i<*px;i++) VE(rowX,i)=VE(rowX,i)/sqrt(VE(varUthat[s],i)); replace_row(Utt,s,rowX); /* scaled score process */ } else {vec_zeros(rowX); replace_row(Utt,s,rowX);} } for (k=1;k<=*px;k++) Ut[k*(*Ntimes)+s]=ME(Utt,s,k-1); } /*s=1..Ntimes Beregning af obs teststorrelser */ for (k=1;k<=*antsim;k++) { mat_zeros(Delta); mat_zeros(Delta2); for (i=0;i<*antclust;i++) { /* random=gasdev(&idum); */ random=norm_rand(); scl_mat_mult(random,W4t[i],tmpM1); mat_add(tmpM1,Delta,Delta); scl_mat_mult(random,Uti[i],tmpM2); mat_add(tmpM2,Delta2,Delta2); } extract_row(Delta,*Ntimes-1,zav); for (s=1;s<*Ntimes;s++) { time=times[s]-times[0]; scl_vec_mult(time/tau,zav,zi); extract_row(Delta,s,rowZ); vec_subtr(rowZ,zi,difZ); for (i=0;i<*pg;i++) { VE(difZ,i)=fabs(VE(difZ,i)); l=(*pg+i); if (VE(difZ,i)>test[l*(*antsim)+k-1]) test[l*(*antsim)+k-1]=VE(difZ,i); VE(zi,i)=fabs(ME(Delta,s,i))/sqrt(Rvcu[(i+1)*(*Ntimes)+s]); if (VE(zi,i)>test[i*(*antsim)+k-1]) test[i*(*antsim)+k-1]=VE(zi,i); } if (*weighted>=1) { extract_row(Delta2,s,xi); if ((s>*weighted) && (s<*Ntimes-*weighted)) { for (i=0;i<*px;i++) {VE(xi,i)=fabs(ME(Delta2,s,i))/sqrt(VE(varUthat[s],i)); if (VE(xi,i)>simUt[i*(*antsim)+k-1]) simUt[i*(*antsim)+k-1]=VE(xi,i); } if (k<50) { for (i=0;i<*px;i++) { l=(k-1)*(*px)+i; Uit[l*(*Ntimes)+s]=ME(Delta2,s,i)/sqrt(VE(varUthat[s],i));}} } } /* weigted score */ else { extract_row(Delta2,s,xi); for (i=0;i<*px;i++) { if (fabs(VE(xi,i))>simUt[i*(*antsim)+k-1]) simUt[i*(*antsim)+k-1]=fabs(VE(xi,i)); } if (k<50) { for (i=0;i<*px;i++) { l=(k-1)*(*px)+i; Uit[l*(*Ntimes)+s]=ME(Delta2,s,i);}} } /* else wscore=0 */ } /* s=1..Ntims */ } /* k=1..antsim */ PutRNGstate(); /* to use R random normals */ } // }}} sim==1 // {{{ freeing free_mats(&tmpM1,&S1t,&tmpM2,&S1start,&et,>,&qt,&Utt,&Delta,&Delta2,&ldesignX,&ZP,&WX,&ldesignG,&COV,&A,&AI,&M1,&CtVUCt ,&d2S0,&RobVbeta,&tmp1,&tmp2,&dS1,&S2,&dS2,&S2pl,&dS2pl,&SI,&VU,&VUI, &ZXAI,&ZX,&dM1M2,&M1M2t ,&tmp3,&ZPX,&dYI,&Ct,NULL); free_vecs(&S0t ,&S0start,&lht ,&reszpbeta,&res1dim, &risk,&weight,&plamt,&dlamt,&dN,&zcol,&Gbeta,&one,&offset ,&Ctt,&ahatt,&tmpv1,&difX,&rowX,&xi,&xipers,&dA,&VdA,&MdA,&S1,&dS0,&S1star,&xtilde,&xav,&difxxav ,&U,&Upl,&beta,&delta,&difzzav,&Uprofile, &tmpv2,&rowZ,&zi,&difZ,&zav,&VdB,NULL); for (j=0;j<*antpers;j++) { free_vec(dLamt[j]); free_mat(dotwitowit[j]); free_mat(AIxit[j]); } for (j=0;j<*antclust;j++) { free_mat(W3t[j]); free_mat(W4t[j]); free_mat(W2t[j]);free_vec(W2[j]); free_vec(W3[j]); free_mat(Uti[j]); } for (j=0;j<*Ntimes;j++) { free_mat(dYIt[j]); free_vec(dAt[j]); free_mat(C[j]);free_mat(M1M2[j]);free_mat(ZXAIs[j]); free_vec(ZXdA[j]); free_mat(St[j]); free_mat(d2G[j]); free_vec(dG[j]); free_vec(varUthat[j]); } free(ipers); free(pg); free(cluster); // }}} } timereg/src/matrix.h0000644000176200001440000001721514664040562014167 0ustar liggesusers #define USE_FC_LEN_T #include #include #include #include #include #include #include #include #include #include #include #include #include #ifndef FCONE #define FCONE #endif #define ME(matrix,row,col) (((matrix)->entries)[(col) * ((matrix)->nr) + (row)]) #define ME3(matrix3,dim1,row,col) (((matrix3)->entries)[(dim1)*(((matrix3)->nr)*((matrix3)->nc))+(col)*((matrix3)->nr)+(row)]) #define VE(vector,index) (((vector)->entries)[(index)]) #define oops(s) {error((s));} #define max(a,b) ( ((a) > (b)) ? (a) : (b) ) #define min(a,b) ( ((a) > (b)) ? (b) : (a) ) #define malloc_mat(NR, NC, M) { (M) = R_Calloc(1,matrix); ((M)->nr) = (NR); ((M)->nc) = (NC); ((M)->entries) = R_Calloc(((NR)*(NC)) , double);} #define malloc_mat3(DIM,NR, NC, M3) {(M3) = R_Calloc(1,matrix); ((M3)->dim)=(DIM); ((M3)->nr) = (NR); ((M3)->nc) = (NC); ((M3)->entries) = R_Calloc(((DIM)*(NR)*(NC)) , double);} #define malloc_vec(L, V) { (V) = R_Calloc(1,vector); ((V)->length) = (L); ((V)->entries) = R_Calloc((L), double);} typedef struct{ int dim; int nr; int nc; double *entries; } matrix3; typedef struct{ int nr; int nc; double *entries; } matrix; typedef struct{ int length; double *entries; } vector; typedef struct{ double timec; int callc; } counter; /* void malloc_mat(int *nrow, int *ncol, matrix *M); */ void free_mat3(matrix3 *M); void free_mat(matrix *M); /* void malloc_vec(int *length, vector *V); */ void free_vec(vector *V); int nrow_matrix(matrix *M); int ncol_matrix(matrix *M); int length_vector(vector *v); void print_a_matrix(matrix *M); void MtM(matrix *M, matrix *A); void cumsumM(matrix *M, matrix *Mout,int rev,int weighted,double *weights); void cumsumM1pM2(matrix *M1, matrix *M2,matrix *At[],int rev,int weighted,double *weights,int nindex, int *index); void cumsumMpM(matrix *M1,matrix *At[],int rev,int weighted,double *weights, int nindex,int *index); void invertSPD(matrix *A, matrix *AI); void invertSPDunsafe(matrix *A, matrix *AI); void Mv(matrix *M, vector *v1, vector *v2); void vM(matrix *M, vector *v1, vector *v2); vector *vec_star(vector *v1, vector *v2, vector *v3); double vec_sum(vector *v); double vec_prod(vector *v1,vector *v2); double vec_min(vector *v, int *imin); void mat_zeros(matrix *M); void vec_zeros(vector *v); void print_mat(matrix *M); void print_vec(vector *v); vector *extract_row(matrix *M, int row_to_get, vector *v); void replace_row(matrix *M, int row_to_set, vector *v); void vec_add(vector *v1, vector *v2, vector *v3); vector *scl_vec_mult(double scalar, vector *v1, vector *v2); matrix *scl_mat_mult(double scalar, matrix *m1, matrix *m2); matrix *mat_copy(matrix *m1, matrix *m2); vector *vec_copy(vector *v1, vector *v2); void mat_subsec(matrix *m1, int rowStart, int colStart, int rowStop, int colStop, matrix *m2); matrix *mat_transp(matrix *m1, matrix *m2); void vec_subtr(vector *v1, vector *v2, vector *v3); void mat_subtr(matrix *m1, matrix *m2, matrix *m3); void mat_add(matrix *m1, matrix *m2, matrix *m3); void vec_add_mult(vector *v1, vector *v2, double s, vector *v3); void MtA(matrix *M, matrix *A, matrix *Mout); void MAt(matrix *M, matrix *A, matrix *Mout); void invert(matrix *A, matrix *AI); void invertS(matrix *A, matrix *AI,int silent); void invertUnsafe(matrix *A, matrix *AI); void invertUnsafeS(matrix *A, matrix *AI,int silent); void cholesky(matrix *A, matrix *AI); void choleskyunsafe(matrix *A, matrix *AI); void MxA(matrix *M, matrix *A, matrix *Mout); void R_CheckUserInterrupt(void); void print_clock(clock_t *intime,int i); void update_clock(clock_t *intime, counter *C); void zcntr(counter *C); void print_counter(int i, counter *C); void head_matrix(matrix *M); void head_vector(vector *V); void identity_matrix(matrix *M); void malloc_mats(int nrow, int ncol, ...); void malloc_vecs(int length, ...); void free_mats(matrix **M, ...); void free_vecs(vector **V, ...); vector *vec_ones(vector *v); void replace_col(matrix *M, int col_to_set, vector *v); vector *extract_col(matrix *M, int col_to_get, vector *v); void Cpred(double *cum,int *nx,int *px,double *xval,int *nxval,double *pred,int *tminus); void sindex(int *index, double *jump, double *eval, int *njump, int *neval,int *strict); void nclusters(int *npers,int *clusters, int *nclust, int *mclust); void clusterindex(int *clusters, int *nclust,int *npers,int *idclust, int *clustsize, int *mednum,int *num,int *firstclustid); void clusterindexdata(int *clusters,int *nclust,int *npers,int *idclust,int *clustsize,int *mednum, int *num,double *data, int *p,double *nydata); void comptest(double *times,int *Ntimes,int *px,double *cu,double *vcu, double *vcudif,int *antsim,double *test,double *testOBS, double *Ut,double *simUt,matrix **W4t,int *weighted,int *antpers); double tukey(double x,double b); void smoothB(double *designX,int *nx,int *p,double *bhat,int *nb,double *b,int *degree,int *coef); void comptestfunc(double *times,int *Ntimes,int *px,double *cu,double *vcu, double *vcudif,int *antsim,double *test,double *testOBS, double *Ut,double *simUt,matrix **W4t,int *weighted,int *antpers, double *gamma,int *line,double *timepowtest); void itfitsemi(double *times,int *Ntimes,double *x,int *delta,int *cause,double *KMc, double *z,int *antpers,int *px,int *Nit,double *score,double *hess, double *est,double *var,int *sim,int *antsim,int *rani,double *test, double *testOBS,double *Ut,double *simUt,int *weighted, double *gamma, double *vargamma,int *semi,double *zsem,int *pg,int *trans,double *gamma2, int *CA,int *line,int *detail,double *biid,double *gamiid,int *resample, double *timepow,int *clusters,int *antclust,double *timepowtest,int *silent,double *convc, double *weight,double *entry,double *trunkp,int *estimator,int *fixgamma ,int *stratum, int *ordertime,int *robust,double *ssf,double *KMtimes, double *gamscore,double *Dscore,int *monotone); void bubble_sort(double *val,int *list,int n); void LevenbergMarquardt(matrix *S,matrix *SI,vector *U,vector *delta,double *lm,double *step); void readXt2(int *antpers,int *nx,int *p,double *designX, double *start,double *stop,int *status,int pers,matrix *X,double time); void readXt(int *antpers,int *nx,int *p,double *designX,double *start,double *stop, int *status,int pers,matrix *X,double time,int *clusters,int *cluster,int *id) ; void readXZt(int *antpers,int *nx,int *px,double *designX,int *pg,double *designG, double *start,double *stop,int *status,int pers,matrix *X, matrix *WX,matrix *Z,matrix *WZ,double time,int *clusters, int *cluster,int *ls,int stat,int l,int *id,int s,int medw); void readXZtsimple(int *antpers,int *nx,int *px,double *designX,int *pg,double *designG, double *start,double *stop,int *status,int pers,matrix *X, matrix *Z,double time, int s, int *id); void resmeansemi(double *times,int *Ntimes,double *x,int *delta,int *cause, double *KMc,double *z,int *antpers,int *px,int *Nit, double *score,double *hess,double *est,double *var,int *sim, int *antsim,int *rani,double *test,double *testOBS,double *Ut, double *simUt,int *weighted,double *gamma,double *vargamma,int *semi, double *zsem,int *pg,int *trans,double *gamma2,int *CA, int *line,int *detail,double *biid,double *gamiid,int *resample, double *timepow,int *clusters,int *antclust,double *timepowtest,int *silent,double *convc,double *tau, int *funcrestrict,int *causeS, double *weights,double *KMtimes); timereg/src/aalenC.c0000644000176200001440000001070614421510301014017 0ustar liggesusers#include //#include #include #include #include "matrix.h" void robaalenC(double *times,int *Ntimes,double *designX,int *nx,int *p,int *antpers,double *start,double *stop,double *cu,double *vcu, double *robvcu,int *sim,int *antsim,int *retur,double *cumAit,double *test,int *rani,double *testOBS,int *status, double *Ut,double *simUt,int *id,int *weighted,int *robust,int *covariance,double *covs,int *resample, double *Biid,int *clusters,int *antclust,double *loglike,int *silent) //double *designX,*times,*start,*stop,*cu,*vcu,*robvcu,*cumAit,*test,*testOBS,*Ut,*simUt,*covs,*Biid,*loglike; //int *nx,*p,*antpers,*Ntimes,*sim,*retur,*rani,*antsim,*status,*id,*covariance, *weighted,*robust,*resample,*clusters,*antclust,*silent; { // {{{ matrix *ldesignX, *QR, *R, *A, *AI, *Vcov; matrix *cumAt[*antclust]; vector *diag,*dB,*dN,*VdB,*xi,*rowX,*rowcum,*difX,*vtmp; vector *cumhatA[*antclust],*cumA[*antclust],*cum; int ci,i,j,k,l,s,c,count,pers=0,*cluster=calloc(*antpers,sizeof(int)); double time,ahati,*vcudif=calloc((*Ntimes)*(*p+1),sizeof(double)); if (*robust==1) { for (i=0;i<*antclust;i++) { malloc_vec(*p,cumhatA[i]); malloc_vec(*p,cumA[i]); if (*sim==1) malloc_mat(*Ntimes,*p,cumAt[i]); } } /* print_clock(&debugTime, 0); */ malloc_mat(*antpers,*p,ldesignX); malloc_mat(*p,*p,QR); malloc_mat(*p,*p,Vcov); malloc_mat(*p,*p,A); malloc_mat(*p,*p,AI); malloc_mat(*antpers,*p,R); malloc_vec(*antpers,dN); malloc_vecs(*p,&cum,&diag,&dB,&VdB,&xi,&rowX,&rowcum,&difX,&vtmp,NULL); // for (j=0;j<*antpers;j++) cluster[j]=0; /* print_clock(&debugTime, 1); */ R_CheckUserInterrupt(); for (s=1;s<*Ntimes;s++){ time=times[s]; mat_zeros(ldesignX); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++){ if ((start[c]=time)) { for(j=0;j<*p;j++) { ME(ldesignX,id[c],j) = designX[j*(*nx)+c]; } cluster[id[c]]=clusters[c]; if (time==stop[c] && status[c]==1) { pers=id[c]; } count=count+1; } } // readXt(antpers,nx,p,designX,start,stop,status,pers,ldesignX,time,clusters,cluster,id); MtM(ldesignX,A); invertS(A,AI,silent[0]); if (ME(AI,0,0)==0.0 && *silent==0){ Rprintf(" X'X not invertible at time %lf \n",time); } if (s < -1) { print_mat(AI); print_mat(A); } extract_row(ldesignX,pers,xi); Mv(AI,xi,dB); vec_star(dB,dB,VdB); vec_star(xi,dB,vtmp); ahati = vec_sum(vtmp); loglike[0]=loglike[0]-ahati/(time-times[s-1]); for (k=1;k<*p+1;k++) { cu[k*(*Ntimes)+s]=cu[k*(*Ntimes)+s-1]+VE(dB,k-1); vcu[k*(*Ntimes)+s]=vcu[k*(*Ntimes)+s-1]+VE(VdB,k-1); VE(cum,k-1)=cu[k*(*Ntimes)+s]; } cu[s]=time; vcu[s]=time; robvcu[s]=time; if (*robust==1 || *retur==1) { vec_zeros(VdB); mat_zeros(Vcov); for (i=0;i<*antpers;i++) { ci=cluster[i]; extract_row(ldesignX,i,xi); ahati=vec_prod(xi,dB); Mv(AI,xi,rowX); if (*robust==1) { if (i==pers) { vec_add(rowX,cumhatA[ci],cumhatA[ci]); } scl_vec_mult(ahati,rowX,rowX); vec_add(rowX,cumA[ci],cumA[ci]); } if (*retur==1){ cumAit[i*(*Ntimes)+s]= cumAit[i*(*Ntimes)+s]+1*(i==pers)-ahati; } } if (*robust==1) { for (i=0;i<*antclust;i++) { vec_subtr(cumhatA[i],cumA[i],difX); if (*sim==1) replace_row(cumAt[i],s,difX); vec_star(difX,difX,vtmp); vec_add(vtmp,VdB,VdB); if (*resample==1) { for (k=0;k<*p;k++) {l=i*(*p)+k; Biid[l*(*Ntimes)+s]=VE(difX,k);} } if (*covariance==1) { for (k=0;k<*p;k++) for (c=0;c<*p;c++) ME(Vcov,k,c) = ME(Vcov,k,c) + VE(difX,k)*VE(difX,c); } } for (k=1;k<*p+1;k++) { robvcu[k*(*Ntimes)+s]=VE(VdB,k-1); if (*covariance==1) { for (c=0;c<*p;c++) { l=(k-1)*(*p)+c; covs[l*(*Ntimes)+s]=ME(Vcov,k-1,c); } } } } } /* if robust==1 || retur==1*/ R_CheckUserInterrupt(); } /* s = 1..Ntimes */ R_CheckUserInterrupt(); if (*sim==1) { comptest(times,Ntimes,p,cu,robvcu,vcudif,antsim,test,testOBS,Ut,simUt,cumAt,weighted,antclust); } cu[0]=times[0]; vcu[0]=times[0]; robvcu[0]=times[0]; free_vecs(&dN,&cum,&diag,&dB,&VdB,&xi,&rowX,&rowcum,&difX,&vtmp,NULL); free_mats(&ldesignX,&QR,&Vcov,&A,&AI,&R,NULL); if (*robust==1){ for (i=0;i<*antclust;i++) { free_vec(cumA[i]); free_vec(cumhatA[i]); if (*sim==1) free_mat(cumAt[i]); } } free(cluster); free(vcudif); } // }}} timereg/src/aalen.c0000644000176200001440000006242614611733036013737 0ustar liggesusers#include #include #include #include "matrix.h" #include #include void D2lapsf(double y, double x, double z, double *zz) { zz[0]= pow(x,y)* pow(x+z,(-y-1))* (y* log(x+z)-y* log(x)-1) ; zz[1]= y* pow(x,(y-1))* pow(x+z,(-y-2))*(x-y* z) ; zz[2]= y* (y+1)* pow(x,y)*pow((x+z),(-y-2)); zz[3]= pow(y,2)* (y+1)* pow(x,(y-1))* pow(x+z,(-y-2))+(-y-2)* y* (y+1)* pow(x,y)* pow(x+z,(-y-3)); zz[4]= y* pow(x,y)* pow(x+z,(-y-2))+(y+1)*pow(x,y)* pow(x+z,(-y-2))+y* (y+1)* pow(x,y) *log(x)* pow(x+z,(-y-2))-y *(y+1)* pow(x,y)* pow(x+z,(-y-2))* log(x+z); zz[5]= y* (y+1)* (y+2)* (-pow(x,y))* pow(x+z,(-y-3)); } void aalen(double *times,int *Ntimes,double *designX,int *nx,int *p,int *antpers,double *start,double *stop,double *cu,double *vcu,int *status) { // {{{ matrix *ldesignX, *A, *AI; vector *dB, *VdB, *tmpv, *xi; int j,k,s,c,count,pers=0; double time; malloc_mat(*antpers,*p,ldesignX); malloc_mat(*p,*p,A); malloc_mat(*p,*p,AI); malloc_vec(*p,xi); malloc_vec(*p,dB); malloc_vec(*p,VdB); malloc_vec(*p,tmpv); for (s=1;s<*Ntimes;s++){ time=times[s]; mat_zeros(ldesignX); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { for(j=0;j<*p;j++){ ME(ldesignX,count,j) = designX[j*(*nx)+c]; } if (time==stop[c] && status[c]==1) { pers=count; for(j=0;j<*p;j++) { VE(xi,j)=designX[j*(*nx)+c]; } } count=count+1; } } //readXt2(antpers,nx,p,designX,start,stop,status,pers,ldesignX,time); extract_row(ldesignX,pers,xi); MtM(ldesignX,A); invert(A,AI); Mv(AI,xi,dB); vec_star(dB,dB,VdB); if (vec_sum(dB)==0.0){ Rprintf("Aalen:Singular matrix for time=%lf \n",time); } cu[s]=time; vcu[s]=time; for (k=1;k<*p+1;k++) { cu[k*(*Ntimes)+s]=cu[k*(*Ntimes)+s-1]+VE(dB,k-1); vcu[k*(*Ntimes)+s]=vcu[k*(*Ntimes)+s-1]+VE(VdB,k-1); } } cu[0]=times[0]; vcu[0]=times[0]; free_vec(dB); free_vec(VdB); free_mat(ldesignX); free_mat(A); free_mat(AI); free_vec(xi); free_vec(tmpv); } // }}} void robaalen(double *times,int *Ntimes,double *designX,int *nx,int *p,int *antpers,double *start,double *stop,double *cu,double *vcu, double *robvcu,int *sim,int *antsim,int *retur,double *cumAit,double *test,double *testOBS,int *status, double *Ut,double *simUt,int *id,int *weighted,int *robust,int *covariance,double *covs,int *resample, double *Biid,int *clusters,int *antclust,int *silent,double *weights,int *entry,int *mof,double *offsets,int *strata, double *caseweight,int *icase) { // {{{ // {{{ setting up variables and allocating matrix *ldesignX,*wX,*A,*AI,*Vcov; matrix *cumAt[*antclust]; vector *dB,*VdB,*xi,*rowX,*rowcum,*difX,*vtmp; vector *cumhatA[*antclust],*cumA[*antclust],*cum; int invertible,cin,ci=0,i,j,k,l,s,c,count,pers=0, *cluster=calloc(*antpers,sizeof(int)), *idd=calloc(*antpers,sizeof(int)); // int *int0=calloc(*antpers,sizeof(int)); double time,ahati,*vcudif=calloc((*Ntimes)*(*p+1),sizeof(double)); if (*robust==1) { for (i=0;i<*antclust;i++) { malloc_vec(*p,cumhatA[i]); malloc_vec(*p,cumA[i]); if (*sim==1) malloc_mat(*Ntimes,*p,cumAt[i]); } } malloc_mats(*antpers,*p,&ldesignX,&wX,NULL); malloc_mats(*p,*p,&Vcov,&A,&AI,NULL); malloc_vecs(*p,&cum,&dB,&VdB,&xi,&rowX,&rowcum,&difX,&vtmp,NULL); R_CheckUserInterrupt(); for (c=0;c<*nx;c++) cluster[id[c]]=clusters[c]; for (c=0;c<*nx;c++) idd[id[c]]=id[c]; // }}} // for (c=0;(c<*nx);c++) Rprintf(" %lf \n",weights[c]); // Rprintf(" entry \n"); // for (c=0;(c<*nx);c++) Rprintf(" %d \n",entry[c]); // double *zzz=calloc(6,sizeof(double)); // double x=0.11, y=1/3, z=1/3; //for (s=1;s<40000;s++) D2lapsf(x,y,z,zzz); for (s=1;s<*Ntimes;s++){ time=times[s]; vec_zeros(dB); // {{{ reading design and computing matrix products if (s==1) { // {{{ reading start design for (c=0,count=0;((c<*nx) && (count!=*antpers));c++){ if ((start[c]=time)) { for(j=0;j<*p;j++) { ME(ldesignX,id[c],j) = designX[j*(*nx)+c]; ME(wX,id[c],j) = weights[c]*designX[j*(*nx)+c]; } if (time==stop[c] && status[c]==1) { pers=id[c]; } for(j=0;j<*p;j++)for(k=0;k<*p;k++) ME(A,j,k)+=designX[j*(*nx)+c]*designX[k*(*nx)+c]*weights[c]; count=count+1; } } // MtA(ldesignX,wX,A); ci=*nx-1; while ((stop[ci]=0) ) ci=ci-1; } // }}} // Rprintf("%d %d %d %lf %lf %lf \n",s,ci,id[ci],start[ci],stop[ci],time); if (s>1) while ((stop[ci]=0) ) { // Rprintf("ww %d %d %lf %lf %d \n",ci,id[ci],stop[ci],time,entry[ci]); for(j=0;j<*p;j++) VE(xi,j)=designX[j*(*nx)+ci]; if (entry[ci]==1) { replace_row(ldesignX,id[ci],xi); scl_vec_mult(weights[ci],xi,vtmp); replace_row(wX,id[ci],vtmp); } else { replace_row(ldesignX,id[ci],dB); replace_row(wX,id[ci],dB); } for(j=0;j<*p;j++) for(k=0;k<*p;k++) ME(A,j,k)+=entry[ci]*VE(xi,k)*VE(xi,j)*weights[ci]; ci=ci-1; pers=id[ci]; } // }}} // print_mat(ldesignX); print_mat(A); // print_mat(wX); // Rprintf("==================================\n"); // MtM(ldesignX,AI); print_mat(AI); invertS(A,AI,silent[0]); invertible=1; if (fabs(ME(AI,0,0))<0.0000000001 && *strata==0){ invertible=0; if (*silent==0) Rprintf(" X'X not invertible at time %lf %d \n",time,invertible); } if (*strata==1) { for (k=0;k<*p;k++) if (fabs(ME(A,k,k))<0.000001) ME(AI,k,k)=0; else ME(AI,k,k)=1/ME(A,k,k); } if (s < -1) { print_mat(AI); print_mat(A); } extract_row(wX,pers,xi); // scl_vec_mult(weights[ci],xi,xi); // print_vec(xi); Mv(AI,xi,dB); if (*icase==1) { // printf(" %lf \n",caseweight[s-1]); scl_vec_mult(caseweight[s-1],dB,dB); } vec_star(dB,dB,VdB); for (k=1;k<*p+1;k++) { cu[k*(*Ntimes)+s]=cu[k*(*Ntimes)+s-1]+VE(dB,k-1); vcu[k*(*Ntimes)+s]=vcu[k*(*Ntimes)+s-1]+VE(VdB,k-1); VE(cum,k-1)=cu[k*(*Ntimes)+s]; } cu[s]=time; vcu[s]=time; robvcu[s]=time; // for (k=1;k<*p+1;k++) Rprintf(" %lf ",cu[k*(*Ntimes)+s]);Rprintf(" \n"); if (((*robust==1) || (*retur>=1)) ) // {{{ { vec_zeros(VdB); mat_zeros(Vcov); for (i=0;i<*antpers;i++) { cin=cluster[i]; extract_row(ldesignX,i,xi); ahati=vec_prod(xi,dB); extract_row(wX,i,xi); Mv(AI,xi,rowX); if (*robust==1) { if (i==pers) { vec_add(rowX,cumhatA[cin],cumhatA[cin]); } scl_vec_mult(ahati,rowX,rowX); vec_add(rowX,cumA[cin],cumA[cin]); } if (*retur==1) cumAit[i*(*Ntimes)+s]= 1*(i==pers)-ahati; if (*retur==2) cumAit[i]= cumAit[i]+1*(i==pers)-ahati; } if (*robust==1) { for (i=0;i<*antclust;i++) { vec_subtr(cumhatA[i],cumA[i],difX); if (*sim==1) replace_row(cumAt[i],s,difX); vec_star(difX,difX,vtmp); vec_add(vtmp,VdB,VdB); if (*resample==1) { for (k=0;k<*p;k++) {l=i*(*p)+k; Biid[l*(*Ntimes)+s]=VE(difX,k);} } if (*covariance==1) { for (k=0;k<*p;k++) for (c=0;c<*p;c++) ME(Vcov,k,c) = ME(Vcov,k,c) + VE(difX,k)*VE(difX,c); } } for (k=1;k<*p+1;k++) { robvcu[k*(*Ntimes)+s]=VE(VdB,k-1); if (*covariance==1) { for (c=0;c<*p;c++) { l=(k-1)*(*p)+c; covs[l*(*Ntimes)+s]=ME(Vcov,k-1,c); } } } } } // }}} /* if robust==1 || retur==1*/ } /* s = 1..Ntimes */ R_CheckUserInterrupt(); if (*sim==1) { comptest(times,Ntimes,p,cu,robvcu,vcudif,antsim,test,testOBS,Ut,simUt,cumAt,weighted,antclust); } cu[0]=times[0]; vcu[0]=times[0]; robvcu[0]=times[0]; free_vecs(&cum,&dB,&VdB,&xi,&rowX,&rowcum,&difX,&vtmp,NULL); free_mats(&ldesignX,&wX,&Vcov,&A,&AI,NULL); if (*robust==1){ for (i=0;i<*antclust;i++) { free_vec(cumA[i]); free_vec(cumhatA[i]); if (*sim==1) free_mat(cumAt[i]); } } free(cluster); free(idd); free(vcudif); } // }}} void semiaalen(double *alltimes,int *Nalltimes,int *Ntimes,double *designX,int *nx,int *px,double *designG,int *ng,int *pg,int *antpers,double *start,double *stop,int *nb,double *bhat,double *cu,double *vcu,double *Robvcu,double *gamma,double *Vgamma,double *RobVgamma,int *sim,int *antsim,double *test,double *testOBS,int *robust,int *status,double *Ut,double *simUt,int *id,int *weighted,double *cumAit,int *retur,int *covariance,double *covs,int *resample,double *gammaiid,double *Biid,int *clusters,int *antclust,double *intZHZ,double *intZHdN,int *deltaweight,int *silent,double *weights,int *entry,int *fixedgamma,int *mof,double *offsets,double *gamma2,double *Vgamma2, double *caseweight,int *icase) { // {{{ // {{{ setting up variables and allocating matrix *Vcov,*X,*WX,*A,*AI,*AIXW,*Z,*WZ; matrix *IdCGam,*dCGam,*CGam,*Ct,*ICGam,*VarKorG,*dC,*ZH,*XWZ,*ZWZ,*XWZAI; matrix *Vargam,*dVargam,*GCdM1M2,*Vargam2; matrix *dM1M2,*M1M2t,*RobVargam,*tmpM2,*tmpM3,*tmpM4; matrix *W3t[*antclust],*W4t[*antclust]; // matrix *AIs[*Nalltimes],*C[*Nalltimes],*Acorb[*Nalltimes],*M1M2[*Ntimes]; vector *W2[*antclust],*W3[*antclust]; vector *VdB,*difX,*xi,*tmpv1,*tmpv2; vector *dAoff,*dA,*rowX,*dN,*AIXWdN,*bhatt,*pbhat,*plamt; vector *dgam2,*gam2,*korG,*pghat,*rowZ,*gam,*gamoff,*dgam,*ZHdN,*IZHdN,*zi,*offset; int l1,cin,ci=0,i,j,k,l,c,s,count,pers=0,pmax,stat, *cluster=calloc(*antpers,sizeof(int)), *stats=calloc(*Nalltimes,sizeof(int)), *idd=calloc(*antpers,sizeof(int)), *ls=calloc(*Ntimes,sizeof(int)), detail=1; double time,dtime,ahati,ghati,hati; double *vcudif=calloc((*Ntimes)*(*px+1),sizeof(double)), *times=calloc(*Ntimes,sizeof(double)), *cumoff=calloc((*Nalltimes)*(*px+1),sizeof(double)); malloc_mat(*antpers,*px,X); malloc_mat(*antpers,*px,WX); malloc_mat(*antpers,*pg,Z); malloc_mat(*antpers,*pg,WZ); malloc_mat(*px,*antpers,AIXW); malloc_mat(*pg,*antpers,ZH); malloc_mats(*px,*px,&Vcov,&A,&AI,&GCdM1M2,&VarKorG,NULL); malloc_mats(*pg,*pg,&tmpM2,&ZWZ,&RobVargam,&Vargam,&dVargam,&Vargam2,&ICGam,&CGam,&IdCGam,&dCGam,NULL); malloc_mats(*px,*pg,&tmpM3,&Ct,&dC,&XWZ,&XWZAI,&dM1M2,&M1M2t,NULL); malloc_mat(*px,*pg,tmpM4); malloc_vecs(*px,&dA,&dAoff,&VdB,&difX,&xi,&tmpv1,&korG,&rowX,&AIXWdN,&bhatt,NULL); malloc_vecs(*pg,&dgam2,&gam2,&zi,&tmpv2,&rowZ,&gam,&gamoff,&dgam,&ZHdN,&IZHdN,NULL); malloc_vecs(*antpers,&offset,&pbhat,&dN,&pghat,&plamt,NULL); matrix *AIn,*XZAIn,*Cn,*M1M2n; malloc_mat((*px)*(*Nalltimes),*px,AIn); malloc_mat((*px)*(*Nalltimes),*pg,XZAIn); malloc_mat((*px)*(*Nalltimes),*pg,Cn); malloc_mat(*pg,(*px)*(*Ntimes),M1M2n); for (j=0;j<*Nalltimes;j++) { // malloc_mat(*px,*pg,Acorb[j]); // malloc_mat(*px,*pg,C[j]); stats[j]=0; } // for (j=0;j<*Ntimes;j++) malloc_mat(*px,*pg,M1M2[j]); if (*robust==1) { for (j=0;j<*antclust;j++) { malloc_mat(*Ntimes,*px,W3t[j]); malloc_mat(*Ntimes,*px,W4t[j]); malloc_vec(*pg,W2[j]); malloc_vec(*px,W3[j]); } // for (j=0;j<*Nalltimes;j++) malloc_mat(*px,*px,AIs[j]); } pmax=max(*pg,*px); mat_zeros(Ct); mat_zeros(CGam); vec_zeros(IZHdN); times[0]=alltimes[0]; l=0; for (c=0;c<*nx;c++) cluster[id[c]]=clusters[c]; for (c=0;c<*nx;c++) idd[id[c]]=id[c]; // }}} // for (c=0;(c<*nx);c++) Rprintf(" %lf \n",weights[c]); // for (c=0;(c<*nx);c++) Rprintf(" %lf \n",offsets[c]); // Rprintf(" entry \n"); // for (c=0;(c<*nx);c++) Rprintf(" %d \n",entry[c]); int timing=0; clock_t c0,c1; c0=clock(); for (s=1;s<*Nalltimes;s++){ time=alltimes[s]; dtime=time-alltimes[s-1]; // mat_zeros(X); mat_zeros(Z); mat_zeros(WX); mat_zeros(WZ); vec_zeros(rowX); vec_zeros(rowZ); stat=0; // {{{ reading design and making matrix products if (s==1) { // {{{ reading start design for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { if (*mof==1) VE(offset,id[c])=offsets[c]; for(j=0;j=0) ) ci=ci-1; } // }}} // print_mat(X); print_mat(Z); print_mat(WX); print_mat(WZ); // Rprintf(" (((((((((((((((((((((((((((((((((((((((((((( \n"); // Rprintf("%d %d %d %lf %lf %lf \n",s,ci,id[ci],start[ci],stop[ci],time); vec_zeros(rowX); vec_zeros(rowZ); if (s>1) // {{{ modifying design for next time points while ((stop[ci]=0) ) { // Rprintf("ww %d %d %lf %lf %d \n",ci,id[ci],stop[ci],time,entry[ci]); for(j=0;j<*px;j++) VE(xi,j)=designX[j*(*nx)+ci]; for(j=0;j<*pg;j++) VE(zi,j)=designG[j*(*nx)+ci]; // print_vec(xi); print_vec(zi); if (entry[ci]==1) { if (*mof==1) VE(offset,id[ci])=offsets[ci]; replace_row(X,id[ci],xi); replace_row(Z,id[ci],zi); scl_vec_mult(weights[ci],xi,tmpv1); replace_row(WX,id[ci],tmpv1); scl_vec_mult(weights[ci],zi,tmpv2); replace_row(WZ,id[ci],tmpv2); } else { if (*mof==1) VE(offset,id[ci])=0; replace_row(X,id[ci],rowX);replace_row(Z,id[ci],rowZ); replace_row(WX,id[ci],rowX);replace_row(WZ,id[ci],rowZ); } // Rprintf(" hej \n"); for(j=0;j1) & (time==stop[ci]) & (status[ci]==1)) { pers=id[ci]; stat=1;l=l+1; ls[l]=s;stats[s]=stat; } // }}} // }}} // print_mat(A); invertS(A,AI,silent[0]); if (ME(AI,0,0)==0.0 && *silent==0){ Rprintf(" X'X not invertible at time %lf \n",time); } MxA(AI,XWZ,XWZAI); MtA(XWZAI,XWZ,tmpM2); mat_subtr(ZWZ,tmpM2,dCGam); scl_mat_mult(dtime,dCGam,dCGam); if (*deltaweight==0) {scl_mat_mult(dtime,dCGam,dCGam); } mat_add(CGam,dCGam,CGam); // print_mat(CGam); if (stat==1) { extract_row(WX,pers,tmpv1); Mv(AI,tmpv1,AIXWdN); extract_row(WZ,pers,zi); vM(XWZ,AIXWdN,tmpv2); vec_subtr(zi,tmpv2,ZHdN); if (*deltaweight==0){ scl_vec_mult(dtime,ZHdN,ZHdN); } vec_add(ZHdN,IZHdN,IZHdN); } /* correction from offsets calculated here */ if (*mof==1) { vM(WX,offset,rowX); Mv(AI,rowX,tmpv1); scl_vec_mult(dtime,tmpv1,tmpv1); // vec_subtr(AIXWdN,tmpv1,dB); vM(WZ,offset,rowZ); vM(XWZAI,rowX,dgam); vec_subtr(rowZ,dgam,dgam); vec_add_mult(gamoff,dgam,dtime,gamoff); for (k=1;k<=*px;k++) cumoff[k*(*Nalltimes)+s]=VE(tmpv1,k-1); } scl_mat_mult(dtime,XWZAI,tmpM4); mat_add(tmpM4,Ct,Ct); // mat_copy(XWZAI,Acorb[s]); // mat_copy(Ct,C[s]); for (j=0;j<*pg;j++) for (i=0;i<*px;i++) { ME(XZAIn,(s-1)*(*px)+i,j)=ME(XWZAI,i,j); // ME(Cn,(s-1)*(*px)+i,j)=ME(Ct,i,j); } if (stat==1) { vcu[l]=time; cu[l]=time; times[l]=time; for (j=0;j<*pg;j++) for (i=0;i<*px;i++) ME(Cn,l*(*px)+i,j)=ME(Ct,i,j); for (k=0;k<*pg;k++){ for (j=0;j<*pg;j++) ME(dVargam,k,j)= VE(ZHdN,j)*VE(ZHdN,k); for (j=0;j<*pg;j++) ME(Vargam2,k,j)+= VE(dgam2,j)*VE(dgam2,k); for (j=0;j<*px;j++) ME(dM1M2,j,k)=VE(ZHdN,k)*VE(AIXWdN,j); } mat_add(dVargam,Vargam,Vargam); mat_add(dM1M2,M1M2t,M1M2t); // mat_copy(M1M2t,M1M2[l]); //for (i=0;i<*px;i++) Rprintf(" %d %d %d %d \n",*Ntimes,l,(*Ntimes)*(*px),l*(*px)+i); for (j=0;j<*pg;j++) for (i=0;i<*px;i++) ME(M1M2n,j,l*(*px)+i)=ME(M1M2t,i,j); for (k=1;k<=*px;k++) { cu[k*(*Ntimes)+l]=VE(AIXWdN,k-1); vcu[k*(*Ntimes)+l]=vcu[k*(*Ntimes)+l-1]+VE(AIXWdN,k-1)*VE(AIXWdN,k-1); } } if (*robust==1) for (j=0;j<*px;j++) for (i=0;i<*px;i++) ME(AIn,(s-1)*(*px)+j,i)=ME(AI,j,i); // AIs[s]=mat_copy(AI,AIs[s]); // for (i=0;i<*antpers;i++) { // extract_row(WX,i,xi);Mv(AI,xi,rowX);replace_row(AIxit[i],s,rowX); // } } /* s =1...Ntimes */ if (timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: going through times %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} if (detail>=2) Rprintf("Fitting done \n"); invertS(CGam,ICGam,silent[0]); if (*fixedgamma==0) Mv(ICGam,IZHdN,gam); if ((*mof==1) & (*fixedgamma==0)) { Mv(ICGam,gamoff,dgam); vec_subtr(gam,dgam,gam); } if (ME(ICGam,0,0)==0 && *silent==0) Rprintf(" intZHZ singular\n"); // Mv(ICGam,IZHdN,gam); MxA(Vargam,ICGam,tmpM2); MxA(ICGam,tmpM2,Vargam); mat_zeros(X); mat_zeros(Z); mat_zeros(WX); mat_zeros(WZ); l=0; l1=0; for (s=1;s<*Nalltimes;s++) { time=alltimes[s]; dtime=time-alltimes[s-1]; stat=0; if (*robust==1) { // {{{ // {{{ reading design and making matrix products if (s==1) { // {{{ reading start design for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { if (*mof==1) VE(offset,id[c])=offsets[c]; for(j=0;j=0) ) ci=ci-1; } // }}} vec_zeros(rowX); vec_zeros(rowZ); if (s>1) // {{{ modifying design for next time points while ((stop[ci]=0) ) { for(j=0;j<*px;j++) VE(xi,j)=designX[j*(*nx)+ci]; for(j=0;j<*pg;j++) VE(zi,j)=designG[j*(*nx)+ci]; if (entry[ci]==1) { if (*mof==1) VE(offset,id[ci])=offsets[ci]; replace_row(X,id[ci],xi); replace_row(Z,id[ci],zi); scl_vec_mult(weights[ci],xi,tmpv1); replace_row(WX,id[ci],tmpv1); scl_vec_mult(weights[ci],zi,tmpv2); replace_row(WZ,id[ci],tmpv2); } else { if (*mof==1) VE(offset,id[ci])=0; replace_row(X,id[ci],rowX);replace_row(Z,id[ci],rowZ); replace_row(WX,id[ci],rowX);replace_row(WZ,id[ci],rowZ); } // for(j=0;j1) & (time==stop[ci]) & (status[ci]==1)) { pers=id[ci]; stat=1; l1=l1+1; // ls[l]=s; } // }}} // }}} } // }}} if (stats[s]==1) l=l+1; if (stats[s]==1) for (k=1;k<=*px;k++) VE(dA,k-1)=cu[k*(*Ntimes)+l]; else vec_zeros(dA); // Rprintf(" %d %d %d %d %d %d \n",s,l,l1,ls[l],stats[s],stat); if (*mof==1) { for (k=1;k<=*px;k++) { VE(dA,k-1)=VE(dA,k-1)-cumoff[k*(*Nalltimes)+s]; VE(dAoff,k-1)= -cumoff[k*(*Nalltimes)+s]; cumoff[k*(*Nalltimes)+s]=cumoff[k*(*Nalltimes)+s-1]+cumoff[k*(*Nalltimes)+s]; } } /* terms for robust variance */ if (*robust==1 ) // {{{ { for (j=0;j<*pg;j++) for (i=0;i<*px;i++) { ME(tmpM4,i,j)= dtime*ME(XZAIn,(s-1)*(*px)+i,j); ME(XWZAI,i,j)= ME(XZAIn,(s-1)*(*px)+i,j); } for (j=0;j<*px;j++) for (i=0;i<*px;i++) ME(AI,j,i)= ME(AIn,(s-1)*(*px)+j,i); // print_mat(tmpM4); // mat_subtr(C[s],C[s-1],tmpM4); // print_mat(tmpM4); Mv(tmpM4,gam,korG); for (i=0;i<*antpers;i++) { cin=cluster[i]; extract_row(X,i,xi); extract_row(Z,i,zi); if (stat==1) ahati=vec_prod(xi,dA); else ahati=0.0; ghati=dtime*vec_prod(zi,gam); hati=ahati+ghati-vec_prod(xi,korG); if (*mof==1) hati=hati+dtime*VE(offset,i); if (*robust==1) { extract_row(WX,i,xi); extract_row(WZ,i,zi); // vM(Acorb[s],xi,tmpv2); vM(XWZAI,xi,tmpv2); vec_subtr(zi,tmpv2,tmpv2); if (i==pers && stat==1) vec_add(tmpv2,W2[cin],W2[cin]); scl_vec_mult(hati,tmpv2,rowZ); vec_subtr(W2[cin],rowZ,W2[cin]); // extract_row(AIxit[i],s,rowX); Mv(AI,xi,rowX); if (i==pers && stat==1) { vec_add(rowX,W3[cin],W3[cin]); } scl_vec_mult(hati,rowX,rowX); vec_subtr(W3[cin],rowX,W3[cin]); } // if (*retur==1) { // if (stat==0){ // cumAit[i*(*Ntimes)+l+1]= // cumAit[i*(*Ntimes)+l+1]-hati; // } else { // cumAit[i*(*Ntimes)+l]=cumAit[i*(*Ntimes)+l]+1*(i==pers)-hati; // } // } if (stat==1) replace_row(W3t[cin],l,W3[cin]); } /* i=1..antpers */ } // }}} /* robust ==1 */ if (stats[s]==1) { // extract_row(X,pers,xi); ahati=vec_prod(xi,dA); // extract_row(WX,pers,xi); vec_star(xi,dA,rowX); for (k=1;k<=*px;k++) cu[k*(*Ntimes)+l]=cu[k*(*Ntimes)+l-1]+cu[k*(*Ntimes)+l]+VE(dAoff,k-1); for (j=0;j<*pg;j++){ // for (i=0;i<*px;i++) ME(Ct,i,j)=ME(Cn,(ls[l]-1)*(*px)+i,j); for (i=0;i<*px;i++) ME(Ct,i,j)=ME(Cn,l*(*px)+i,j); for (i=0;i<*px;i++) ME(M1M2t,i,j)=ME(M1M2n,j,l*(*px)+i); } // MxA(C[ls[l]],Vargam,tmpM4); MAt(tmpM4,C[ls[l]],VarKorG); // MxA(M1M2[l],ICGam,tmpM4); MAt(C[ls[l]],tmpM4,GCdM1M2); MxA(Ct,Vargam,tmpM4); MAt(tmpM4,Ct,VarKorG); MxA(M1M2t,ICGam,tmpM4); MAt(Ct,tmpM4,GCdM1M2); for (k=1;k<=*px;k++) vcu[k*(*Ntimes)+l]+= ME(VarKorG,k-1,k-1)-2.0*ME(GCdM1M2,k-1,k-1); } } /* s=1 ..Ntimes */ vec_star(IZHdN,gam,rowZ); if (detail>=2) Rprintf("Offsets adjustment and MG variances for gamma \n"); // loglike[0]=loglike[0]-vec_sum(rowZ); l=0; for (s=1;s<*Ntimes;s++) { for (j=0;j<*pg;j++) for (i=0;i<*px;i++) ME(Ct,i,j)=ME(Cn,s*(*px)+i,j); // for (i=0;i<*px;i++) ME(Ct,i,j)=ME(Cn,(ls[l]-1)*(*px)+i,j); // Mv(C[ls[s]],gam,korG); Mv(Ct,gam,korG); for (k=1;k<=*px;k++) cu[k*(*Ntimes)+s]=cu[k*(*Ntimes)+s]-VE(korG,k-1); if (*robust==1) { // {{{ ROBUST VARIANCES vec_zeros(VdB); mat_zeros(Vcov); for (j=0;j<*antclust;j++) { Mv(ICGam,W2[j],tmpv2); // if (*fixedgamma==1) vec_zeros(rowX); else Mv(C[ls[s]],tmpv2,rowX); if (*fixedgamma==1) vec_zeros(rowX); else Mv(Ct,tmpv2,rowX); extract_row(W3t[j],s,tmpv1); vec_subtr(tmpv1,rowX,difX); replace_row(W4t[j],s,difX); vec_star(difX,difX,tmpv1); vec_add(tmpv1,VdB,VdB); if (*resample==1) { if (s==1) for (k=0;k<*pg;k++) gammaiid[k*(*antclust)+j]=VE(tmpv2,k); for (k=0;k<*px;k++) { l=j*(*px)+k; Biid[l*(*Ntimes)+s]=VE(difX,k); } } if (*covariance==1) { for (k=0;k<*px;k++) for (c=0;c<*px;c++) ME(Vcov,k,c)=ME(Vcov,k,c)+VE(difX,k)*VE(difX,c); } if (s==1) for (c=0;c<*pg;c++) for (k=0;k<*pg;k++) ME(RobVargam,c,k)=ME(RobVargam,c,k)+VE(W2[j],c)*VE(W2[j],k); } /* j =1 ..Antclust */ } // }}} /* robust==1 */ for (k=1;k<*px+1;k++) { Robvcu[k*(*Ntimes)+s]=VE(VdB,k-1); if (*covariance==1) { for (j=0;j<*px;j++) { l=(k-1)*(*px)+j; covs[l*(*Ntimes)+s]=ME(Vcov,k-1,j); } } } } /* s=1 ..Ntimes */ if (detail>=2) Rprintf("Baseline corrected for gamma and robust variances \n"); if (*robust==1) { MxA(RobVargam,ICGam,tmpM2); MxA(ICGam,tmpM2,RobVargam); } for (j=0;j<*pg;j++) { intZHdN[j]=VE(IZHdN,j); gamma[j]=VE(gam,j); gamma2[j]=VE(gam2,j); for (k=0;k<*pg;k++) { Vgamma[k*(*pg)+j]=ME(Vargam,j,k); Vgamma2[k*(*pg)+j]=ME(Vargam2,j,k); RobVgamma[k*(*pg)+j]=ME(RobVargam,j,k); intZHZ[k*(*pg)+j]=ME(CGam,j,k); } } cu[0]=times[0]; vcu[0]=times[0]; if (*sim==1) { comptest(times,Ntimes,px,cu,Robvcu,vcudif,antsim,test,testOBS,Ut,simUt,W4t,weighted,antclust); } // {{{ freeing free_mats(&AIn,&XZAIn,&Cn,&M1M2n,NULL); free_mat(X); free_mat(WX); free_mat(Z); free_mat(WZ); free_mat(AIXW); free_mat(ZH); free_mats(&Vcov,&A,&AI,&GCdM1M2,&VarKorG,NULL); free_mats(&tmpM2,&ZWZ,&RobVargam,&Vargam,&dVargam,&ICGam,&CGam,&IdCGam,&dCGam,NULL); free_mats(&Vargam2,&tmpM4,&tmpM3,&Ct,&dC,&XWZ,&XWZAI,&dM1M2,&M1M2t,NULL); free_vecs(&dgam2,&gam2,&dA,&dAoff,&VdB,&difX,&xi,&tmpv1,&korG,&rowX,&AIXWdN,&bhatt,NULL); free_vecs(&zi,&tmpv2,&rowZ,&gam,&gamoff,&dgam,&ZHdN,&IZHdN,NULL); free_vecs(&offset,&pbhat,&dN,&pghat,&plamt,NULL); // for (j=0;j<*Nalltimes;j++) { free_mat(Acorb[j]); free_mat(C[j]); } // for (j=0;j<*Ntimes;j++) { free_mat(M1M2[j]); } if (*robust==1) { // for (j=0;j<*Nalltimes;j++) free_mat(AIs[j]); for (j=0;j<*antclust;j++) { free_mat(W3t[j]); free_mat(W4t[j]); free_vec(W2[j]); free_vec(W3[j]); } } free(vcudif); free(times); free(cumoff); free(stats); free(idd); free(cluster); free(ls); // }}} } // }}} timereg/src/dynadd.c0000644000176200001440000005120514421510301014076 0ustar liggesusers//#include #include #include "matrix.h" void dynadd(double *times,double *y,int *Ntimes,double *designX,int *nx,int *px,double *designA,int *na,int *pa,double *ahat,double *bhat,double *bhatny,int *nxval,int *antpers, double *start,double *stop,double *cu0,double *cuf,double *cuMS,double *vcu0,double *vcuf,double *robvcu,double *w,int *mw,int *rani,int *sim,int *antsim,double *cumBit,double *test, double *testOBS,int *status,double *Ut,double *simUt,double *b,double *cumly,int *retur,int *id,int *smoothXX,int *weighted,double *vculy,int *clusters,int *antclust) //double *bhatny,*bhat,*ahat,*designX,*designA,*times,*y,*start,*stop,*cu0,*cuf,*cuMS, //*vcu0,*vcuf,*w,*robvcu,*cumBit,*test,*testOBS,*Ut,*simUt,*b,*cumly,*vculy; //int *sim,*antsim,*retur,*nxval,*nx,*px,*na,*pa,*antpers,*Ntimes,*mw,*rani,*status,*id,*smoothXX,*weighted,*clusters,*antclust; { matrix *ldesignX,*ldesignA,*cdesignX,*cdesignA,*Aa,*AaI,*A,*AI; matrix *XbXa,*XWX; vector *korf,*dB,*dA,*dR,*ahatt,*xt,*pdA,*diag,*xai,*sumx,*vone,*itot; vector *VdBly,*VdB,*VdB0,*VdBf,*fkor,*dkorB,*tmpv,*tmpv1,*tmpv2,*tmpv3,*tmpv4; vector *pahat,*pbhat,*bhatt,*pbahat,*pdbahat,*dBly; vector *dAt[*Ntimes]; matrix *cumBt[*antpers]; vector *cumhatB[*antpers],*cumB[*antpers],*cum; int silent=1; int pers=0,i,j,k,s,c,count,pmax,nmax,risk; int *coef=calloc(1,sizeof(int)),*imin=calloc(1,sizeof(int)), *ps=calloc(1,sizeof(int)),*degree=calloc(1,sizeof(int)); double time,zpers=0,dif,dtime,YoneN,kia; double *vcudif=calloc((*Ntimes)*(*px+1),sizeof(double)); for (i=0;i<*antpers;i++) { malloc_vec(*px,cumhatB[i]); malloc_vec(*px,cumB[i]); malloc_mat(*Ntimes,*px,cumBt[i]); } for (i=0;i<*Ntimes;i++) malloc_vec(*pa,dAt[i]); malloc_vec(*px,cum); malloc_mat(*px,*pa,XbXa); malloc_mat(*antpers,*px,ldesignX); malloc_mat(*antpers,*px,cdesignX); malloc_mat(*antpers,*pa,ldesignA); malloc_mat(*antpers,*pa,cdesignA); malloc_mat(*pa,*pa,Aa); malloc_mat(*pa,*pa,AaI); malloc_mats(*px,*px,&XWX,&A,&AI,NULL); malloc_vecs(*px,&dB,&diag,&sumx,&itot,&korf,&dBly,&bhatt,&fkor,&VdBly,&VdB,&VdB0,&VdBf,&dkorB,&tmpv,&tmpv1,&tmpv2,&tmpv3,&tmpv4,NULL); malloc_vecs(*antpers,&pbhat,&pbahat,&pahat,&pdbahat,&vone,&dR,&pdA,NULL); malloc_vec(*nxval,xt);vone=vec_ones(vone);malloc_vec(*pa,ahatt);malloc_vec(*pa,xai);malloc_vec(*pa,dA); if (*px>=*pa) pmax=*px; else pmax=*pa; if (*nx>=*na) nmax=*nx; else nmax=*na; R_CheckUserInterrupt(); for (s=1;s<*Ntimes;s++) { time=times[s]; risk=0; dtime=time-times[s-1]; mat_zeros(ldesignX); mat_zeros(ldesignA); vec_zeros(dR); for (c=0,count=0;((c=time)) { for(j=0;j=*pa) pmax=*px; else pmax=*pa; if (*pg>=pmax) pmax=*pg; if (*nx>=*na) nmax=*nx; else nmax=*na; /* Prelim. est. of gamma for var. est. loaded from (B(t)/t */ for(j=0;j<*pg;j++) {VE(gam,j)=gamma[j];VE(gamstart,j)=gamma[j];} R_CheckUserInterrupt(); for (s=1;s<*Ntimes;s++) { vec_zeros(dR); zpers=0; risk=0; time=times[s]; dtime=time-times[s-1]; mat_zeros(ldesignX); mat_zeros(ldesignG); mat_zeros(ldesignA); ctime=dtime+ctime; for (c=0,count=0;((c=time)) { for(j=0;j #include #include "matrix.h" /* ====================================================== */ void twostagereg(double *times,int *Ntimes,double *designX,int *nx,int *px,double *designG,int *ng,int *pg, int *antpers,double *start,double *stop, int *Nit, int *detail, int *id,int *status, int *ratesim, int *robust, int *clusters, int *antclust,int *betafixed, double *theta, double *vartheta,double *thetascore, int *inverse, int *clustsize,double *desthetaI, int *ptheta,double *SthetaI,double *step,int *idiclust,int *notaylor,double *gamiid,double *biid,int *semi,double *cumhaz, double *cumhazleft,int *lefttrunk,double *rr,int *maxtimesim,int *timegroup,int *secluster,int *antsecluster,double *thetiid,double *timereso,double *DUbeta) { // {{{ defining variables matrix *ldesG0,*cdesX2,*Ftilde,*Gtilde; matrix *destheta,*d2UItheta,*d2Utheta,*varthetascore,*Stheta,*mattheta; matrix *Biid[*antsecluster]; // ,*Sthetaiid[*antsecluster]; vector *dAiid[*antsecluster],*gammaiid[*antsecluster],*thetaiid[*antsecluster]; vector *lamt,*lamtt,*offset,*weight,*one; vector *tmpv1,*xi,*zi,*reszpbeta,*res1dim; vector *vthetascore,*vtheta3,*vtheta1,*vtheta2,*dtheta; int cc,c,i,j,k,l,s,it,pmax,v; double dummy,ll,lle; double tau,sumscore=999, theta0=0,Dthetanu=1,logl=0; double *thetaiidscale=calloc(*antclust,sizeof(double)), *Nt=calloc(*antclust,sizeof(double)), *Nti=calloc(*antpers,sizeof(double)), *NH=calloc(*antclust,sizeof(double)), *HeH=calloc(*antclust,sizeof(double)), *HeHleft=calloc(*antclust,sizeof(double)), *H2eH=calloc(*antclust,sizeof(double)), *H2eHleft=calloc(*antclust,sizeof(double)), *Rtheta=calloc(*antclust,sizeof(double)), *Rthetaleft=calloc(*antclust,sizeof(double)), *Hik=calloc(*antpers,sizeof(double)), *insecluster=calloc(*antsecluster,sizeof(double)); int *ipers=calloc(*Ntimes,sizeof(int)), *cluster=calloc(*antpers,sizeof(int)), *multitrunc=calloc(*antclust,sizeof(int)); for (j=0;j<*antclust;j++) { Nt[j]=0; NH[j]=0; multitrunc[j]=0; } for (j=0;j<*antsecluster;j++) { insecluster[j]=0; if (*notaylor==0) { malloc_vec(*pg,gammaiid[j]); malloc_mat(*maxtimesim,*px,Biid[j]); } malloc_vec(*ptheta,dAiid[j]); malloc_vec(*ptheta,thetaiid[j]); // malloc_mat(*ptheta,*ptheta,Sthetaiid[j]); } malloc_mat(*ptheta,*px,Ftilde); malloc_mat(*ptheta,*pg,Gtilde); malloc_mats(*antpers,*px,&cdesX2,NULL); malloc_mats(*antpers,*pg,&ldesG0,NULL); malloc_mat(*antpers,*ptheta,destheta); malloc_mat(*ptheta,*ptheta,d2Utheta); malloc_mat(*ptheta,*ptheta,d2UItheta); malloc_mat(*ptheta,*ptheta,Stheta); malloc_mat(*ptheta,*ptheta,mattheta); malloc_mat(*ptheta,*ptheta,varthetascore); malloc_vecs(*ptheta,&vthetascore,&vtheta1,&dtheta,&vtheta2,&vtheta3,NULL); malloc_vecs(*px,&tmpv1,&xi,NULL); malloc_vecs(*antpers,&weight,&lamtt,&lamt,&one,&offset,NULL); malloc_vecs(*pg,&zi,NULL); malloc_vec(1,reszpbeta); malloc_vec(1,res1dim); if (*px>=*pg) pmax=*px; else pmax=*pg; ll=0; for (i=0;i<*antpers;i++) { Hik[i]=0; Nti[i]=0; VE(one,i)=1; VE(weight,i)=1; VE(offset,i)=1;} for (c=0;c<*antpers;c++) cluster[id[c]]=clusters[c]; for (j=0;j<*antpers;j++) { Hik[j]=cumhaz[j]; Nti[j]=Nti[j]+status[j]; Nt[cluster[j]]= Nt[cluster[j]]+status[j]; } // for (j=0;j<*antpers;j++) Rprintf("%d %d %d %lf %lf %lf \n",j,id[j],cluster[id[j]],cumhaz[j],Nti[j],cumhazleft[j]); if (*notaylor==0) { if (*semi==1) for (i=0;i<*antsecluster;i++) for (j=0;j<*pg;j++) VE(gammaiid[i],j)=gamiid[j*(*antclust)+i]; // if (*semi==1) for (i=0;i<*antclust;i++) for (j=0;j<*pg;j++) VE(gammaiid[i],j)=0; // for (i=0;i<*antclust;i++) for (j=0;j<*pg;j++) // printf("%d %d %d %lf \n",*antclust,j,i,gamiid[j*(*antclust)+i]); for (i=0;i<*antsecluster;i++) for (s=0;s<*maxtimesim;s++) for (c=0;c<*px;c++) { l=i*(*px)+c; ME(Biid[i],s,c)=biid[l*(*maxtimesim)+s]; // ME(Biid[i],s,c)=0; // printf("%d %d %d %d %d %d \n",*maxtimesim,l,s,j,i,l*(*maxtimesim)+s); } } // assuming that destheta is on this form: antpers x ptheta for(i=0;i<*antpers;i++) for(j=0;j<*ptheta;j++) ME(destheta,i,j)=desthetaI[j*(*antpers)+i]; for (c=0;((c<*antpers));c++) for(j=0;j0) multitrunc[j]+=1; } R_CheckUserInterrupt(); /*===================Estimates theta, two stage approach of glidden ==== */ for (i=0;i<*ptheta;i++) VE(vtheta1,i)=theta[i]; // starting values for (it=0;it<*Nit;it++) // {{{ frailty parameter Newton-Raphson { R_CheckUserInterrupt(); for (j=0;j<*antclust;j++) { Rthetaleft[j]=1; Rtheta[j]=1; HeHleft[j]=0; HeH[j]=0;H2eH[j]=0; H2eHleft[j]=0; } vec_zeros(vthetascore); mat_zeros(d2Utheta); logl=0; Mv(destheta,vtheta1,lamtt); for (j=0;j<*antclust;j++) if (clustsize[j]>=2) { for (k=0;k=2) && (start[i]>0)) { Rthetaleft[j]=Rthetaleft[j]+exp(theta0*cumhazleft[i])-1; HeHleft[j]=HeHleft[j]+cumhazleft[i]*exp(theta0*cumhazleft[i]); H2eHleft[j]=H2eHleft[j]+pow(cumhazleft[i],2)*exp(theta0*cumhazleft[i]); } } } for (j=0;j<*antclust;j++) if (clustsize[j]>=2) { if (it==0) { cc=idiclust[0*(*antclust)+j]; // takes one index from cluster cc=secluster[cc]; // secluster id related to this cluster insecluster[cc]=1; // something going on in secluster } // takes design and parameter to this cluster i=idiclust[0*(*antclust)+j]; // index from this cluster extract_row(destheta,i,vtheta2); theta0=VE(lamtt,i); if (*inverse==1){theta0=exp(VE(lamtt,i));Dthetanu=theta0; } sumscore=0; ll=0; if (Nt[j]>=2) for (k=2;k<=Nt[j];k++) { tau=(k-1)/(1+theta0*(k-1)); lle=-pow((k-1),2)/pow((1+theta0*(k-1)),2); sumscore=sumscore+tau; ll=ll+lle; logl+=log((1+theta0*(k-1))); } logl=logl+theta0*NH[j]+(1/theta0+Nt[j])*log(Rtheta[j]); if (*lefttrunk==1 && multitrunc[j]>=2) logl=logl-(1/theta0)*log(Rthetaleft[j]); if (it<0 && multitrunc[j]>=2) { Rprintf(" %d %d %lf %lf %lf \n",j,clustsize[j],Rtheta[j],HeH[j],H2eH[j]); Rprintf(" %d %d %lf %lf %lf \n",j,multitrunc[j],Rthetaleft[j],HeHleft[j],H2eHleft[j]); } thetaiidscale[j]=sumscore+ log(Rtheta[j])/(theta0*theta0)-(1/theta0+Nt[j])*HeH[j]/Rtheta[j]+NH[j]; // printf(" %d %d %lf \n",j,clustsize[j],thetaiidscale[j]); if (*lefttrunk==1 && multitrunc[j]>=2) thetaiidscale[j]=thetaiidscale[j]- log(Rthetaleft[j])/(theta0*theta0)+(1/theta0)*HeHleft[j]/Rthetaleft[j]; // printf("%d %d %lf \n",j,multitrunc[j],thetaiidscale[j]); scl_vec_mult(thetaiidscale[j]*Dthetanu,vtheta2,vtheta3); if (isnan(thetaiidscale[j])) { if (theta0<0) Rprintf("negative value of random effect variances causes problems, try step.size=0.1\n"); Rprintf("nan i score subject=%d %lf %lf %lf %lf %lf %lf %lf %lf %lf \n",j,theta0,Nt[j],NH[j],HeH[j],Rtheta[j],Rthetaleft[j],HeHleft[j],Dthetanu,thetaiidscale[j]); print_vec(vtheta3); oops("missing value\n"); } if (isnan(thetaiidscale[j])) vec_zeros(vtheta3); if (it==(*Nit-1)) { // printf(" tror vi er her %d %d \n",i,secluster[i]); print_vec(vtheta3); print_vec(thetaiid[secluster[i]]); vec_add(vtheta3,thetaiid[secluster[i]],thetaiid[secluster[i]]); } vec_add(vthetascore,vtheta3,vthetascore); tau=ll+(2/pow(theta0,2))*HeH[j]/Rtheta[j]-(2/pow(theta0,3))*log(Rtheta[j]) -(1/theta0+Nt[j])*(H2eH[j]*Rtheta[j]-HeH[j]*HeH[j])/pow(Rtheta[j],2); if (*lefttrunk==1 && multitrunc[j]>=2) { tau=tau-((2/pow(theta0,2))*HeHleft[j]/Rthetaleft[j]-(2/pow(theta0,3))*log(Rthetaleft[j]) -(1/theta0)*(H2eHleft[j]*Rthetaleft[j]-HeHleft[j]*HeHleft[j])/pow(Rthetaleft[j],2)); } for (c=0;c<*ptheta;c++) for (k=0;k<*ptheta;k++) { // ME(Sthetaiid[j],c,k)=VE(vtheta2,c)*VE(vtheta2,k)*tau*pow(Dthetanu,2); if (*inverse==0) ME(mattheta,c,k)=VE(vtheta2,c)*VE(vtheta2,k)*tau*pow(Dthetanu,2); if (*inverse==1) ME(mattheta,c,k)=VE(vtheta2,c)*VE(vtheta2,k)*(tau*pow(Dthetanu,2)+thetaiidscale[j]*Dthetanu); } mat_add(d2Utheta,mattheta,d2Utheta); } // j=1...antclust // LevenbergMarquardt(d2Utheta,d2UItheta,vthetascore,dtheta,step,step); invertS(d2Utheta,d2UItheta,1); if (*detail==1) { Rprintf("====================Iteration %d ==================== \n",it); Rprintf("Log-likelihood %lf \n",logl); Rprintf("Estimate theta \n"); print_vec(vtheta1); Rprintf("Score D l\n"); print_vec(vthetascore); Rprintf("Information D^2 l\n"); print_mat(d2UItheta); } Mv(d2UItheta,vthetascore,dtheta); scl_vec_mult(*step,dtheta,dtheta); vec_subtr(vtheta1,dtheta,vtheta1); sumscore=0; for (k=0;k<*ptheta;k++) sumscore= sumscore+fabs(VE(vthetascore,k)); if ((sumscore<0.0000001) & (it<*Nit-2)) it=*Nit-2; } /* it theta Newton-Raphson */ // }}} if (*detail==1) Rprintf("Newton-Raphson ok \n"); for (i=0;i<*ptheta;i++) { theta[i]=VE(vtheta1,i); thetascore[i]=VE(vthetascore,i); } // if (*detail==1) Rprintf("notaylor %d robust %d \n",*notaylor,*robust); R_CheckUserInterrupt(); /* terms for robust variances ============================ */ if (*robust==1) { // {{{ mat_zeros(Gtilde); double dummyleft=0; int engang=0; if ((*notaylor==0) && (*semi==1)) { // {{{ derivative D_betaU = Gtilde for (j=0;j<*antclust;j++) if (clustsize[j]>=2) { for (v=0;v=2) { dummyleft=-cumhazleft[i]*( (1/(theta0*Rthetaleft[j]))*exp(theta0*cumhazleft[i]) -(1/theta0)*(1+theta0*cumhazleft[i])*exp(theta0*cumhazleft[i])/Rthetaleft[j] +exp(theta0*cumhazleft[i])*HeHleft[j]/pow(Rthetaleft[j],2) ); } else dummyleft=0; if (*notaylor==0) { extract_row(ldesG0,i,zi); extract_row(destheta,i,vtheta1); for (c=0;c<*ptheta;c++) for (l=0;l<*pg;l++) ME(Gtilde,c,l)=ME(Gtilde,c,l)+VE(zi,l)*VE(vtheta1,c)*Dthetanu*(dummy+dummyleft); } } } for (c=0;c<*ptheta;c++) for (l=0;l<*pg;l++) DUbeta[c*(*pg)+l]=ME(Gtilde,c,l); // SthetaI[k*(*ptheta)+j]=ME(d2UItheta,j,k); } // }}} if (*notaylor==0) for (s=1;s<*maxtimesim;s++) { // {{{ derivatve D_baseline(t) engang=0; for (k=0;k<*antsecluster;k++) if (insecluster[k]>0) { // for (k=0;k<*antclust;k++) if (clustsize[k]>=2) { // cc=idiclust[0*(*antclust)+k]; // takes one index from cluster // cc=secluster[cc]; // secluster id related to this cluster // insecluster[cc]=1; if (engang==0) { // {{{ derivatve D_baseline(t) engang=1; mat_zeros(Ftilde); for (j=0;j<*antclust;j++) if (clustsize[j]>=2) { for (v=0;v=timereso[s])) { theta0=VE(lamtt,i); if (*inverse==1) theta0=exp(theta0); dummy=rr[i]*((1/(theta0*Rtheta[j]))*exp(theta0*Hik[i]) -(1/theta0+Nt[j])*(1+theta0*Hik[i])*exp(theta0*Hik[i])/Rtheta[j]+Nti[i] +(1+theta0*Nt[j])*exp(theta0*Hik[i])*HeH[j]/pow(Rtheta[j],2)); } else dummy=0; // if (*lefttrunk==1 && multitrunc[j]>=2 ) { if (*lefttrunk==1 && multitrunc[j]>=2 && (start[i]>=timereso[s])) { dummyleft=-rr[i]* ((1/(theta0*Rthetaleft[j]))*exp(theta0*cumhazleft[i]) -(1/theta0)*(1+theta0*cumhazleft[i])*exp(theta0*cumhazleft[i])/Rthetaleft[j] +exp(theta0*cumhazleft[i])*HeHleft[j]/pow(Rthetaleft[j],2)); } else dummyleft=0; extract_row(destheta,i,vtheta1); extract_row(cdesX2,i,xi); for (c=0;c<*ptheta;c++) for (l=0;l<*px;l++) ME(Ftilde,c,l)=ME(Ftilde,c,l)+VE(xi,l)*VE(vtheta1,c)*Dthetanu*(dummy+dummyleft); } } } // }}} extract_row(Biid[k],s,tmpv1); extract_row(Biid[k],s-1,xi); vec_subtr(tmpv1,xi,xi); Mv(Ftilde,xi,vtheta2); vec_add(dAiid[k],vtheta2,dAiid[k]); } /* k=0..antseclust */ } // s=1, maxtimesim // }}} for (j=0;j<*antsecluster;j++) { // {{{ iid // printf("-------------------- %d \n",j); if (*notaylor==0) { if (insecluster[j]>0) if (*semi==1) { Mv(Gtilde,gammaiid[j],vtheta2); vec_add(thetaiid[j],vtheta2,thetaiid[j]); // print_vec(vtheta2); } vec_add(thetaiid[j],dAiid[j],thetaiid[j]); // print_vec(dAiid[j]); } for (i=0;i<*ptheta;i++) { thetiid[j*(*ptheta)+i]=VE(thetaiid[j],i); for (k=0;k<*ptheta;k++) ME(varthetascore,i,k)=ME(varthetascore,i,k)+VE(thetaiid[j],i)*VE(thetaiid[j],k); } } // }}} } // }}} robust==1 MxA(d2UItheta,varthetascore,d2Utheta); MxA(d2Utheta,d2UItheta,varthetascore); for (j=0;j<*ptheta;j++) for (k=0;k<*ptheta;k++) { SthetaI[k*(*ptheta)+j]=ME(d2UItheta,j,k); vartheta[k*(*ptheta)+j]=ME(varthetascore,j,k); } // {{{ freeing everything for (j=0;j<*antsecluster;j++) { if (*notaylor==0) { free_vec(gammaiid[j]); free_mat(Biid[j]); } free_vec(dAiid[j]); free_vec(thetaiid[j]); // free_mat(Sthetaiid[j]); } free_mats(&mattheta,&destheta, &d2Utheta, &d2UItheta, &Stheta, &Ftilde, &Gtilde, &varthetascore, &cdesX2, &ldesG0,NULL); free_vecs(&weight,&lamtt,&lamt, &one,&offset,&xi,&zi,&tmpv1, &vthetascore,&vtheta3,&vtheta1,&dtheta,&vtheta2,&reszpbeta, &res1dim,NULL); free(Nt); free(Nti); free(thetaiidscale); free(NH); free(HeH); free(H2eH); free(HeHleft); free(H2eHleft); free(Rtheta); free(Rthetaleft); free(Hik); free(cluster); free(ipers); free(insecluster); free(multitrunc); // }}} } timereg/src/Makevars.win0000644000176200001440000000031014666275306014776 0ustar liggesusers## This assumes that we can call Rscript to ask Rcpp about its locations ## Use the R_HOME indirection to support installations of multiple R version PKG_LIBS += $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) timereg/src/cox-aalen.c0000644000176200001440000011313514421510301014503 0ustar liggesusers#include #include #include #include "matrix.h" #include #include void score(double *times,int *Ntimes,double *designX,int *nx,int *px,double *designG,int *ng,int *pg,int *antpers,double *start,double *stop, double *betaS,int *Nit,double *cu,double *vcu,double *w,int *mw,double *loglike,double *Iinv,double *Vbeta,int *detail,double *offs,int *mof,int *sim,int *antsim, double *Rvcu,double *RVbeta, double *test,double *testOBS,double *Ut,double *simUt,double *Uit,int *XligZ,double *aalen,int *nb,int *id,int *status,int *wscore,double *dNit,int *ratesim,double *score,double *dhatMit,double *gammaiid,double *dmgiid, int *retur,int *robust,int *covariance,double *Vcovs,int *addresamp,double *addproc, int *resample,double *gamiid,double *biid,int *clusters,int *antclust,double *vscore,int *betafixed,double *weights,int *entry,int *exactderiv, int *timegroup,int *maxtimepoint,int *stratum,double *silent,double *caseweight) //double *designX,*designG,*times,*betaS,*start,*stop,*cu,*w,*loglike,*Vbeta,*RVbeta,*vcu,*offs,*Rvcu,*Iinv,*test,*testOBS,*Ut,*simUt,*Uit,*aalen,*score,*dhatMit,*gammaiid,*dmgiid,*Vcovs,*addproc,*gamiid,*biid,*vscore,*weights,*dNit,*sim,*caseweight,*silent; //int*covariance,*nx,*px,*ng,*pg,*antpers,*Ntimes,*mw,*Nit,*detail,*mof,*antsim,*XligZ,*nb,*id,*status,*wscore,*ratesim,*retur,*robust,*addresamp,*resample,*clusters,*antclust,*betafixed,*entry,*exactderiv,*timegroup,*maxtimepoint,*stratum; { int timing=0; double basesim=0,basestart=0; int ssilent=round(silent[0]); double propodds=silent[1]; int icaseweight=round(silent[2]); // printf("%d %d %lf \n",ssilent,icaseweight,propodds); clock_t c0,c1; c0=clock(); // mjump=sim[2]; // multiple jumps in clusters, relevant for ratesim=0 simulering via cholesky simulering basesim =sim[0]; // 1,0,-1, baseline is also simulated from time basesim=sim[0] and variance estimated (can be omitted for some for models) basestart=sim[1]; // baseline is also simulated from time basesim=sim[0] and variance estimated (can be omitted for some for models) // printf(" basesim %lf %d \n",basesim,*antsim); // basesim=0 no simulations but variance, basesim=1 (simul and variance), basesim=-1 (no simulations no variance) if (*detail==2) Rprintf("Memory allocation starting %d %d %d \n",*antpers,*antclust,*maxtimepoint); // {{{ setting up memory matrix *X,*Z,*WX,*WZ,*cdesX,*cdesX2,*cdesX3,*CtVUCt,*A,*AI; matrix *Vcov,*dYI,*Ct,*dM1M2,*M1M2t,*COV,*ZX,*ZP,*ZPX; matrix *tmp2,*tmp3,*dSprop,*dS,*S1,*SI,*S2,*M1,*VU,*ZXAI,*VUI; matrix *ZPZ,*RobVbeta,*Delta,*tmpM1,*Utt,*Delta2,*tmpM2; // matrix *St[*maxtimepoint],*M1M2[*Ntimes],*C[*maxtimepoint],*ZXAIs[*Ntimes],*dYIt[*Ntimes]; // matrix *St[*Ntimes], // matrix *M1M2[*Ntimes],*C[*Ntimes],*ZXAIs[*Ntimes],*AIs[*Ntimes]; matrix *Stg[*maxtimepoint],*Cg[*maxtimepoint]; matrix *ZPX1,*ZPZ1,*ZPXo,*ZPZo; vector *cumm,*dA,*VdA,*MdA,*delta,*zav,*lamt,*lamtt; vector *xi,*zi,*U,*beta,*xtilde,*Gbeta,*zcol,*one,*difzzav; vector *offset,*weight,*varUthat[*maxtimepoint],*Uprofile; // vector *ZXdA[*Ntimes]; vector *ta,*ahatt,*vrisk,*tmpv1,*tmpv2,*rowX,*rowZ,*difX,*VdB; vector *W2[*antclust],*W3[*antclust]; matrix *W3t[*antclust],*W4t[*antclust],*W2t[*antclust],*Uti[*antclust]; vector *Ui[*antclust]; vector *reszpbeta,*res1dim; matrix *dAt; int cin=0,ci=0,c,pers=0,i=0,j,k,l,s,s1,it,count,pmax, *imin=calloc(1,sizeof(int)), *cluster=calloc(*antpers,sizeof(int)), *strata=calloc(*antpers,sizeof(int)), *ipers=calloc(*Ntimes,sizeof(int)); double S0,RR=1,time=0,ll,lle,llo; double tau,hati,random,scale,sumscore; double *cug=calloc((*maxtimepoint)*(*px+1),sizeof(double)), *timesg=calloc((*maxtimepoint),sizeof(double)), *powi=calloc(*Ntimes,sizeof(double)) ; // *caseweight=calloc(*Ntimes,sizeof(double)); // double norm_rand(); // void GetRNGstate(),PutRNGstate(); int stratpers=0,antstrat=stratum[1]; double *S0strata=calloc(antstrat,sizeof(double)); matrix *ZPZs[antstrat],*ZPXs[antstrat]; // ,*As[antstrat],*ZXs[antstrat]; // for (j=0;j<*nx;j++) printf(" %d ",stratum[j+2]); if (*detail==1) Rprintf("antstrat %d \n",antstrat); for (j=0;j=0) { malloc_mat(*maxtimepoint,*px,W3t[j]); malloc_mat(*maxtimepoint,*px,W4t[j]); malloc_vec(*px,W3[j]); } malloc_mat(*maxtimepoint,*pg,W2t[j]); malloc_mat(*maxtimepoint,*pg,Uti[j]); malloc_vec(*pg,Ui[j]); } for(j=0;j<*maxtimepoint;j++) malloc_vec(*pg,varUthat[j]); } // }}} for (c=0;c<*nx;c++) cluster[id[c]]=clusters[c]; if (*antsim>0) { malloc_mat(*maxtimepoint,*pg,Delta2); malloc_mat(*maxtimepoint,*pg,tmpM2); } if (basesim>0) { malloc_mat(*maxtimepoint,*px,Delta); malloc_mat(*maxtimepoint,*px,tmpM1); } malloc_mat(*maxtimepoint,*pg,Utt); malloc_mats(*antpers,*px,&WX,&X,&cdesX,&cdesX2,&cdesX3,NULL); malloc_mats(*antpers,*pg,&WZ,&ZP,&Z,NULL); malloc_mats(*px,*px,&Vcov,&COV,&A,&AI,&M1,&CtVUCt,NULL); malloc_mats(*pg,*pg,&RobVbeta,&ZPZ,&tmp2,&dSprop,&dS,&S1,&S2,&SI,&VU,&VUI,NULL); malloc_mats(*pg,*px,&ZXAI,&ZX,&dM1M2,&M1M2t,NULL); malloc_mats(*px,*pg,&tmp3,&ZPX,&dYI,&Ct,NULL); malloc_mats(*px,*pg,&ZPX1,NULL); malloc_mats(*pg,*pg,&ZPZ1,NULL); malloc_mats(*px,*pg,&ZPXo,NULL); malloc_mats(*pg,*pg,&ZPZo,NULL); malloc_mat(*Ntimes,*px,dAt); malloc_vec(1,reszpbeta); malloc_vec(1,res1dim); malloc_vecs(*antpers,&weight,&lamtt,&lamt,&zcol,&Gbeta,&one,&offset,NULL); malloc_vecs(*px,&ahatt,&tmpv1,&difX,&VdB,&rowX,&xi,&dA,&VdA,&MdA,&cumm,NULL); malloc_vecs(*px,&xtilde,NULL); malloc_vecs(*pg,&tmpv2,&rowZ,&zi,&U,&beta,&delta,&zav,&difzzav,&Uprofile,NULL); malloc_vec(*nb,ta); malloc_vec(*antpers,vrisk); if (*detail==1) Rprintf("Memory allocation starting \n"); for(j=0;j<*maxtimepoint;j++) { malloc_mat(*px,*pg,Cg[j]); malloc_mat(*pg,*pg,Stg[j]);} matrix *Cn,*M1M2n,*ZXAIn,*AIn; if (basesim>=0) { malloc_mat((*px)*(*Ntimes),*pg,Cn); malloc_mat(*pg,(*px)*(*Ntimes),M1M2n); malloc_mat((*px)*(*Ntimes),*px,AIn); } malloc_mat(*pg,(*px)*(*Ntimes),ZXAIn); // matrix *Uiclustert[*antclust]; // matrix *Uicluster[*antclust]; //if (*ratesim==0 && mjump==1) { // for(j=0;j<*antclust;j++) { // malloc_mat((*pg)*(*maxtimepoint),*pg,Uiclustert[j]); // malloc_mat((*pg),(*pg),Uicluster[j]); //} //} vector *ranvec,*vectmp; malloc_vec(*pg,ranvec); malloc_vec((*pg)*(*maxtimepoint),vectmp); // for(j=0;j<*Ntimes;j++) { // malloc_mat(*px,*pg,C[j]); malloc_mat(*pg,*px,M1M2[j]); // malloc_mat(*pg,*px,ZXAIs[j]); malloc_vec(*px,dAt[j]); malloc_mat(*px,*pg,dYIt[j]); //// malloc_vec(*pg,ZXdA[j]); malloc_mat(*pg,*pg,St[j]); // } pmax=max(*px,*pg); ll=0; for(j=0;j<*pg;j++) VE(beta,j)=betaS[j]; for(j=0;j<*antpers;j++) {VE(weight,j)=1; VE(offset,j)=1;} // }}} if (*detail==1) Rprintf("Memory allocation done \n"); if (timing==2) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: setting up allocation %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} R_CheckUserInterrupt(); if (*detail==1) Rprintf("Iterations start \n"); cu[0]=times[0]; double pweight=1,xdA=0; for (it=0;it<*Nit || (*Nit==0 && it==0);it++) // {{{ iterations start for cox-aalen model { if (it>0) { vec_zeros(cumm); vec_zeros(U); mat_zeros(S1); mat_zeros(A); mat_zeros(ZPZ); mat_zeros(ZPX); mat_zeros(ZX); mat_zeros(X); mat_zeros(Z); mat_zeros(WX); mat_zeros(WZ); for (j=0;j=time)) ) { for(j=0;j=0) ) ci=ci-1; } // }}} vec_zeros(rowX); vec_zeros(rowZ); if (s>1) // {{{ modifying design for next time points while ((stop[ci]=0) ) { VE(Gbeta,id[ci])=0; // vec_prod(zi,beta); for(j=0;j<*px;j++) VE(xi,j)=designX[j*(*nx)+ci]; for(j=0;j<*pg;j++) { VE(zi,j)=designG[j*(*nx)+ci]; VE(Gbeta,id[ci])+=VE(zi,j)*VE(beta,j); } RR=exp(VE(Gbeta,id[ci])+offs[ci]); if (entry[ci]==1) { replace_row(X,id[ci],xi); replace_row(Z,id[ci],zi); scl_vec_mult(weights[ci]*RR,xi,tmpv1); replace_row(WX,id[ci],tmpv1); scl_vec_mult(weights[ci],zi,tmpv2); replace_row(WZ,id[ci],tmpv2); VE(weight,id[ci])=weights[ci]; if (*mof==1) VE(offset,id[ci])=offs[ci]; } else { replace_row(X,id[ci],rowX); replace_row(Z,id[ci],rowZ); replace_row(WX,id[ci],rowX); replace_row(WZ,id[ci],rowZ); VE(Gbeta,id[ci])=0; VE(weight,id[ci])=0; if (*mof==1) VE(offset,id[ci])=0; } S0+=entry[ci]*RR*weights[ci]; S0strata[stratum[ci+2]]+=entry[ci]*RR*weights[ci]; for(j=0;j1) { scl_mat_mult(1/S0strata[stratpers],ZPZs[stratpers],ZPZo); scl_mat_mult(1/S0strata[stratpers],ZPXs[stratpers],ZPXo); } // }}} if (s<0) { Rprintf("======================================================= %d \n",s); print_mat(A); print_mat(ZPX); print_mat(ZX); print_mat(A); print_mat(ZPZ); } if (stratum[0]==0) invertS(A,AI,ssilent); if (ME(AI,0,0)==0 && stratum[0]==0 && ssilent==0) { Rprintf("additive design X'X not invertible at time (number, value): %d %lf \n",s,time); print_mat(A); } if (ME(AI,0,0)==0 && stratum[0]==0 && ssilent==2) { Rprintf("additive design X'X not invertible at time (number, value) : %d %lf \n",s,time); print_mat(A); Rprintf("print only first time with non-invertible design X'X\n"); ssilent=0; } if (stratum[0]==1) { for (k=0;k<*px;k++) if (fabs(ME(A,k,k))<0.000001) ME(AI,k,k)=0; else ME(AI,k,k)=1/ME(A,k,k); } // computation of dA scale=VE(weight,pers); extract_row(X,pers,xi); scl_vec_mult(scale,xi,xi); Mv(AI,xi,dA); MxA(ZX,AI,ZXAI); // if (*detail==3) {print_vec(xi); print_mat(A); print_mat(AI); } if (propodds>0) { // intensity 1/(1+theta exp(Z^T beta) A(t-1)) xdA=vec_prod(xi,cumm); pweight=(1+propodds*exp(+VE(Gbeta,pers))*xdA); powi[s]=pweight; scl_vec_mult(pweight,dA,dA); } if (icaseweight==1) { pweight=caseweight[s]; // printf(" %lf \n",caseweight[s]); powi[s]=pweight; scl_vec_mult(pweight,dA,dA); } if (it==(*Nit-1)) { replace_row(dAt,s,dA); for (j=0;j<*pg;j++) for (i=0;i<*px;i++) ME(ZXAIn,j,(s-1)*(*px)+i)=ME(ZXAI,j,i); } if (s<0) {print_mat(A); print_mat(AI); print_mat(ZX); } /* First derivative U and Second derivative S */ extract_row(Z,pers,zi); scl_vec_mult(scale,zi,zi); Mv(ZX,dA,zav); // pweight multiplied onto dA and therefore already on zav if (propodds>0 || icaseweight==1) scl_vec_mult(pweight,zi,zi); vec_subtr(zi,zav,difzzav); // scl_vec_mult(scale,difzzav,difzzav); // if (propodds>0 || icaseweight==1) scl_vec_mult(pweight,difzzav,difzzav); vec_add(difzzav,U,U); if (it==((*Nit)-1)) if (*detail==3) {Rprintf(" time %d %lf %lf Dl contribution \n",s,scale,times[s]); print_vec(difzzav); } if (s<0) { // {{{ Rprintf(" %d %d %lf %lf \n",pers,s,time,scale); print_vec(xi); print_vec(dA); print_vec(zi); print_vec(zav); print_vec(difzzav); print_vec(U); print_mat(A); print_mat(AI); } // }}} if (*betafixed==0) // {{{ if (stratum[0]==0) if ( (((*exactderiv==1) && (it==(*Nit-1) ||(*Nit==0 && it==0)) && (*px>1))) || ((*exactderiv==2) && (*px>1)) ) { if (*detail==3) Rprintf("Computation of second derivative \n"); mat_zeros(ZPZ1); mat_zeros(ZPX1); for (i=0;i<*antpers;i++) { extract_row(WX,i,xi); // er det weight her, nej da !! VE(lamt,i)=vec_prod(xi,dA); extract_row(Z,i,zi); scl_vec_mult(VE(lamt,i),zi,rowZ); replace_row(ZP,i,rowZ); extract_row(X,i,xi); for(j=0;j0) scl_mat_mult(pweight,dS,dS); if (icaseweight==1) scl_mat_mult(pweight,dS,dS); // extra term for second derivative wrt beta if (propodds>0) { // (Z-E) Z exp(Z beta) x^T A(t-1) mat_add(dS,dSprop,dS); } if (*mw==1) {scale=VE(weight,pers); scl_mat_mult(scale,dS,dS); } mat_add(dS,S1,S1); if (it==((*Nit)-1)) if (*detail==4) { Rprintf(" time %d %d %lf D2l contribution \n",s,stratpers,times[s]); print_mat(ZPZo); print_mat(ZPXo); print_mat(ZXAI); Rprintf("============================================ \n"); print_mat(tmp2); print_mat(dS); print_mat(S1); // for (j=0;j=0) for (j=0;j<*pg;j++) for (i=0;i<*px;i++) { ME(M1M2n,j,(s-1)*(*px)+i)=ME(M1M2t,j,i); ME(Cn,(s-1)*(*px)+i,j)=ME(Ct,i,j); } for (k=1;k<=*px;k++) { cu[k*(*Ntimes)+s]=cu[k*(*Ntimes)+s-1]+VE(dA,k-1); cug[k*(*maxtimepoint)+timegroup[s]]=cu[k*(*Ntimes)+s]; vcu[k*(*Ntimes)+s]=VE(VdA,k-1)+vcu[k*(*Ntimes)+s-1]; } if (*robust==1 && basesim>=0) { for (j=0;j<*px;j++) for (i=0;i<*px;i++) ME(AIn,(s-1)*(*px)+j,i)=ME(AI,j,i); } } // }}} if (propodds>0) { // cumulative hazard (to use for prop odds model vec_add(dA,cumm,cumm); } } // }}} /* Ntimes */ if (timing==1) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: going through times %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} /* for (k=0;k<*pg;k++) ME(S1,k,k)=ME(S1,k,k)+*ridge; */ invertS(S1,SI,ssilent); if (*betafixed==0 ) { Mv(SI,U,delta); MxA(SI,VU,S2); MxA(S2,SI,VU); } if (*detail==1) { Rprintf("=============Iteration %d =============== \n",it); Rprintf("Estimate beta \n"); print_vec(beta); Rprintf("delta beta \n"); print_vec(delta); Rprintf("Score D l\n"); print_vec(U); Rprintf("Information -D^2 l\n"); print_mat(SI); }; // updates beta for all but final and fixed situation // double step=0.5; if (*betafixed==0 && (*Nit>0) && (it<*Nit-1)) { // scl_vec_mult(step,delta,delta); vec_add(beta,delta,beta); } for (k=0;k<*pg;k++) sumscore=sumscore+fabs(VE(U,k)); if ((sumscore<0.0000001) & (it<(*Nit)-2)) { it=*Nit-2; } } /* it */ // }}} if (*detail==2) Rprintf("Fitting done \n"); if (timing==2) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: fitting done %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} R_CheckUserInterrupt(); lle=0; llo=0; ci=0; for (k=0;k<*pg;k++) score[k]=VE(U,k); mat_zeros(A); mat_zeros(ZPZ); mat_zeros(ZPX); mat_zeros(ZX); mat_zeros(X); mat_zeros(Z); mat_zeros(WX); mat_zeros(WZ); vec_zeros(zav); if (*detail==2) Rprintf("robust==%d \n",*robust); if (*robust==1) // {{{ { for (s=1;s<*Ntimes;s++) // {{{ terms for robust variances { time=times[s]; cu[s]=times[s]; vcu[s]=times[s]; if (*robust==1) { Rvcu[timegroup[s]]=times[s]; cug[timegroup[s]]=times[s]; timesg[timegroup[s]]=times[s]; Ut[timegroup[s]]=times[s]; } R_CheckUserInterrupt(); sumscore=0; S0=0; for (j=0;j=time)) ) { for(j=0;j=0) ) ci=ci-1; } // }}} vec_zeros(rowX); vec_zeros(rowZ); if (s>1) // {{{ modifying design for next time points while ((stop[ci]=0) ) { VE(Gbeta,id[ci])=0; // vec_prod(zi,beta); for(j=0;j<*px;j++) VE(xi,j)=designX[j*(*nx)+ci]; for(j=0;j<*pg;j++) { VE(zi,j)=designG[j*(*nx)+ci]; VE(Gbeta,id[ci])+=VE(zi,j)*VE(beta,j); } RR=exp(VE(Gbeta,id[ci])+offs[ci]); if (entry[ci]==1) { replace_row(X,id[ci],xi); replace_row(Z,id[ci],zi); scl_vec_mult(RR*weights[ci],xi,tmpv1); // scl_vec_mult(RR,xi,tmpv1); replace_row(WX,id[ci],tmpv1); scl_vec_mult(weights[ci],zi,tmpv2); replace_row(WZ,id[ci],tmpv2); if (*mw==1) VE(weight,id[ci])=weights[ci]; if (*mof==1) VE(offset,id[ci])=offs[ci]; } else { replace_row(X,id[ci],rowX); replace_row(WX,id[ci],rowX); replace_row(Z,id[ci],rowZ); replace_row(WZ,id[ci],rowZ); VE(Gbeta,id[ci])=0; if (*mw==1) VE(weight,id[ci])=0; if (*mof==1) VE(offset,id[ci])=0; } S0+=entry[ci]*RR*weights[ci]; S0strata[stratum[ci+2]]+=entry[ci]*RR*weights[ci]; ci=ci-1; pers=id[ci]; stratpers=stratum[ci+2]; } // }}} ipers[s]=pers; // }}} // if (s<3) { head_matrix(X); head_matrix(WX); head_matrix(Z); head_matrix(WZ); } // extract_row(WX,pers,xi); extract_row(dAt,s,dA); // hati=vec_prod(xi,dA); lle=lle+log(hati); for (j=0;j<*pg;j++) for (i=0;i<*px;i++) ME(ZXAI,j,i)=ME(ZXAIn,j,(s-1)*(*px)+i); if (basesim>=0) { for (j=0;j<*px;j++) for (i=0;i<*px;i++) ME(AI,j,i)=ME(AIn,(s-1)*(*px)+j,i); } // print_mat(ZXAI); print_vec(dA); if (*ratesim==1 || *retur>=1) for (i=0;i<*antpers;i++) // {{{ { cin=cluster[i]; extract_row(WX,i,rowX); // RR*xi extract_row(Z,i,zi); extract_row(X,i,xi); hati=vec_prod(rowX,dA); if (*ratesim==1) { Mv(ZXAI,xi,tmpv2); vec_subtr(zi,tmpv2,tmpv2); if (*mw==1) { scl_vec_mult(VE(weight,i),tmpv2,tmpv2);} // weight adjustment if (i==pers) vec_add(tmpv2,W2[cin],W2[cin]); if (*ratesim==1) {scl_vec_mult(hati,tmpv2,rowZ); vec_subtr(W2[cin],rowZ,W2[cin]); } if (basesim>=0) { Mv(AI,xi,rowX); if (*mw==1) scl_vec_mult(VE(weight,i),rowX,rowX); if (i==pers) {vec_add(rowX,W3[cin],W3[cin]); } llo=llo+hati; if (*ratesim==1) {scl_vec_mult(hati,rowX,rowX); vec_subtr(W3[cin],rowX,W3[cin]);} } } if (*retur==1) dhatMit[i*(*Ntimes)+s]=1*(i==pers)-hati; if (*retur==2) dhatMit[i]=dhatMit[i]+1*(i==pers)-hati; } // }}} if (*ratesim==1) for (j=0;j<*antclust;j++) { replace_row(W2t[j],timegroup[s],W2[j]); if (basesim>=0) replace_row(W3t[j],timegroup[s],W3[j]); } if (*ratesim==0) // {{{ compute resampling counting process LWY style version { cin=cluster[pers]; extract_row(WX,pers,rowX); // RR*xi extract_row(Z,pers,zi); extract_row(X,pers,xi); Mv(ZXAI,xi,tmpv2); vec_subtr(zi,tmpv2,tmpv2); if (*mw==1) scl_vec_mult(VE(weight,pers),tmpv2,tmpv2); if (propodds>0 || icaseweight==1) scl_vec_mult(powi[s],tmpv2,tmpv2); vec_add(tmpv2,W2[cin],W2[cin]); // if (mjump==1) // for (j=0;j<*pg;j++) for (i=0;i<*pg;i++) // ME(Uicluster[cin],j,i)+=VE(tmpv2,j)*VE(tmpv2,i); if (basesim>=0) { Mv(AI,xi,rowX); if (*mw==1) scl_vec_mult(VE(weight,pers),rowX,rowX); if (propodds>0 || icaseweight==1) scl_vec_mult(powi[s],rowX,rowX); vec_add(rowX,W3[cin],W3[cin]); } // distrubes the increments to the end for each process with jumps for (s1=timegroup[s];s1<*maxtimepoint;s1++) // {{{ { // printf("W2t %d %d %d \n",cin,s1,*maxtimepoint); // print_mat(W2t[cin]); replace_row(W2t[cin],s1,W2[cin]); // printf("2 %d %d \n",cin,s1); if (basesim>=0) replace_row(W3t[cin],s1,W3[cin]); // if (mjump==1) { // cholesky(Uicluster[cin],tmp2); //// if (s1==timegroup[s]) { //// printf(" tmp2 %d \n",cin); //// print_vec(tmpv2); //// print_mat(Uicluster[cin]); //// print_mat(tmp2); //// MtM(tmp2,dS); //// print_mat(dS); //// } // for (j=0;j<*pg;j++) for (i=0;i<*pg;i++) ME(Uiclustert[cin],s1*(*pg)+j,i)=ME(tmp2,i,j); // } } // }}} } // }}} /* MG baseret varians beregning */ if (basesim>=0) // {{{ { for (j=0;j<*pg;j++) for (i=0;i<*px;i++) { ME(M1M2t,j,i)=ME(M1M2n,j,(s-1)*(*px)+i); ME(Ct,i,j)= ME(Cn,(s-1)*(*px)+i,j); } // printf(" s %d \n",s); // print_mat(Ct); MxA(Ct,VU,tmp3); MAt(tmp3,Ct,CtVUCt); // print_mat(CtVUCt); MxA(Ct,SI,tmp3); MxA(tmp3,M1M2t,COV); // print_mat(COV); for (k=1;k<=*px;k++) { if (*betafixed==0) vcu[k*(*Ntimes)+s]+=ME(CtVUCt,k-1,k-1)+2*ME(COV,k-1,k-1); // vcu[k*(*Ntimes)+s]+=ME(CtVUCt,k-1,k-1); } } // }}} for (k=1;k<=*pg;k++) Ut[k*(*maxtimepoint)+timegroup[s]]=ME(Utt,timegroup[s],k-1); } // }}} } // }}} if (timing==2) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: robust variance terms 1 %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} if (*detail==2) Rprintf("Robust variances 1 \n"); R_CheckUserInterrupt(); ll=lle-llo; /* likelihood beregnes */ if (*detail==2) Rprintf("loglike is %lf \n",ll); // check af score process er ok // int itest=1; // if (itest==1) // for (s=0;s<*maxtimepoint;s++) { // mat_zeros(S2); mat_zeros(dS); mat_zeros(SI); // mat_zeros(VUI); mat_zeros(ZPZ); // for (j=0;j<*antclust;j++) // { // extract_row(W2t[j],s,tmpv2); // for (k=0;k<*pg;k++) for (i=0;i<*pg;i++) ME(S2,k,i)+=VE(tmpv2,k)*VE(tmpv2,i); // if (mjump==1) { // for (k=0;k<*pg;k++) for (i=0;i<*pg;i++) ME(dS,k,i)=ME(Uiclustert[j],s*(*pg)+k,i); // mat_transp(dS,dS); // MtM(dS,VUI); // mat_add(VUI,ZPZ,ZPZ); // } //} //printf("score process variance %d \n",s); //print_mat(S2); //print_mat(ZPZ); //} if (*robust==1) // {{{ robust variances { for (s=1;s<*maxtimepoint;s++) { vec_zeros(VdB); mat_zeros(Vcov); for (j=0;j<*antclust;j++) // {{{ { if (s==1 && *detail==4) { Rprintf("========================= %d \n",j); print_mat(W2t[j]); print_vec(W2[j]); print_mat(Stg[s]); print_mat(S1); print_mat(SI); } Mv(SI,W2[j],tmpv2); if (basesim>=0) { Mv(Cg[s],tmpv2,rowX); extract_row(W3t[j],s,tmpv1); vec_add(tmpv1,rowX,difX); if (*betafixed==1) scl_vec_mult(1,tmpv1,difX); replace_row(W4t[j],s,difX); vec_star(difX,difX,tmpv1); vec_add(tmpv1,VdB,VdB); } if (s==1) if (*betafixed==0) { for (c=0;c<*pg;c++) gamiid[c*(*antclust)+j]=gamiid[c*(*antclust)+j]+VE(tmpv2,c); } if (*resample==1 && basesim>=0) { for (c=0;c<*px;c++) {l=j*(*px)+c; biid[l*(*maxtimepoint)+s]=biid[l*(*maxtimepoint)+s]+VE(difX,c); } } if (*covariance==1 && basesim>=0) { for (k=0;k<*px;k++) for (c=0;c<*px;c++) ME(Vcov,k,c)=ME(Vcov,k,c)+VE(difX,k)*VE(difX,c); } Mv(Stg[s],tmpv2,rowZ); extract_row(W2t[j],s,tmpv2); if (*detail==4) Rprintf("j,s is %d %d \n",j,s); if (*betafixed==0) { vec_subtr(tmpv2,rowZ,zi); replace_row(Uti[j],s,zi); // if (mjump==1 && *ratesim==0) // { // cholesky(Uicluster[j],tmp2); // mat_transp(tmp2,tmp2); // MxA(SI,tmp2,tmp2); // MxA(Stg[s],tmp2,dS); // for (c=0;c<*pg;c++) for (i=0;i<*pg;i++) ME(Uiclustert[j],s*(*pg)+c,i)-=ME(dS,c,i); // } } else replace_row(Uti[j],s,tmpv2); vec_star(zi,zi,tmpv2); vec_add(tmpv2,varUthat[s],varUthat[s]); } // }}} /* j in clusters */ if (*betafixed==0) for (i=0;i<*pg;i++) vscore[(i+1)*(*maxtimepoint)+s]=VE(varUthat[s],i); if (basesim>=0) for (k=1;k<*px+1;k++) { Rvcu[k*(*maxtimepoint)+s]=VE(VdB,k-1); if (*covariance==1) { for (j=0;j<*px;j++) { l=(k-1)*(*px)+j; Vcovs[l*(*maxtimepoint)+s]=ME(Vcov,k-1,j); } } } } /* s=1 ..maxtimepoints */ } // }}} robust variance //if (mjump==1 && *ratesim==0) //for (j=0;j<*antclust;j++) { // printf("observed score ========================== %d \n",j); // print_vec(W2[j]); // print_mat(Uicluster[j]); //} //if (mjump==2 && *ratesim==0) //for (j=0;j<*antclust;j++) { // printf("observed score ========================== %d \n",j); // print_mat(Uti[j]); // print_mat(Uiclustert[j]); //} if (timing==2) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: variance terms 2 %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} if (*detail==2) Rprintf("Robust variances 2 \n"); if ((*betafixed==0) && (*robust==1)) { for (j=0;j<*antclust;j++) { Mv(SI,W2[j],tmpv2); for (c=0;c<*pg;c++) for (k=0;k<*pg;k++) ME(RobVbeta,c,k)=ME(RobVbeta,c,k)+VE(W2[j],c)*VE(W2[j],k); for (k=0;k<*pg;k++) gammaiid[j*(*pg)+k]=VE(tmpv2,k); } MxA(RobVbeta,SI,ZPZ); MxA(SI,ZPZ,RobVbeta); } if (timing==2) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: variance terms 3 %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} R_CheckUserInterrupt(); for(j=0;j<*pg;j++) { betaS[j]= VE(beta,j); loglike[0]=lle; loglike[1]=ll; for (k=0;k<*pg;k++){ Iinv[k*(*pg)+j]=ME(SI,j,k); Vbeta[k*(*pg)+j]=-ME(VU,j,k); RVbeta[k*(*pg)+j]=-ME(RobVbeta,j,k); } } // printf("cholesky"); cholesky(SI,VU); print_mat(SI); print_mat(VU); // MtM(VU,SI); print_mat(SI); if (timing==2) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: variance terms 4 %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} // check af observed score process er ok , sammenligning af variancer til // int itest1=1; // if (itest1==1 ) // for (s=0;s<*maxtimepoint;s++) { // mat_zeros(S2); mat_zeros(dS); mat_zeros(VUI); mat_zeros(ZPZ); // for (j=0;j<*antclust;j++) // { // extract_row(Uti[j],s,tmpv2); // for (k=0;k<*pg;k++) for (i=0;i<*pg;i++) ME(S2,k,i)+=VE(tmpv2,k)*VE(tmpv2,i); // if (mjump==1) { // for (k=0;k<*pg;k++) for (i=0;i<*pg;i++) ME(dS,k,i)=ME(Uiclustert[j],s*(*pg)+k,i); // print_mat(dS); //// mat_transp(dS,dS); // MtM(dS,ZPZ); // printf("obs Score %d %d \n",s,j); // print_mat(ZPZ); // mat_add(ZPZ,VUI,VUI); // } //} //printf(" %d \n",s); //print_mat(S2); //print_mat(VUI); //} // for(j=0;j<*antclust;j++) print_mat(Uti[j]); if (*detail==2) Rprintf("Ready for simulations antsim =%d\n",*antsim); if (*antsim>0) // {{{ score process simulations { // Rprintf("Simulations start N= %ld \n",(long int) *antsim); tau=times[*Ntimes-1]-times[0]; for (i=1;i<=*px;i++) VE(rowX,i-1)=cug[i*(*maxtimepoint)+(*maxtimepoint-1)]; for (s=1;s<*maxtimepoint;s++) // {{{ /* Beregning af OBS teststorrelser */ { time=timesg[s]-times[0]; // FIX if (basesim>0) // {{{ { if ((timesg[s]>basestart)) { for (i=1;i<=*px;i++) { VE(xi,i-1)=fabs(cug[i*(*maxtimepoint)+s])/sqrt(Rvcu[i*(*maxtimepoint)+s]); if (VE(xi,i-1)>testOBS[i-1]) testOBS[i-1]=VE(xi,i-1); } } scl_vec_mult(time/tau,rowX,difX); for (i=1;i<=*px;i++) VE(xi,i-1)=cug[i*(*maxtimepoint)+s]; vec_subtr(xi,difX,difX); if ((s>*wscore) && (s<*maxtimepoint-*wscore)) { for (i=0;i<*px;i++) { VE(difX,i)=fabs(VE(difX,i)); l=(*px+i); if (VE(difX,i)>testOBS[l]) testOBS[l]=VE(difX,i); } } } // }}} if (*wscore>=1) { /* sup beregnes i R */ if ((s>*wscore) && (s<*maxtimepoint-*wscore)) {extract_row(Utt,s,rowZ); for (i=0;i<*pg;i++) VE(rowZ,i) = VE(rowZ,i)/sqrt(VE(varUthat[s],i)); replace_row(Utt,s,rowZ); /* scaled score process */ } else {vec_zeros(rowZ); replace_row(Utt,s,rowZ);} } for (k=1;k<=*pg;k++) Ut[k*(*maxtimepoint)+s]=ME(Utt,s,k-1); } // }}} *s=1..maxtimepoint Beregning af obs teststorrelser if (*detail==2) Rprintf("Simulations start N= %ld \n",(long int) *antsim); for (k=1;k<=*antsim;k++) // {{{ k=1,...,antsim { R_CheckUserInterrupt(); if (basesim>0) mat_zeros(Delta); mat_zeros(Delta2); vec_zeros(tmpv1); for (i=0;i<*antclust;i++) // {{{ { random=norm_rand(); if (basesim>0) { scl_mat_mult(random,W4t[i],tmpM1); mat_add(tmpM1,Delta,Delta); } // if ((mjump==0 && *ratesim==0) || (*ratesim==1)) { // random=norm_rand(); scl_mat_mult(random,Uti[i],tmpM2); mat_add(tmpM2,Delta2,Delta2); // } else { // for (c=0;c<*pg;c++) VE(ranvec,c)=norm_rand(); // Mv(Uiclustert[i],ranvec,vectmp); // for (c=0;c<*maxtimepoint;c++) // for (l=0;l<*pg;l++) ME(tmpM2,c,l)=VE(vectmp,c*(*pg)+l); // mat_add(tmpM2,Delta2,Delta2); // } } // }}} if (basesim>0) extract_row(Delta,*maxtimepoint-1,tmpv1); for (s=1;s<*maxtimepoint;s++) { time=timesg[s]-times[0]; if (basesim>0) // {{{ { scl_vec_mult(time/tau,tmpv1,xi); extract_row(Delta,s,rowX); vec_subtr(rowX,xi,difX); if (*addresamp==1) { if (k<51) for (i=0;i<*px;i++) {l=(k-1)*(*px)+i; addproc[l*(*maxtimepoint)+s]=ME(Delta,s,i);} } for (i=0;i<*px;i++) { VE(difX,i)=fabs(VE(difX,i)); l=(*px+i); if (VE(difX,i)>test[l*(*antsim)+k-1]) test[l*(*antsim)+k-1]=VE(difX,i); if ((timesg[s]>basestart)) { VE(xi,i)=fabs(ME(Delta,s,i))/sqrt(Rvcu[(i+1)*(*maxtimepoint)+s]); if (VE(xi,i)>test[i*((*antsim))+k-1]) test[i*((*antsim))+k-1]=VE(xi,i); } } } // }}} if (*wscore>=1) {/*{{{*/ extract_row(Delta2,s,zi); if ((s>*wscore) && (s<*maxtimepoint-*wscore)) { for (i=0;i<*pg;i++) {VE(zi,i)=fabs(ME(Delta2,s,i))/sqrt(VE(varUthat[s],i)); if (VE(zi,i)>simUt[i*(*antsim)+k-1]) simUt[i*(*antsim)+k-1]=VE(zi,i); } if (k<50) { for (i=0;i<*pg;i++) { l=(k-1)*(*pg)+i; Uit[l*(*maxtimepoint)+s]=ME(Delta2,s,i)/sqrt(VE(varUthat[s],i));}} } } /* weighted score */ else { extract_row(Delta2,s,zi); for (i=0;i<*pg;i++) { if (fabs(VE(zi,i))>simUt[i*(*antsim)+k-1]) simUt[i*(*antsim)+k-1]=fabs(VE(zi,i)); } if (k<50) { for (i=0;i<*pg;i++) { l=(k-1)*(*pg)+i; Uit[l*(*maxtimepoint)+s]=ME(Delta2,s,i);} } } /* else wscore=0 */ /*}}}*/ } /* s=1..Ntims */ } // }}} /* k=1..antsim */ } /* sim==1 */ // }}} if (timing==2) { // {{{ c1=clock(); Rprintf ("\telapsed CPU time: before freeing %f\n", (float) (c1 - c0)/CLOCKS_PER_SEC); c0=clock(); } // }}} PutRNGstate(); /* to use R random normals */ if (*detail==2) Rprintf("Freeing "); // {{{ freeing if (antsim[0]>0) free_mats(&Delta2,&tmpM2,NULL); if (basesim>0) free_mats(&Delta,&tmpM1,NULL); if (basesim>=0) free_mats(&Cn,&M1M2n,&AIn,NULL); free_mats(&ZXAIn,NULL); free_mats(&dAt,&Utt,&WX,&X,&cdesX,&cdesX2,&cdesX3, &WZ,&ZP,&Z, &Vcov,&COV,&A,&AI,&M1,&CtVUCt, &RobVbeta,&ZPZ,&tmp2,&dSprop,&dS,&S1,&S2,&SI,&VU,&VUI, &ZXAI,&ZX,&dM1M2,&M1M2t, &tmp3,&ZPX,&dYI,&Ct, &ZPX1,&ZPZ1, &ZPXo,&ZPZo,NULL); free_vecs(&vectmp,&ranvec,&reszpbeta,&res1dim,&weight,&lamtt,&lamt,&zcol,&Gbeta,&one,&offset, &ahatt,&tmpv1,&difX,&VdB,&rowX,&xi,&dA,&VdA,&MdA,&cumm, &xtilde, &tmpv2,&rowZ,&zi,&U,&beta,&delta,&zav,&difzzav,&Uprofile, &ta,&vrisk,NULL); if (*robust==1) { for (j=0;j<*antclust;j++) { free_vec(W2[j]); if (basesim>=0) { free_mat(W3t[j]); free_mat(W4t[j]); free_vec(W3[j]); } free_mat(W2t[j]); free_mat(Uti[j]); free_vec(Ui[j]); } for (j=0;j<*maxtimepoint;j++) free_vec(varUthat[j]); } // if (*ratesim==0 && mjump==1) { // for(j=0;j<*antclust;j++) { free_mat(Uiclustert[j]); free_mat(Uicluster[j]); } // } for(j=0;j<*maxtimepoint;j++) { free_mat(Cg[j]); free_mat(Stg[j]);} free(cluster); free(ipers); free(imin); free(cug); free(timesg); free(S0strata); free(strata); free(powi); // free(caseweight); // }}} for (j=0;j //#include #include #include #define USE_FC_LEN_T #include #include #include #include #include #include "matrix.h" #ifndef FCONE #define FCONE #endif void free_mat(matrix *M){ R_Free(M->entries); R_Free(M); } void free_mat3(matrix3 *M){ R_Free(M->entries); R_Free(M); } void free_vec(vector *V){ R_Free(V->entries); R_Free(V); } int nrow_matrix(matrix *M){ return M->nr; } int ncol_matrix(matrix *M){ return M->nc; } int length_vector(vector *v){ return v->length; } void print_a_matrix(matrix *M){ int j, k; for(j=0; j < nrow_matrix(M); j++){ for(k = 0; k < ncol_matrix(M); k++){ Rprintf("%+7.7g ", ME(M,j,k)); } Rprintf("\n"); } } /* DPOTRI - compute the inverse of a real symmetric positive */ /* definite matrix A using the Cholesky factorization A = U**T*U */ /* or A = L*L**T computed by DPOTRF */ //extern void F77_SUB(dpotri)(const char* uplo, const int* n, double* a, const int* lda, int* info); // /* DPOTRF - compute the Cholesky factorization of a real */ /* symmetric positive definite matrix A */ //extern void F77_SUB(dpotrf)(const char* uplo, const int* n, double* a, const int* lda, int* info); // //extern void F77_SUB(dgemm)(const char *transa, const char *transb, const int *m, // const int *n, const int *k, const double *alpha, // const double *a, const int *lda, // const double *b, const int *ldb, // const double *beta, double *c, const int *ldc); // /* DGEMV - perform one of the matrix-vector operations */ /* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ // //extern void F77_SUB(dgemv)(const char *trans, const int *m, const int *n, // const double *alpha, const double *a, const int *lda, // const double *x, const int *incx, const double *beta, // double *y, const int *incy); // // /* DGETRF - compute an LU factorization of a general M-by-N */ /* matrix A using partial pivoting with row interchanges */ //extern void F77_SUB(dgetrf)(const int* m, const int* n, double* a, const int* lda, int* ipiv, int* info); // // /* DGETRI - compute the inverse of a matrix using the LU */ /* factorization computed by DGETRF */ //extern void F77_SUB(dgetri)(const int* n, double* a, const int* lda, int* ipiv, double* work, const int* lwork, int* info); // cumsum of matrix apply(X,2,cusum) // rev=1 apply(X[n:1,],2,cumsum)[n:1,] // for rev=1 possible to return only apply(X[n:1,],2,cumsum)[nindex,] void cumsumM(matrix *M, matrix *Mout,int rev,int weighted,double *weights) { int i,j,p=ncol_matrix(M),n=nrow_matrix(M); double lweights[n]; matrix *temp; malloc_mat(n,p,temp); if( !( (ncol_matrix(M) == ncol_matrix(Mout)) )) { oops("Error: dimensions in cumsumM\n"); } for(i=0;i0) for(i = 0;i0) for(i = 0;ientries, &lda, M->entries, &ldb, &beta, A->entries, &ldc FCONE FCONE); } else { // if M and A occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(A),ncol_matrix(A),temp); F77_CALL(dgemm)(&transa, &transb, &m, &n, &k, &alpha, M->entries, &lda, M->entries, &ldb, &beta, temp->entries, &ldc FCONE FCONE); //F77_CALL(dgemm)("N", "T", &nrx, &ncy, &ncx, &one, x, &nrx, y, &nry, &zero, z, &nrx FCONE FCONE); // Copy these results into A, then remove the temporary matrix mat_copy(temp,A); free_mat(temp); } } // Does cholesky of := A, where A is symmetric positive definite, of order *n void cholesky(matrix *A, matrix *AI){ // {{{ if( !(nrow_matrix(A) == ncol_matrix(A) && nrow_matrix(AI) == ncol_matrix(AI) && nrow_matrix(A) == ncol_matrix(AI)) ){ oops("Error: dimensions in invertSPD\n"); } // Ensure that A and AI do not occupy the same memory. if(A != AI){ // printf(" er her\n"); choleskyunsafe(A, AI); } else { // if M and A occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(AI),ncol_matrix(AI),temp); choleskyunsafe(A, temp); // Copy these results into AI, then remove the temporary matrix mat_copy(temp,AI); free_mat(temp); } } // }}} // cholesky := A, where A is symmetric positive definite, of order *n void choleskyunsafe(matrix *A, matrix *AI){ // {{{ //unsafe because it assumes A and AI are both square and of the same //dimensions, and that they occupy different memory // char uplo = 'U'; // lower version int i, j; int n = nrow_matrix(A); // int lda = n; // matrix A has dimensions *n x *n int info = -999; // double rcond; // int pivot[n]; // double z[n]; // double qraux[n]; // double work[2*n]; // int rank = 0; // int job=1; // double tol = 1.0e-07; // First copy the matrix A into the matrix AI // print_mat(A); mat_copy(A,AI); // print_mat(AI); // printf("sssssssssss======================\n"); // job = 1; // Indicates that AI is upper triangular // rcond = 999.0; // First find the Cholesky factorization of A, // stored as an upper triangular matrix char uplo1 = 'U'; // lower version F77_CALL(dpotrf)(&uplo1, &n, AI->entries, &n, &info FCONE); // Lastly turn the vector a into the matrix AI // Take only the lower triangular portion, since this // is the relevant part returned by dpotrf for(i = 0; i < n; i++){ for(j = 0; j < i; j++){ ME(AI,i,j) = 0; } } // print_mat(AI); // Rprintf("in chol \n"); // printf("======================\n"); // print_mat(A); // print_mat(AI); // printf(" check chol back\n"); // matrix *tmp; // malloc_mat(n,n,tmp); // MtM(AI,tmp); // print_mat(tmp); // free_mat(tmp); } // }}} // Does AI := inverse(A), where A is symmetric positive definite, of order *n void invertSPD(matrix *A, matrix *AI){ if( !(nrow_matrix(A) == ncol_matrix(A) && nrow_matrix(AI) == ncol_matrix(AI) && nrow_matrix(A) == ncol_matrix(AI)) ){ oops("Error: dimensions in invertSPD\n"); } // Ensure that A and AI do not occupy the same memory. if(A != AI){ invertSPDunsafe(A, AI); } else { // if M and A occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(AI),ncol_matrix(AI),temp); invertSPDunsafe(A, temp); // Copy these results into AI, then remove the temporary matrix mat_copy(temp,AI); free_mat(temp); } } // Does AI := inverse(A), where A is symmetric positive definite, of order *n void invertSPDunsafe(matrix *A, matrix *AI){ //unsafe because it assumes A and AI are both square and of the same //dimensions, and that they occupy different memory char uplo = 'U'; int i, j; int n = nrow_matrix(A); int lda = n; // matrix A has dimensions *n x *n int info = -999; double rcond; int pivot[n]; double z[n]; double qraux[n]; double work[2*n]; int rank = 0; int job=1; double tol = 1.0e-07; // First copy the matrix A into the matrix AI for(i = 0; i < n; i++){ for(j = 0; j < n; j++){ ME(AI,i,j) = ME(A,i,j); } } // dqrdc(x,ldx,n,p, qraux,jpvt,work,job) // F77_CALL(dqrdc)(AI->entries, &n, &n, &n, &rank, qraux, pivot, work,job); // dqrdc2(x,ldx,n,p,tol,k,qraux,jpvt,work) F77_CALL(dqrdc2)(AI->entries, &n, &n, &n, &tol, &rank, qraux, pivot, work); for(i = 0; i < n; i++){ for(j = 0; j < i; j++){ ME(AI,j,i) = 0.0; } } job = 1; // Indicates that AI is upper triangular rcond = 999.0; F77_CALL(dtrco)(AI->entries, &n, &n, &rcond, z, &job); if(rcond < tol){ Rprintf("Error in invertSPD: estimated condition number = %7.7e\n",1/rcond); for(i = 0; i < n; i++){ for(j = 0; j < n; j++){ ME(AI,i,j) = 0.0; } } } else { for(i = 0; i < n; i++){ pivot[i] = i+1; for(j = 0; j < n; j++){ ME(AI,i,j) = ME(A,i,j); } } // First find the Cholesky factorization of A, // stored as an upper triangular matrix F77_CALL(dpotrf)(&uplo, &n, AI->entries, &lda, &info FCONE); if(info < 0){ Rprintf("Error in invertSPD: arg %d of DPOTRF\n",-info); } else if(info > 0){ Rprintf("Error in invertSPD: matrix does not appear to be SPD\n"); } // then use this factorization to compute the inverse of A F77_CALL(dpotri)(&uplo, &n, AI->entries, &lda, &info FCONE); if(info != 0){ Rprintf("Error in invertSPD: DPOTRI returned info = %d \n",info); } // Lastly turn the vector a into the matrix AI // Take only the upper triangular portion, since this // is the relevant part returned by dpotrf for(i = 0; i < n; i++){ for(j = 0; j < i; j++){ ME(AI,i,j) = ME(AI,j,i); } } } } // v2 := M %*% v1 // where M has dims (nrow x ncol) // and v1 has dims (ncol x 1 ) // amd v2 has dims (nrow x 1 ) void Mv(matrix *M, vector *v1, vector *v2){ char trans = 'n'; double alpha = 1.0; double beta = 0.0; int incx = 1; int incy = 1; int nrow = nrow_matrix(M); int ncol = ncol_matrix(M); if( !(length_vector(v1) == ncol && length_vector(v2) == nrow) ){ oops("Error: dimensions in Mv\n"); } // Ensure that v1 and v2 do not occupy the same memory. if(v1 != v2){ F77_CALL(dgemv)(&trans, &nrow, &ncol, &alpha, M->entries, &nrow, v1->entries, &incx, &beta, v2->entries, &incy FCONE); } else { // if v1 and v2 occupy the same memory, store the results in a // temporary vector. vector *temp; malloc_vec(length_vector(v2),temp); F77_CALL(dgemv)(&trans, &nrow, &ncol, &alpha, M->entries, &nrow, v1->entries, &incx, &beta, temp->entries, &incy FCONE); // Copy these results into A, then remove the temporary matrix vec_copy(temp,v2); free_vec(temp); } } // v2 := v1 %*% matrix // where v1 has dims (1 x nrow) // and matrix has dims (nrow x ncol) // amd v2 has dims (1 x ncol) void vM(matrix *M, vector *v1, vector *v2){ char trans = 't'; double alpha = 1.0; double beta = 0.0; int incx = 1; int incy = 1; int nrow = nrow_matrix(M); int ncol = ncol_matrix(M); if( !(length_vector(v1) == nrow && length_vector(v2) == ncol) ){ oops("Error: dimensions in vM\n"); } // Ensure that v1 and v2 do not occupy the same memory. if(v1 != v2){ F77_CALL(dgemv)(&trans, &nrow, &ncol, &alpha, M->entries, &nrow, v1->entries, &incx, &beta, v2->entries, &incy FCONE ); } else { // if v1 and v2 occupy the same memory, store the results in a // temporary vector. vector *temp; malloc_vec(length_vector(v2),temp); F77_CALL(dgemv)(&trans, &nrow, &ncol, &alpha, M->entries, &nrow, v1->entries, &incx, &beta, temp->entries, &incy FCONE); // Copy these results into A, then remove the temporary matrix vec_copy(temp,v2); free_vec(temp); } } // v3 := v1 * v2, where * is the Hadamard (componentwise) product of the // two vectors, which is the same as * does in R for vectors of the same length vector *vec_star(vector *v1, vector *v2, vector *v3){ int i; int n = length_vector(v1); if( !(length_vector(v2) == n && length_vector(v3) == n) ){ oops("Error: dimensions in vec_star\n"); } for(i = 0; i < n; i++){ VE(v3,i) = VE(v1,i)*VE(v2,i); } return(v3); } // := v1^T * v2, inner product // two vectors double vec_prod(vector *v1, vector *v2){ double sum = 0.0; int i; int n = length_vector(v1); if( !(length_vector(v2) == n) ){ oops("Error: dimensions in vec_star\n"); } for(i = 0; i < n; i++){ sum += VE(v1,i)*VE(v2,i); } return sum; } // Sums the entries of a vector of length n double vec_sum(vector *v){ double sum = 0.0; int i; int n = length_vector(v); for(i = 0; i < n; i++){ sum += VE(v,i); } return sum; } // Sums the entries of a vector of length n vector *vec_ones(vector *v){ int i; int n = length_vector(v); for(i = 0; i < n; i++){ VE(v,i) = 1.0; } return(v); } // Returns the minimum of the entries of a vector of length n double vec_min(vector *v, int *imin){ double Min = VE(v,0); int i; int n = length_vector(v); *imin = 0; for(i = 1; i < n; i++){ if(VE(v,i) < Min){ Min = VE(v,i); *imin = i; } } return Min; } // set all entries of an *nrow x *ncol matrix M to zero void mat_zeros(matrix *M){ int j, k; for(j=0; j < nrow_matrix(M); j++){ for(k = 0; k < ncol_matrix(M); k++){ ME(M,j,k) = 0.0; } } } // set all entries of vector v of length *length to zero void vec_zeros(vector *v){ int j; for(j=0; j < length_vector(v); j++){ VE(v,j) = 0.0; } } // Simple I/O function that prints a matrix void print_mat(matrix *M){ int j, k; Rprintf("Matrix nrow=%d ncol=%d \n",nrow_matrix(M),ncol_matrix(M)); for(j=0; j < nrow_matrix(M); j++){ for(k = 0; k < ncol_matrix(M); k++){ // Rprintf("%5.5g ", ME(M,j,k)); // Rprintf("%+15.15g ", ME(M,j,k)); Rprintf("%lf ", ME(M,j,k)); } Rprintf("\n"); } Rprintf("\n"); } // Simple I/O function that prints the top of a matrix void head_matrix(matrix *M){ int j, k; Rprintf("head:Matrix nrow=%d ncol=%d \n",nrow_matrix(M),ncol_matrix(M)); for(j=0; j < min(nrow_matrix(M),6); j++){ for(k = 0; k < min(ncol_matrix(M),6); k++){ //Rprintf("%5.5g ", ME(M,j,k)); Rprintf("%lf ", ME(M,j,k)); } Rprintf("\n"); } Rprintf("\n"); } // Simple I/O function that prints the first few entries of a vector void head_vector(vector *V){ int j; Rprintf("head:Vector lengthn=%d \n",length_vector(V)); for(j=0; j < min(length_vector(V),6); j++){ Rprintf("%lf ", VE(V,j)); } Rprintf("\n"); } // Simple I/O function that prints a vector void print_vec(vector *v){ int j; Rprintf("Vector lengthn=%d \n",length_vector(v)); for(j=0; j < length_vector(v); j++){ Rprintf("%lf ", VE(v,j)); } Rprintf("\n\n"); } // sets v := M[row_to_get,] vector *extract_row(matrix *M, int row_to_get, vector *v){ int j; if(!(length_vector(v) == ncol_matrix(M))){ oops("Error: dimensions in extract_row\n"); } if(row_to_get >= 0 && row_to_get < nrow_matrix(M)){ for(j = 0; j < length_vector(v); j++){ VE(v,j) = ME(M,row_to_get,j); } return(v); } else { oops("Error: trying to get an invalid row in 'extract_row'\n"); } return(v); } // sets M[row_to_get,] := v void replace_row(matrix *M, int row_to_set, vector *v){ int j; if(!(length_vector(v) == ncol_matrix(M))){ oops("Error: dimensions in replace_row\n"); } if(row_to_set >= 0 && row_to_set < nrow_matrix(M)){ for(j = 0; j < ncol_matrix(M); j++){ ME(M,row_to_set,j) = VE(v,j); } } else { oops("Error: trying to get an invalid row in 'replace_row'\n"); } } // v3 := v1 + v2, where the three vectors have length void vec_add(vector *v1, vector *v2, vector *v3){ int i; int n = length_vector(v1); if( !(length_vector(v2) == n && length_vector(v3) == n) ){ oops("Error: dimensions in vec_addition\n"); } for(i=0; i < n; i++){ VE(v3,i) = VE(v1,i) + VE(v2,i); } } // v3 := v1 + s * v2, where the three vectors have length, // and s is a double scalar void vec_add_mult(vector *v1, vector *v2, double s, vector *v3){ int i; int n = length_vector(v1); if( !(length_vector(v2) == n && length_vector(v3) == n) ){ oops("Error: dimensions in vec_addition\n"); } for(i=0; i < n; i++){ VE(v3,i) = VE(v1,i) + s*VE(v2,i); } } // v2 := scalar * v1, where invec and outvec are vectors of // length *length, and *scalar is a (double) scalar vector *scl_vec_mult(double scalar, vector *v1, vector *v2){ int i; int n = length_vector(v1); if( !(length_vector(v2) == n) ){ oops("Error: dimensions in scl_vec_mult\n"); } for(i=0; i < n; i++){ VE(v2,i) = scalar * VE(v1,i); } return(v2); } // m2 := scalar * m1 matrix *scl_mat_mult(double scalar, matrix *m1, matrix *m2){ int i,j; int m = nrow_matrix(m1); int n = ncol_matrix(m1); if( !(nrow_matrix(m1) == m && ncol_matrix(m1) == n) ){ oops("Error: dimensions in scl_vec_mult\n"); } for(i=0; i < m; i++){ for(j=0; j < n; j++){ ME(m2,i,j) = ME(m1,i,j) * scalar; } } return(m2); } // m2 := m1 matrix *mat_copy(matrix *m1, matrix *m2){ int i,j; int m = nrow_matrix(m1); int n = ncol_matrix(m1); if( !(nrow_matrix(m2) == m && ncol_matrix(m2) == n) ){ oops("Error: dimensions in copy_matrix\n"); } if(m1 == m2){ oops("copy_matrix was asked to write one matrix into its own memory\nThere may be an error...\n"); } for(i=0; i < m; i++){ for(j=0; j < n; j++){ ME(m2,i,j) = ME(m1,i,j); } } return(m2); } // v2 := v1 vector *vec_copy(vector *v1, vector *v2){ int i; int l = length_vector(v1); if( !(length_vector(v2) == l) ){ oops("Error: dimensions in copy_vector\n"); } if(v1 == v2){ oops("copy_vector was asked to write one matrix into its own memory\nThere may be an error...\n"); } for(i=0; i < l; i++){ VE(v2,i) = VE(v1,i); } return(v2); } // m2 := m1 void mat_subsec(matrix *m1, int rowStart, int colStart, int rowStop, int colStop, matrix *m2){ int i,j; int m = nrow_matrix(m1); int n = ncol_matrix(m1); if( !(nrow_matrix(m2) == (rowStop-rowStart) && ncol_matrix(m2) == (colStop-colStart)) ){ oops("Error: dimensions in mat_subsec\n"); } else if(!(rowStart >= 0 && colStart >= 0 && rowStop < m && colStop < n)){ oops("Error: trying to access non-existing rows or cols in mat_subsec\n"); } if(m1 == m2){ oops("matrix_subsec was asked to write one matrix into its own memory\nThere may be an error...\n"); } for(i=rowStart; i < rowStop; i++){ for(j=colStart; j < colStop; j++){ ME(m2,i-rowStart,j-colStart) = ME(m1,i,j); } } } // m2 := t(m1) matrix *mat_transp(matrix *m1, matrix *m2){ int i,j; int m = nrow_matrix(m1); int n = ncol_matrix(m1); if( !(ncol_matrix(m2) == m && nrow_matrix(m2) == n) ){ oops("Error: dimensions in mat_transp\n"); } // Ensure that m1 and m2 do not occupy the same memory. if(m1 != m2){ for(i=0; i < m; i++){ for(j=0; j < n; j++){ ME(m2,j,i) = ME(m1,i,j); } } } else { // if v1 and v2 occupy the same memory, store the results in a // temporary vector. matrix *temp; malloc_mat(nrow_matrix(m2),ncol_matrix(m2),temp); for(i=0; i < m; i++){ for(j=0; j < n; j++){ ME(temp,j,i) = ME(m1,i,j); } } // Copy these results into A, then remove the temporary matrix mat_copy(temp,m2); free_mat(temp); } return(m2); } // v3 := v1 - v2, where the three vectors have length *length void vec_subtr(vector *v1, vector *v2, vector *v3){ int i; int n = length_vector(v1); if( !(length_vector(v2) == n && length_vector(v3) == n) ){ oops("Error: dimensions in vec_subtraction\n"); } for(i=0; i < n; i++){ VE(v3,i) = VE(v1,i) - VE(v2,i); } } // m3 := m1 - m2, where the three matrix have the same dimentions void mat_subtr(matrix *m1, matrix *m2, matrix *m3){ int i,j; int m = nrow_matrix(m1); int n = ncol_matrix(m1); if( !(nrow_matrix(m2) == m && ncol_matrix(m2) == n && nrow_matrix(m3) == m && ncol_matrix(m3) == n) ){ oops("Error: dimensions in mat_subtr\n"); } for(i=0; i < m; i++){ for(j=0; j < n; j++){ ME(m3,i,j) = ME(m1,i,j) - ME(m2,i,j); } } } // m3 := m1 + m2, where the three matrix have the same dimentions void mat_add(matrix *m1, matrix *m2, matrix *m3){ int i,j; int m = nrow_matrix(m1); int n = ncol_matrix(m1); if( !(nrow_matrix(m2) == m && ncol_matrix(m2) == n && nrow_matrix(m3) == m && ncol_matrix(m3) == n) ){ oops("Error: dimensions in mat_subtr\n"); } for(i=0; i < m; i++){ for(j=0; j < n; j++){ ME(m3,i,j) = ME(m1,i,j) + ME(m2,i,j); } } } // Performs Mout := t(M) %*% A, where M is an nRowM x nColM matrix, // and A is an nRowM x nColA matrix, and Mout is a nColM x nColA matrix void MtA(matrix *M, matrix *A, matrix *Mout){ char transa = 't'; char transb = 'n'; double alpha = 1.0; double beta = 0.0; int m = ncol_matrix(M); int n = ncol_matrix(A); int k = nrow_matrix(M); int lda = nrow_matrix(M); int ldb = nrow_matrix(M); int ldc = ncol_matrix(M); if( !(nrow_matrix(M) == nrow_matrix(A) && nrow_matrix(Mout) == ncol_matrix(M) && ncol_matrix(Mout) == ncol_matrix(A)) ){ oops("Error: dimensions in MtA\n"); } // Ensure that Mout does not occupy the same memory as M or A if(Mout != A && Mout != M){ // the results of 1.0 * t(M) %*% A + 0.0 * Mout is stored in Mout F77_CALL(dgemm)(&transa, &transb, &m, &n, &k, &alpha, M->entries, &lda, A->entries, &ldb, &beta, Mout->entries, &ldc FCONE FCONE); } else { // if M and A occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(Mout),ncol_matrix(Mout),temp); // the results of 1.0 * t(M) %*% A + 0.0 * Mout is stored in temp F77_CALL(dgemm)(&transa, &transb, &m, &n, &k, &alpha, M->entries, &lda, A->entries, &ldb, &beta, temp->entries, &ldc FCONE FCONE); // Copy these results into A, then remove the temporary matrix mat_copy(temp,Mout); free_mat(temp); } } // Performs Mout := M %*% t(A), where M is an nRowM x nColM matrix, // and A is an nRowA x nColM matrix, and Mout is a nRowM x nRowA matrix void MAt(matrix *M, matrix *A, matrix *Mout){ char transa = 'n'; char transb = 't'; double alpha = 1.0; double beta = 0.0; int m = nrow_matrix(M); int n = nrow_matrix(A); int k = ncol_matrix(M); int lda = nrow_matrix(M); int ldb = nrow_matrix(A); int ldc = nrow_matrix(Mout); if( !(ncol_matrix(M) == ncol_matrix(A) && nrow_matrix(Mout) == nrow_matrix(M) && ncol_matrix(Mout) == nrow_matrix(A)) ){ oops("Error: dimensions in MAt\n"); } // Ensure that Mout does not occupy the same memory as M or A if(Mout != A && Mout != M){ // the results of 1.0 * t(M) %*% A + 0.0 * Mout is stored in Mout F77_CALL(dgemm)(&transa, &transb, &m, &n, &k, &alpha, M->entries, &lda, A->entries, &ldb, &beta, Mout->entries, &ldc FCONE FCONE); } else { // if M and A occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(Mout),ncol_matrix(Mout),temp); // the results of 1.0 * t(M) %*% A + 0.0 * Mout is stored in temp F77_CALL(dgemm)(&transa, &transb, &m, &n, &k, &alpha, M->entries, &lda, A->entries, &ldb, &beta, temp->entries, &ldc FCONE FCONE); // Copy these results into Mout, then remove the temporary matrix mat_copy(temp,Mout); free_mat(temp); } } // Does Ainv := inverse(A), where A is a square matrix void invert(matrix *A, matrix *Ainv){ if( !(nrow_matrix(A) == ncol_matrix(A) && nrow_matrix(Ainv) == ncol_matrix(Ainv) && nrow_matrix(A) == ncol_matrix(Ainv)) ){ oops("Error: dimensions in invert\n"); } // Ensure that A and Ainv do not occupy the same memory. if(A != Ainv){ invertUnsafe(A, Ainv); } else { // if A and Ainv occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(Ainv),ncol_matrix(Ainv),temp); invertUnsafe(A, temp); // Copy these results into Ainv, then remove the temporary matrix mat_copy(temp,Ainv); free_mat(temp); } } // Does Ainv := inverse(A), where A is a square matrix void invertS(matrix *A, matrix *Ainv,int silent){ if( !(nrow_matrix(A) == ncol_matrix(A) && nrow_matrix(Ainv) == ncol_matrix(Ainv) && nrow_matrix(A) == ncol_matrix(Ainv))){ oops("Error: dimensions in invert\n"); } // Ensure that A and Ainv do not occupy the same memory. if(A != Ainv){ invertUnsafeS(A, Ainv,silent); } else { // if A and Ainv occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(Ainv),ncol_matrix(Ainv),temp); invertUnsafeS(A, temp,silent); // Copy these results into Ainv, then remove the temporary matrix mat_copy(temp,Ainv); free_mat(temp); } } // Does Ainv := inverse(A), where A is a square matrix void invertUnsafe(matrix *A, matrix *Ainv){ //unsafe because it assumes A and Ainv are both square and of the //same dimensions, and that they occupy different memory //char uplo = 'U'; int i, j; int n = nrow_matrix(A); int lda = n; // matrix A has dimensions n x n int *ipiv = malloc(n * sizeof(int)); int lwork = n * n; int info = -999; double anorm = -999.0; double rcond = -999.0; double tol = 1.0e-07; double *dwork = malloc(4 * n * sizeof(double)); int *iwork = malloc(n * sizeof(int)); double *work = malloc(n * n * sizeof(double)); // First turn the matrix A into the vector a for(i = 0; i < n; i++){ for(j = 0; j < n; j++){ ME(Ainv,i,j) = ME(A,i,j); } } anorm = F77_NAME(dlange)("O", &n, &n, Ainv->entries, &lda, dwork FCONE); // First find the LU factorization of A, // stored as an upper triangular matrix F77_CALL(dgetrf)(&n, &n, Ainv->entries, &lda, ipiv, &info ); if(info != 0){ //Avoid printing this error message Rprintf("2 Error in invert: DGETRF returned info = %d \n",info); mat_zeros(Ainv); print_mat(Ainv); } else { for(i = 0; i < n; i++){ iwork[i]= ipiv[i]; } F77_CALL(dgecon)("O", &n, Ainv->entries, &lda, &anorm, &rcond, dwork, iwork, &info FCONE ); if(info != 0){ //Avoid printing this error message Rprintf("1 Error in invert: DGETRF returned info = %d \n",info); mat_zeros(Ainv); return; } if(rcond < tol){ Rprintf("Error in invert: estimated reciprocal condition number = %7.7e\n",rcond); mat_zeros(Ainv); return; } // then use this factorization to compute the inverse of A F77_CALL(dgetri)(&n, Ainv->entries, &lda, ipiv, work, &lwork, &info ); if(info != 0){ Rprintf("Error in invert: DPOTRI returned info = %d \n",info); mat_zeros(Ainv); } if (fabs(ME(Ainv,0,0))>99999999999999) { // TS 23-10 print_mat(Ainv); Rprintf("Inversion, unstable large elements \n"); mat_zeros(Ainv); } } free(work); free(iwork); free(dwork); free(ipiv); } // Does Ainv := inverse(A), where A is a square matrix, possibly silent void invertUnsafeS(matrix *A, matrix *Ainv,int silent){ //unsafe because it assumes A and Ainv are both square and of the //same dimensions, and that they occupy different memory //char uplo = 'U'; int i, j; int n = nrow_matrix(A); int lda = n; // matrix A has dimensions n x n int *ipiv = malloc(n * sizeof(int)); int lwork = n * n; int info = -999; double anorm = -999.0; double rcond = -999.0; double tol = 1.0e-07; double *dwork = malloc(4 * n * sizeof(double)); int *iwork = malloc(n * sizeof(int)); double *work = malloc(n * n * sizeof(double)); // First turn the matrix A into the vector a for(i = 0; i < n; i++){ for(j = 0; j < n; j++){ ME(Ainv,i,j) = ME(A,i,j); } } anorm = F77_NAME(dlange)("O", &n, &n, Ainv->entries, &lda, dwork FCONE); // First find the LU factorization of A, // stored as an upper triangular matrix F77_CALL(dgetrf)(&n, &n, Ainv->entries, &lda, ipiv, &info ); if(info != 0){ //Avoid printing this error message mat_zeros(Ainv); if (silent==0) Rprintf("3 Error in invert: DGETRF returned info = %d \n",info); } else { for(i = 0; i < n; i++){ iwork[i]= ipiv[i]; } F77_CALL(dgecon)("O", &n, Ainv->entries, &lda, &anorm, &rcond, dwork, iwork, &info FCONE ); if(info != 0){ //Avoid printing this error message mat_zeros(Ainv); free(work); free(iwork); free(dwork); free(ipiv); if (silent==0) Rprintf("4 Error in invert: DGETRF returned info = %d \n",info); return; } if(rcond < tol ){ mat_zeros(Ainv); free(work); free(iwork); free(dwork); free(ipiv); if (silent==0) Rprintf("Error in invert: estimated reciprocal condition number = %7.7e\n",rcond); return; } // then use this factorization to compute the inverse of A F77_CALL(dgetri)(&n, Ainv->entries, &lda, ipiv, work, &lwork, &info); if(info != 0 ){ mat_zeros(Ainv); if (silent==0) Rprintf("Error in invert: DPOTRI returned info = %d \n",info); } if (fabs(ME(Ainv,0,0))>99999999999999 ) { // TS 23-10 mat_zeros(Ainv); if (silent==0) Rprintf("Inversion, unstable large elements \n"); } } free(work); free(iwork); free(dwork); free(ipiv); } // Performs Mout := M %*% A, where M is an nRowM x nColM matrix, // and A is an nColM x nColA matrix, and Mout is a nRowM x nColA matrix void MxA(matrix *M, matrix *A, matrix *Mout){ char transa = 'n'; char transb = 'n'; double alpha = 1.0; double beta = 0.0; int m = nrow_matrix(M); int n = ncol_matrix(A); int k = ncol_matrix(M); int lda = nrow_matrix(M); int ldb = ncol_matrix(M); int ldc = nrow_matrix(M); if( !(ncol_matrix(M) == nrow_matrix(A) && nrow_matrix(Mout) == nrow_matrix(M) && ncol_matrix(Mout) == ncol_matrix(A)) ){ oops("Error: dimensions in MxA\n"); } // Ensure that Mout does not occupy the same memory as M or A if(Mout != A && Mout != M){ // the results of 1.0 * M %*% A + 0.0 * c is stored in c // therfore we do not need to initialise c F77_CALL(dgemm)(&transa, &transb, &m, &n, &k, &alpha, M->entries, &lda, A->entries, &ldb, &beta, Mout->entries, &ldc FCONE FCONE); } else { // if M and A occupy the same memory, store the results in a // temporary matrix. matrix *temp; malloc_mat(nrow_matrix(Mout),ncol_matrix(Mout),temp); // the results of 1.0 * M %*% A + 0.0 * c is stored in c // therfore we do not need to initialise c F77_CALL(dgemm)(&transa, &transb, &m, &n, &k, &alpha, M->entries, &lda, A->entries, &ldb, &beta, temp->entries, &ldc FCONE FCONE); // Copy these results into Mout, then remove the temporary matrix mat_copy(temp,Mout); free_mat(temp); } } void print_clock(clock_t *intime, int i){ clock_t outtime = clock(); Rprintf("### point %d, time %7.7e\n", i, difftime(outtime,*intime)); *intime = outtime; } void update_clock(clock_t *intime, counter *C){ clock_t outtime = clock(); C->timec += difftime(outtime,*intime); C->callc++; *intime = outtime; } void zcntr(counter *C){ C->timec = 0.0; C->callc = 0; } void print_counter(int i, counter *C){ Rprintf("### counter %d, time %7.7g, calls %d\n", i, C->timec, C->callc); } void identity_matrix(matrix *M){ int i, j; if(nrow_matrix(M) != ncol_matrix(M)){ oops("Error in identity_matrix: dimenions do not match\n"); } for(i = 0; i < nrow_matrix(M); i++){ for(j = 0; j < nrow_matrix(M); j++){ if(i == j){ ME(M,i,j) = 1.0; } else { ME(M,i,j) = 0.0; } } } } void malloc_mats(int nrow, int ncol, ...){ va_list argp; va_start(argp, ncol); matrix **M; while((M = va_arg(argp, matrix **))){ malloc_mat(nrow,ncol,*M); } va_end(argp); } void malloc_vecs(int length, ...){ va_list argp; va_start(argp, length); vector **V; while((V = va_arg(argp, vector **))){ malloc_vec(length,*V); } va_end(argp); } void free_mats(matrix **M1, ...){ va_list argp; va_start(argp, M1); matrix **M; free_mat(*M1); while((M = va_arg(argp, matrix **))){ free_mat(*M); } va_end(argp); } void free_vecs(vector **V1, ...){ va_list argp; va_start(argp, V1); vector **V; free_vec(*V1); while((V = va_arg(argp, vector **))){ free_vec(*V); } va_end(argp); } // sets v := M[,col_to_get] vector *extract_col(matrix *M, int col_to_get, vector *v){ int j; if(!(length_vector(v) == nrow_matrix(M))){ oops("Error: dimensions in extract_col\n"); } if(col_to_get >= 0 && col_to_get < ncol_matrix(M)){ for(j = 0; j < length_vector(v); j++){ VE(v,j) = ME(M,j,col_to_get); } return(v); } else { oops("Error: trying to get an invalid column in 'extract_col'\n"); } return(v); } // sets M[,col_to_set] := v void replace_col(matrix *M, int col_to_set, vector *v){ int j; if(!(length_vector(v) == nrow_matrix(M))){ oops("Error: dimensions in replace_col\n"); } if(col_to_set >= 0 && col_to_set < ncol_matrix(M)){ for(j = 0; j < nrow_matrix(M); j++){ ME(M,j,col_to_set) = VE(v,j); } } else { oops("Error: trying to get an invalid column in 'replace_col'\n"); } } void LevenbergMarquardt(matrix *S,matrix *SI,vector *U,vector *delta,double *lm,double *step) { // {{{ int i,nrow; double ss=0; matrix *S2; if(!(length_vector(U) == nrow_matrix(S))){ oops("Error: LM : S and U not consistent\n"); } if(!(length_vector(U) == length_vector(delta))){ oops("Error: LM : delta and U not consistent\n"); } nrow=length_vector(delta); malloc_mat(nrow,nrow,S2); for (i=0;i *lm ) { MxA(S,S,S2); for (i=0;i0.0001) scl_vec_mult(*step,delta,delta); free_mat(S2); } // }}} void readXt2(int *antpers,int *nx,int *p,double *designX, double *start,double *stop,int *status,int pers,matrix *X,double time) { // {{{ int j,c,count; for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { for(j=0;j<*p;j++){ ME(X,count,j) = designX[j*(*nx)+c]; } if (time==stop[c] && status[c]==1) { pers=count; } count=count+1; } } } // }}} void readXt(int *antpers,int *nx,int *p,double *designX,double *start,double *stop,int *status,int pers,matrix *X,double time,int *clusters,int *cluster,int *id) { // {{{ int j,c,count; for (c=0,count=0;((c<*nx) && (count!=*antpers));c++){ if ((start[c]=time)) { for(j=0;j<*p;j++) { ME(X,id[c],j) = designX[j*(*nx)+c]; } cluster[id[c]]=clusters[c]; if (time==stop[c] && status[c]==1) { pers=id[c]; } count=count+1; } } } // }}} void readXZt(int *antpers,int *nx,int *px,double *designX,int *pg,double *designG, double *start,double *stop,int *status,int pers,matrix *X, matrix *WX,matrix *Z,matrix *WZ,double time,int *clusters, int *cluster,int *ls,int stat,int l,int *id,int s,int medw) { // {{{ int j,c,count,pmax; pmax=max(*pg,*px); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { cluster[id[c]]=clusters[c]; for(j=0;j=time)) { // cluster[id[c]]=clusters[c]; for(j=0;j // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void aalen(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void addmult(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *) ; extern void atriskindex(void *, void *, void *, void *, void *, void *, void *, void *); extern void clusterindex(void *, void *, void *, void *, void *, void *, void *, void *); extern void compSs(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void compSsforward(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void compSsrev(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void confBandBasePredict(void *, void *, void *, void *, void *, void *, void *); extern void dynadd(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void Gtranssurv(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void itfit(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void localTimeReg(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void mgresid(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void nclusters(void *, void *, void *, void *, void *); extern void OSbreslow(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void OSsemicox(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void OStimecox(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void * , void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void pava(void *, void *, void *); extern void pes(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void posubdist2(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void resmean(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void robaalen(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void robaalenC(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void score(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void semiaalen(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void semibreslow(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *,void *, void *, void *); extern void semidynadd(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void sindex(void *, void *, void *, void *, void *, void *); extern void smooth2B(void *, void *, void *, void *, void *, void *, void *, void *); extern void smoothB(void *, void *, void *, void *, void *, void *, void *, void *); extern void transsurv(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void twostagereg(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"aalen", (DL_FUNC) &aalen, 11}, {"addmult", (DL_FUNC) &addmult, 29}, {"atriskindex", (DL_FUNC) &atriskindex, 8}, {"clusterindex", (DL_FUNC) &clusterindex, 8}, {"compSs", (DL_FUNC) &compSs, 18}, {"compSsforward", (DL_FUNC) &compSsforward, 18}, {"compSsrev", (DL_FUNC) &compSsrev, 18}, {"confBandBasePredict", (DL_FUNC) &confBandBasePredict, 7}, {"dynadd", (DL_FUNC) &dynadd, 42}, {"Gtranssurv", (DL_FUNC) &Gtranssurv, 40}, {"itfit", (DL_FUNC) &itfit, 55}, {"localTimeReg", (DL_FUNC) &localTimeReg, 10}, {"mgresid", (DL_FUNC) &mgresid, 58}, {"nclusters", (DL_FUNC) &nclusters, 5}, {"OSbreslow", (DL_FUNC) &OSbreslow, 31}, {"OSsemicox", (DL_FUNC) &OSsemicox, 37}, {"OStimecox", (DL_FUNC) &OStimecox, 32}, {"pava", (DL_FUNC) &pava, 3}, {"pes", (DL_FUNC) &pes, 29}, {"posubdist2", (DL_FUNC) &posubdist2, 48}, {"resmean", (DL_FUNC) &resmean, 50}, {"robaalen", (DL_FUNC) &robaalen, 37}, {"robaalenC", (DL_FUNC) &robaalenC, 32}, {"score", (DL_FUNC) &score, 65}, {"semiaalen", (DL_FUNC) &semiaalen, 52}, {"semibreslow", (DL_FUNC) &semibreslow, 34}, {"semidynadd", (DL_FUNC) &semidynadd, 55}, {"sindex", (DL_FUNC) &sindex, 6}, {"smooth2B", (DL_FUNC) &smooth2B, 8}, {"smoothB", (DL_FUNC) &smoothB, 8}, {"transsurv", (DL_FUNC) &transsurv, 41}, {"twostagereg", (DL_FUNC) &twostagereg, 45}, {NULL, NULL, 0} }; void R_init_timereg(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } timereg/src/pe-sasieni.c0000644000176200001440000002252114421510301014667 0ustar liggesusers//#include #include #include #include "matrix.h" #include"R_ext/Random.h" void pes(double *alltimes,int *Nalltimes,int *Ntimes,double *designX,int *nx,int *px,double *designG,int *ng,int *pg,int *antpers,double *start,double *stop,double *cu,double *vcu,double *gamma,double *Vgamma,int *status,double *Ut,double *intZHZ,double *intZHdN,int *mof,double *offset,int *mw,double *weight,int *Nit,int *detail,int *rani,int *nsim,double *test) //double *designX,*alltimes,*start,*stop,*cu,*vcu,*designG,*gamma,*Vgamma,*Ut,*intZHZ,*intZHdN,*offset,*weight,*test; //int *detail,*nx,*px,*antpers,*Nalltimes,*Ntimes,*ng,*pg,*status,*mof,*mw,*Nit,*rani,*nsim; { matrix *S2,*S2I,*Vcov,*X,*WX,*A,*AI,*AIXW,*Z,*WZ; matrix *dCGam,*CGam,*Ct,*ICGam,*VarKorG,*dC,*XWZ,*ZWZ,*XWZAI; matrix *Acorb[*Nalltimes],*Vargam,*dVargam,*M1M2[*Ntimes],*GCdM1M2; matrix *C[*Nalltimes],*dM1M2,*M1M2t,*tmpM2,*tmpM3,*tmpM4; matrix *Delta,*tmpM1,*dUt[*Ntimes],*Uti[*antpers],*Utiid[*antpers]; vector *VdB,*difX,*xi,*tmpv1,*tmpv2,*gamoff; vector *dA,*rowX,*dN,*AIXWdN,*bhatt,*pbhat,*plamt; vector *S1,*korG,*pghat,*rowZ,*gam,*dgam,*ZHdN,*VZHdN,*IZHdN,*zi,*offsets; int it,i,j,k,l,c,s,count,pers=0,pmax; int stat, *ls=calloc(*Ntimes,sizeof(int)); double S0,sumscore,time=0,dummy,dtime,random; double *weights=calloc(*antpers,sizeof(double)), *times=calloc(*Ntimes,sizeof(double)), *cumoff=calloc((*Nalltimes)*(*px+1),sizeof(double)); // double norm_rand(); // void GetRNGstate(),PutRNGstate(); malloc_mats(*antpers,*px,&X,&WX,NULL); malloc_mats(*antpers,*pg,&Z,&WZ,NULL); malloc_mats(*px,*px,&Vcov,&A,&AI,&GCdM1M2,&VarKorG,NULL); malloc_mats(*pg,*pg,&S2,&S2I,&tmpM2,&ZWZ,&Vargam,&dVargam,&ICGam,&CGam,&dCGam,NULL); malloc_mats(*px,*antpers,&AIXW,NULL); malloc_mats(*px,*pg,&tmpM4,&tmpM3,&Ct,&dC,&XWZ,&XWZAI,&dM1M2,&M1M2t,NULL); for (j=0;j<*antpers;j++) { malloc_mat(*Ntimes,*pg,Uti[j]); malloc_mat(*Ntimes,*pg,Utiid[j]); } malloc_mat(*Ntimes,*pg,tmpM1); malloc_mat(*Ntimes,*pg,Delta); for (j=0;j<*Nalltimes;j++) { malloc_mat(*px,*pg,Acorb[j]);malloc_mat(*px,*pg,C[j]);} for (j=0;j<*Ntimes;j++) {malloc_mat(*px,*pg,M1M2[j]); malloc_mat(*pg,*pg,dUt[j]); } malloc_vecs(*px,&dA,&VdB,&difX,&xi,&tmpv1,&korG,&rowX,&AIXWdN,&bhatt,NULL); malloc_vecs(*pg,&S1,&gamoff,&zi,&tmpv2,&rowZ,&gam,&dgam,&ZHdN,&IZHdN,&VZHdN,NULL); malloc_vecs(*antpers,&offsets,&dN,&pbhat,&pghat,&plamt,NULL); if (*px>=*pg) pmax=*px; else pmax=*pg; times[0]=alltimes[0]; for (s=0;s<*pg;s++) VE(gam,s)=gamma[s]; cu[0]=times[0]; for (it=0;it<*Nit;it++) { mat_zeros(Ct); mat_zeros(CGam); vec_zeros(IZHdN); l=0; sumscore=0; S0=0; vec_zeros(gamoff); vec_zeros(offsets); for (s=1;s<*Nalltimes;s++) { time=alltimes[s]; dtime=time-alltimes[s-1]; mat_zeros(X); mat_zeros(Z); mat_zeros(WX); mat_zeros(WZ); stat=0; for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { if (*mof==1) VE(offsets,count)=offset[c]; if (*mw==1) weights[count]=weight[c]; else weights[count]=1; for(j=0;j=time)) { if (*mof==1) VE(offsets,count)=offset[c]; if (*mw==1) weights[count]=weight[c]; else weights[count]=1; if (time==stop[c] && status[c]==1) {pers=count;stat=1;l=l+1;} count=count+1; } } if (stat==1) for (k=1;k<=*px;k++) VE(dA,k-1)=cu[k*(*Ntimes)+l]; else vec_zeros(dA); if (*mof==1) for (k=1;k<=*px;k++) VE(dA,k-1)=VE(dA,k-1)-cumoff[k*(*Nalltimes)+s]; if (*mof==1) for (k=1;k<=*px;k++) cumoff[k*(*Ntimes)+s]=cumoff[k*(*Ntimes)+s-1]+ cumoff[k*(*Nalltimes)+s]; if (stat==1) { for (k=1;k<=*px;k++){cu[k*(*Ntimes)+l]= cu[k*(*Ntimes)+l-1]+cu[k*(*Ntimes)+l]; if (*mof==1) cu[k*(*Ntimes)+l]=cu[k*(*Ntimes)+l]- cumoff[k*(*Nalltimes)+s];} MxA(C[ls[l]],Vargam,tmpM4); MAt(tmpM4,C[ls[l]],VarKorG); MxA(M1M2[l],ICGam,tmpM4); MAt(C[ls[l]],tmpM4,GCdM1M2); /* MxA(C[ls[l]],ICGam,tmpM4); MxA(tmpM4,M1M2[l],GCdM1M2);*/ for (k=1;k<=*px;k++) {vcu[k*(*Ntimes)+l]= vcu[k*(*Ntimes)+l]+ME(VarKorG,k-1,k-1)-2*ME(GCdM1M2,k-1,k-1); } } } /* s=1 ..Ntimes */ for (j=0;j<*pg;j++) {gamma[j]=VE(gam,j); intZHdN[j]=VE(IZHdN,j); for (k=0;k<*pg;k++) {Vgamma[k*(*pg)+j]=ME(Vargam,j,k); intZHZ[k*(*pg)+j]=ME(ICGam,j,k); }} cu[0]=times[0]; vcu[0]=times[0]; if (*nsim>0) { // Rprintf(" simulation starts, no resampling = %d \n",*nsim); GetRNGstate(); /* to use R random normals */ for (s=1;s<*Ntimes;s++) for (i=0;i<*antpers;i++) { extract_row(Uti[i],s-1,gam); extract_row(Uti[i],s,ZHdN); vec_add(gam,ZHdN,IZHdN); replace_row(Uti[i],s,IZHdN); extract_row(Uti[i],s,ZHdN); Mv(ICGam,IZHdN,ZHdN); Mv(dUt[s],ZHdN,IZHdN); replace_row(Utiid[i],s,IZHdN); } for (k=1;k<=*nsim;k++) { mat_zeros(Delta); for (i=0;i<*antpers;i++) { random=norm_rand(); scl_mat_mult(random,Utiid[i],tmpM1); mat_add(tmpM1,Delta,Delta); } for (s=1;s<*Ntimes;s++) { extract_row(Delta,s,zi); for (i=0;i<*pg;i++) {VE(zi,i)=fabs(VE(zi,i)); if (VE(zi,i)>test[i*(*nsim)+k-1]) test[i*(*nsim)+k-1]=VE(zi,i); } } } PutRNGstate(); /* to use R random normals */ } /* if nsim >0 */ free_mats(&X,&WX,&Z,&WZ,&Vcov,&A,&AI,&GCdM1M2,&S2,&S2I,&tmpM2,&ZWZ,&VarKorG,&Vargam,&dVargam,&ICGam,&CGam,&dCGam,&AIXW,&tmpM4,&tmpM3,&Ct,&dC,&XWZ,&XWZAI,&dM1M2,&M1M2t,&tmpM1,&Delta,NULL); for (j=0;j<*Nalltimes;j++) { free_mat(Acorb[j]); free_mat(C[j]);} for (j=0;j<*Ntimes;j++) {free_mat(M1M2[j]); free_mat(dUt[j]); } for (j=0;j<*antpers;j++) { free_mat(Uti[j]); free_mat(Utiid[j]); } free_vecs(&dA,&VdB,&difX,&xi,&tmpv1,&korG,&rowX,&AIXWdN,&bhatt,&S1,&gamoff,&zi,&tmpv2,&rowZ,&gam,&dgam,&ZHdN,&IZHdN,&VZHdN,&offsets,&dN,&pbhat,&pghat,&plamt,NULL); free(ls); free(times); free(cumoff); free(weights); } timereg/src/ipcw-residualmean.c0000644000176200001440000004524114421510301016247 0ustar liggesusers#include #include #include "matrix.h" void resmean(double *times,int *Ntimes,double *x,int *delta,int *cause,double *KMc,double *z,int *n,int *px,int *Nit,double *betaS, double *score,double *hess,double *est,double *var,int *sim,int *antsim,int *rani,double *test,double *testOBS,double *Ut,double *simUt,int *weighted, double *gamma,double *vargamma,int *semi,double *zsem,int *pg,int *trans,double *gamma2,int *CA,int *line,int *detail,double *biid,double *gamiid,int *resample, double *timepow,int *clusters,int *antclust,double *timepowtest,int *silent,double *convc,double *tau,int *estimator,int *causeS,double *weights, double *KMtimes,int *ordertime,int *conservative,int *censcode) { // {{{ // {{{ allocation and reading of data from R matrix *X,*cX,*A,*AI,*cumAt[*antclust],*VAR,*Z,*censX; vector *VdB,*risk,*SCORE,*W,*Y,*Gc,*DELTA,*CAUSE,*bhat,*pbhat,*beta,*xi,*censXv, *rr,*rowX,*difbeta,*qs,*bhatub,*betaub,*dcovs,*pcovs,*zi,*rowZ,*zgam; vector *cumhatA[*antclust],*cumA[*antclust],*bet1,*gam,*dp,*dp1,*dp2; int osilent,convt,ps,sing,c,i,j,k,l,s,it,convproblems=0,clusterj,nrisk; double skm,rit=1,time,sumscore,totrisk,*vcudif=calloc((*Ntimes)*(*px+1),sizeof(double)); // float gasdev(),expdev(),ran1(); void resmeansemi(); ps=(*px); // printf(" %d %d %d %d %d %d \n",*px,*semi,*Ntimes,*trans,*antclust,*n); printf(" %d \n",ps); if (*semi==0) { osilent=silent[0]; silent[0]=0; malloc_mat(*n,*px,X); malloc_mat(*n,*px,cX); if (*trans==2) {malloc_mat(*n,*pg,Z);malloc_vecs(*pg,&zgam,&gam,&zi,&rowZ,NULL);} malloc_mats(ps,ps,&A,&AI,&VAR,NULL); malloc_vecs(*n,&rr,&bhatub,&risk,&W,&Y,&Gc,&DELTA,&CAUSE,&bhat,&pbhat,NULL); malloc_vecs(*px,&bet1,&xi,&rowX,&censXv,NULL); malloc_vecs(ps,&dp,&dp1,&dp2,&dcovs,&pcovs,&betaub,&VdB,&qs,&SCORE,&beta,&difbeta,NULL); malloc_mats(*n,*px,&censX,NULL); for (i=0;i<*antclust;i++) { malloc_vec(ps,cumhatA[i]); malloc_vec(ps,cumA[i]); malloc_mat(*Ntimes,ps,cumAt[i]); } for (c=0;c=time); rit= (x[j]>=time); rit=rit*delta[j]*skm; } else if (*estimator==2) { // cause specific YL to cause given event VE(risk,j)=(x[j]<= (*tau))*(cause[j]==*causeS); rit=(x[j]<= (*tau))*(cause[j]==*causeS); rit=rit*delta[j]*skm; } else if (*estimator==3) { // PKA years lost VE(risk,j)=(x[j]>= time); // *(cause[j]==*causeS); rit=(x[j]>= time); // *(cause[j]==*causeS); rit=rit*delta[j]*skm; } else if (*estimator==4) { // inside weight rit= 1; VE(risk,j)=rit; skm=sqrt(weights[j]*KMtimes[s]); rit=weights[j]; } // }}} totrisk=totrisk+VE(risk,j); extract_row(X,j,xi); VE(bhat,j)=vec_prod(xi,bet1); if (*trans==1) { VE(pbhat,j)=VE(bhat,j); scl_vec_mult(rit,xi,dp); } if (*trans==2) { VE(pbhat,j)=exp(VE(bhat,j)); scl_vec_mult(rit*VE(pbhat,j),xi,dp); } if ((*trans==1 ) || (*trans==2)) { replace_row(cX,j,dp); } if (*estimator==1) VE(Y,j)=(((x[j]-time))-VE(pbhat,j))*rit; else if (*estimator==2) VE(Y,j)=((*tau-x[j])-VE(pbhat,j))*rit; else if (*estimator==3) VE(Y,j)=((*tau-x[j])*(cause[j]==*causeS)-VE(pbhat,j))*rit; else if (*estimator==4) VE(Y,j)=((x[j]-time)*(cause[j]==*causeS)*delta[j]/KMc[j]-VE(pbhat,j))*rit; if (it==(*Nit-1) && (*conservative==0)) { // {{{ for censoring distrubution scl_vec_mult(VE(Y,j),dp,dp1); vec_add(censXv,dp1,censXv); replace_row(censX,j,dp1); } // }}} } // }}} totrisk=vec_sum(risk); MtA(cX,cX,A); invertS(A,AI,osilent); // print_mat(A); sing=0; if (fabs(ME(AI,0,0))<.0000001) { convproblems=1; convt=0; silent[s]=1; for (c=0;c0) convc[0]=1; if (*semi==0) { free_mats(&censX,&VAR,&X,&cX,&A,&AI,NULL); if (*trans==2) {free_mats(&Z,NULL); free_vecs(&zgam,&gam,&zi,&rowZ,NULL);} free_vecs(&censXv,&rr,&bhatub,&risk,&W,&Y,&Gc,&DELTA,&CAUSE,&bhat,&pbhat,NULL); free_vecs(&bet1,&xi,&rowX,NULL); free_vecs(&dp,&dp1,&dp2,&dcovs,&pcovs,&betaub,&VdB,&qs,&SCORE,&beta,&difbeta,NULL); for (i=0;i<*antclust;i++) {free_vec(cumhatA[i]); free_vec(cumA[i]); free_mat(cumAt[i]);} } free(vcudif); } // }}} //double *times,*x,*KMc,*z,*score,*hess,*est,*var,*test,*testOBS, //*Ut,*simUt,*gamma,*zsem,*vargamma,*gamma2,*biid,*gamiid,*timepow,*timepowtest, // *weights,*KMtimes, // *convc,*tau; //int *antpers,*px,*Ntimes,*Nit,*cause,*delta,*sim,*antsim,*rani,*weighted, //*semi,*pg,*trans,*CA,*line,*detail,*resample,*clusters,*antclust,*silent,*estimator,*causeS; void resmeansemi(double *times,int *Ntimes,double *x,int *delta,int *cause, double *KMc,double *z,int *antpers,int *px,int *Nit, double *score,double *hess,double *est,double *var,int *sim, int *antsim,int *rani,double *test,double *testOBS,double *Ut, double *simUt,int *weighted,double *gamma,double *vargamma,int *semi, double *zsem,int *pg,int *trans,double *gamma2,int *CA, int *line,int *detail,double *biid,double *gamiid,int *resample, double *timepow,int *clusters,int *antclust,double *timepowtest,int *silent,double *convc,double *tau,int *estimator,int *causeS, double *weights,double *KMtimes) { // {{{ allocation and reading of data from R matrix *ldesignX,*A,*AI,*cdesignX,*ldesignG,*cdesignG; matrix *S,*dCGam,*CGam,*ICGam,*VarKorG,*dC,*XZ,*ZZ,*ZZI,*XZAI; matrix *Ct,*C[*Ntimes],*Acorb[*Ntimes],*tmpM1,*tmpM2,*tmpM3,*tmpM4; matrix *Vargam,*dVargam,*M1M2[*Ntimes],*Delta,*dM1M2,*M1M2t,*RobVargam; matrix *W3t[*antclust],*W4t[*antclust]; vector *W2[*antclust],*W3[*antclust]; vector *diag,*dB,*dN,*VdB,*AIXdN,*AIXlamt,*bhatt,*pbhat,*plamt; vector *korG,*pghat,*rowG,*gam,*dgam,*ZGdN,*IZGdN,*ZGlamt,*IZGlamt; vector *covsx,*covsz,*qs,*Y,*rr,*bhatub,*xi,*rowX,*rowZ,*difX,*zi,*z1,*tmpv1,*tmpv2,*lrisk; int sing,itt,i,j,k,l,s,c,pmax,totrisk,convproblems=0,fixedcov,osilent, *n= calloc(1,sizeof(int)), *nx= calloc(1,sizeof(int)), *robust= calloc(1,sizeof(int)); double lrr,skm,rit=1,dtau,time,dummy,dtime; double *vcudif=calloc((*Ntimes)*(*px+1),sizeof(double)), *inc=calloc((*Ntimes)*(*px+1),sizeof(double)); osilent=silent[0]; silent[0]=0; robust[0]=1; fixedcov=1; n[0]=antpers[0]; nx[0]=antpers[0]; //if (*trans==1) for (j=0;j<*pg;j++) if (fabs(timepow[j]-1)>0.0001) {timem=1;break;} //if (*trans==2) for (j=0;j<*pg;j++) if (fabs(timepow[j])>0.0001) {timem=1;break;} for (j=0;j<*antclust;j++) { malloc_mat(*Ntimes,*px,W3t[j]); malloc_mat(*Ntimes,*px,W4t[j]); malloc_vec(*pg,W2[j]); malloc_vec(*px,W3[j]); } malloc_mats(*antpers,*px,&ldesignX,&cdesignX,NULL); malloc_mats(*antpers,*pg,&ldesignG,&cdesignG,NULL); malloc_mats(*px,*px,&tmpM1,&A,&AI,NULL); malloc_mats(*pg,*pg,&dVargam,&Vargam,&RobVargam,&tmpM2,&ZZ,&VarKorG,&ICGam,&CGam,&dCGam,&S,&ZZI,NULL); malloc_mats(*px,*pg,&XZAI,&tmpM3,&Ct,&dC,&XZ,&dM1M2,&M1M2t,NULL); malloc_mat(*px,*pg,tmpM4); for (j=0;j<*Ntimes;j++) { malloc_mat(*pg,*px,Acorb[j]); malloc_mat(*px,*pg,C[j]); malloc_mat(*px,*pg,M1M2[j]); } malloc_mat(*Ntimes,*px,Delta); malloc_mat(*Ntimes,*px,tmpM1); malloc_vecs(*px,&covsx,&xi,&rowX,&difX,&tmpv1,&korG,&diag,&dB,&VdB,&AIXdN,&AIXlamt,&bhatt,NULL); malloc_vecs(*pg,&covsz,&zi,&rowZ,&tmpv2,&zi,&z1,&rowG,&gam,&dgam,&ZGdN,&IZGdN,&ZGlamt,&IZGlamt,NULL); malloc_vecs(*antpers,&Y,&bhatub,&rr,&lrisk,&dN,&pbhat,&pghat,&plamt,NULL); malloc_vec((*px)+(*pg),qs); if (*px>=*pg) pmax=*px; else pmax=*pg; for (j=0;j<*pg;j++) VE(gam,j)=gamma[j]; // }}} if (fixedcov==1) { for (c=0;c<*antpers;c++) { for(j=0;j0) dtau=*tau-time; else dtau=time; // printf(" %lf %lf %lf \n",time,dtau,*tau); for(j=1;j<=*px;j++) VE(bhatt,j-1)=est[j*(*Ntimes)+s]; Mv(ldesignX,bhatt,pbhat); totrisk=0; for (j=0;j<*antpers;j++) { // {{{ skm=sqrt(weights[j]*KMtimes[s]/KMc[j]); if (*estimator==2) { // cause specific YL to cause given event VE(lrisk,j)=(x[j]<= (*tau))*(cause[j]==*causeS); rit=(x[j]<= (*tau))*(cause[j]==*causeS); rit=rit*delta[j]*skm; } else if (*estimator==3) { // PKA years lost VE(lrisk,j)=(x[j]>= time); // *(cause[j]==*causeS); rit=(x[j]>= time); // *(cause[j]==*causeS); rit=rit*delta[j]*skm; } else if (*estimator==4) { // inside weight conditional residual rit= 1; VE(lrisk,j)=rit; skm=sqrt(weights[j]*KMtimes[s]); rit=1; } else if (*estimator==1) { // standard conditional residual VE(lrisk,j)=(x[j]>=time); rit= (x[j]>=time); rit=rit*delta[j]*skm; } totrisk=totrisk+VE(lrisk,j); extract_row(ldesignX,j,xi); extract_row(ldesignG,j,zi); lrr=0; // {{{ compute P_1 and DP_1 if (*trans==1 ) { for (l=0;l<*pg;l++) lrr=lrr+VE(gam,l)*VE(zi,l)*pow(dtau,timepow[l]); VE(plamt,j)=VE(pbhat,j)+lrr; scl_vec_mult(rit,xi,xi); scl_vec_mult(rit,zi,zi); for (l=0;l<*pg;l++) VE(zi,l)=pow(dtau,timepow[l])*VE(zi,l); } if (*trans==2) { for (l=0;l<*pg;l++) lrr=lrr+VE(gam,l)*VE(zi,l)*pow(dtau,timepow[l]); VE(rr,j)=lrr; VE(plamt,j)=exp(VE(pbhat,j)+lrr); scl_vec_mult(rit*VE(plamt,j),xi,xi); scl_vec_mult(rit*VE(plamt,j),zi,zi); for (l=0;l<*pg;l++) VE(zi,l)= pow(dtau,timepow[l])*VE(zi,l); } // }}} if ((*trans==1 ) || (*trans==2)) { replace_row(cdesignX,j,xi); replace_row(cdesignG,j,zi); } /* if (itt==*Nit-1) { if (KMc[j]<0.00001) vec_zeros(xi); else scl_vec_mult(1/KMc[j],xi,xi); scl_vec_mult(VE(lrisk,j),xi,xi); vec_add(xi,qs,qs); } */ if (*estimator==1) VE(Y,j)=(((x[j]-time))-VE(pbhat,j))*rit; else if (*estimator==3) VE(Y,j)=((*tau-x[j])*(cause[j]==*causeS)-VE(pbhat,j))*rit; else if (*estimator==4) VE(Y,j)=((x[j]-time)*(cause[j]==*causeS)*delta[j]/KMc[j]-VE(pbhat,j))*rit; else if (*estimator==2) VE(Y,j)=((*tau-x[j])-VE(pbhat,j))*rit; } // j=1..antpers ## }}} MtA(cdesignX,cdesignX,A); invertS(A,AI,osilent); sing=0; if (fabs(ME(AI,0,0))<.0000001) { convproblems=1; silent[s]=1; if (osilent==0) Rprintf("Iteration %d: non-invertible design at time %lf\n",itt,time); for (k=1;k<=*px;k++) inc[k*(*Ntimes)+s]=0; sing=1; } if (sing==0) { vM(cdesignX,Y,xi); Mv(AI,xi,AIXdN); MtA(cdesignG,cdesignG,ZZ); MtA(cdesignX,cdesignG,XZ); MxA(AI,XZ,XZAI); MtA(XZAI,XZ,tmpM2); mat_subtr(ZZ,tmpM2,dCGam); scl_mat_mult(dtime,dCGam,dCGam); mat_add(CGam,dCGam,CGam); vM(cdesignG,Y,zi); vM(XZ,AIXdN,tmpv2); vec_subtr(zi,tmpv2,ZGdN); scl_vec_mult(dtime,ZGdN,ZGdN); vec_add(ZGdN,IZGdN,IZGdN); Acorb[s]=mat_transp(XZAI,Acorb[s]); C[s]=mat_copy(XZ,C[s]); /* scl_mat_mult(dtime,XZAI,tmpM4);mat_add(tmpM4,Ct,Ct); */ for (k=1;k<=*px;k++) inc[k*(*Ntimes)+s]=VE(AIXdN,k-1); } if (itt==*Nit-1) { for (i=0;i<*antpers;i++) { // vec_zeros(tmpv1); vec_zeros(z1); j=clusters[i]; extract_row(cdesignX,i,xi); scl_vec_mult(VE(Y,i),xi,xi); Mv(AI,xi,rowX); extract_row(cdesignG,i,zi); scl_vec_mult(VE(Y,i),zi,zi); vM(C[s],rowX,tmpv2); vec_subtr(zi,tmpv2,rowZ); scl_vec_mult(dtime,rowZ,rowZ); // vec_add(rowZ,z1,z1); // vec_add(rowX,tmpv1,tmpv1); vec_add(rowZ,W2[j],W2[j]); for (k=0;k<*px;k++) ME(W3t[j],s,k)= ME(W3t[j],s,k)+VE(rowX,k); } } } /* s=1,...Ntimes */ invertS(CGam,ICGam,osilent); Mv(ICGam,IZGdN,dgam); vec_add(gam,dgam,gam); if (isnan(vec_sum(dgam))) { if (convproblems==1) convproblems=3; else convproblems=2; if (osilent==1) Rprintf("missing values in dgam %ld \n",(long int) s); vec_zeros(gam); } dummy=0; for (k=0;k<*pg;k++) dummy=dummy+fabs(VE(dgam,k)); for (s=0;s<*Ntimes;s++) { vM(Acorb[s],dgam,korG); est[s]=times[s]; var[s]=times[s]; for (k=1;k<=*px;k++) { est[k*(*Ntimes)+s]= est[k*(*Ntimes)+s]+inc[k*(*Ntimes)+s]-VE(korG,k-1); dummy=dummy+fabs(inc[k*(*Ntimes)+s]-VE(korG,k-1)); /* printf(" %lf ",est[k*(*Ntimes)+s]); printf(" \n");*/ } } /* s=1,...Ntimes */ if (dummy<*convc && itt<*Nit-2) itt=*Nit-2; if (*detail==1) { Rprintf(" iteration %d %d \n",itt,*Nit); Rprintf("Total sum of changes %lf \n",dummy); Rprintf("Gamma parameters \n"); print_vec(gam); Rprintf("Change in Gamma \n"); print_vec(dgam); } } /*itt lokke */ /* ROBUST VARIANCES */ if (*robust==1) { for (s=0;s<*Ntimes;s++) { vec_zeros(VdB); for (i=0;i<*antclust;i++) { Mv(ICGam,W2[i],tmpv2); vM(Acorb[s],tmpv2,rowX); extract_row(W3t[i],s,tmpv1); vec_subtr(tmpv1,rowX,difX); replace_row(W4t[i],s,difX); vec_star(difX,difX,tmpv1); vec_add(tmpv1,VdB,VdB); if (*resample==1) { if (s==1) for (c=0;c<*pg;c++) gamiid[c*(*antclust)+i]=gamiid[c*(*antclust)+i]+VE(tmpv2,c); for (c=0;c<*px;c++) {l=i*(*px)+c; biid[l*(*Ntimes)+s]=biid[l*(*Ntimes)+s]+VE(difX,c);} } if (s==0) { for (j=0;j<*pg;j++) for (k=0;k<*pg;k++) ME(RobVargam,j,k)=ME(RobVargam,j,k)+VE(tmpv2,j)*VE(tmpv2,k);} } /* for (i=0;i<*antclust;i++) */ for (k=1;k<*px+1;k++) var[k*(*Ntimes)+s]=VE(VdB,k-1); } /* s=0..Ntimes*/ } /* MxA(RobVargam,ICGam,tmpM2); MxA(ICGam,tmpM2,RobVargam);*/ /* print_mat(RobVargam); */ for (j=0;j<*pg;j++) {gamma[j]=VE(gam,j); for (k=0;k<*pg;k++) {vargamma[k*(*pg)+j]=ME(RobVargam,j,k);}} if (convproblems>=1) convc[0]=convproblems; if (*sim==1) { comptestfunc(times,Ntimes,px,est,var,vcudif,antsim,test,testOBS,Ut,simUt,W4t,weighted,antclust,gamma2,line,timepowtest); } free_mats(&ldesignX,&A,&AI,&cdesignX,&ldesignG,&cdesignG, &S,&dCGam,&CGam,&ICGam,&VarKorG,&dC,&XZ,&ZZ,&ZZI,&XZAI, &Ct,&tmpM1,&tmpM2,&tmpM3,&tmpM4,&Vargam,&dVargam, &Delta,&dM1M2,&M1M2t,&RobVargam,NULL); free_vecs(&qs,&Y,&rr,&bhatub,&diag,&dB,&dN,&VdB,&AIXdN,&AIXlamt, &bhatt,&pbhat,&plamt,&korG,&pghat,&rowG,&gam,&dgam,&ZGdN,&IZGdN, &ZGlamt,&IZGlamt,&xi,&rowX,&rowZ,&difX,&zi,&z1,&tmpv1,&tmpv2,&lrisk, NULL); for (j=0;j<*Ntimes;j++) {free_mat(Acorb[j]);free_mat(C[j]);free_mat(M1M2[j]);} for (j=0;j<*antclust;j++) {free_mat(W3t[j]); free_mat(W4t[j]); free_vec(W2[j]); free_vec(W3[j]); } free(vcudif); free(inc); free(n); free(nx); free(robust); } timereg/src/smooth.c0000644000176200001440000000662314421510301014150 0ustar liggesusers//#include #include #include "matrix.h" double tukey(double x,double b) { return((1/b)*((cos(3.141592 *(x/b))+ 1)/2) * (fabs(x/b) < 1)); } double dtukey(double x,double b) { return((-3.141592/b*b)*(sin(3.141592 *(x/b))/2)*(fabs(x/b) < 1)); } void smoothB(double *designX,int *nx,int *p,double *bhat,int *nb,double *b,int *degree,int *coef) //double *designX,*bhat,*b; //int *coef,*nx,*p,*degree,*nb; { // {{{ matrix *mat1,*mat2,*II,*I; vector *XWy,*Y,*RES,*sY; int count,j,k,s,d; int silent=1; double x,w,band; matrix *sm1,*sm2; malloc_mat(*nx,(*degree)+1,mat1); malloc_mat(*nx,(*degree)+1,mat2); malloc_mat(*nx,(*degree)+1,sm1); malloc_mat(*nx,(*degree)+1,sm2); malloc_vec(*nx,Y); malloc_vec(*nx,sY); malloc_vec((*degree)+1,XWy); malloc_vec((*degree)+1,RES); malloc_mat((*degree)+1,(*degree)+1,II); malloc_mat((*degree)+1,(*degree)+1,I); for (s=0;s<*nb;s++){ x=bhat[s]; for (k=1;k<*p;k++) { vec_zeros(Y); mat_zeros(mat1); mat_zeros(mat2); count=0; vec_zeros(RES); band=b[(k-1)*(*nb)+s]; /* Rprintf("band %lf %ld \n",band,k); */ for (j=0;j<*nx;j++) { if (fabs(designX[j]-x)=4) { MtA(mat1,mat2,II); invertS(II,I,silent); vM(mat1,Y,XWy); vM(I,XWy,RES); }; bhat[k*(*nb)+s]=VE(RES,*coef); } /* components */ } /* times */ free_mat(sm1); free_mat(sm2); free_mat(mat1); free_mat(mat2); free_mat(I); free_mat(II); free_vec(sY); free_vec(Y); free_vec(XWy); free_vec(RES); } // }}} void localTimeReg(double *designX,int *nx,int *p,double *times,double *response,double *bhat,int *nb,double *b,int *lin,double *dens) //double *designX,*bhat,*b,*times,*response,*dens; //int *nx,*p,*nb,*lin; { matrix *X,*AI,*A; vector *res,*Y,*XY; int c,j,k,s,silent=1; double band,x,w,delta; j=(*lin+1)*(*p); malloc_mat(*nx,j,X); malloc_mat(j,j,A); malloc_mat(j,j,AI); malloc_vec(*nx,Y); malloc_vec(j,XY); malloc_vec(j,res); /* Rprintf("enters Local Time Regression \n"); */ for (s=0;s<*nb;s++){ x=bhat[s]; for (c=0;c<*nx;c++){ delta=times[c]-x; band=b[s]; w=tukey(delta,band); dens[s]=dens[s]+w; dens[(*nb)+s]=dens[(*nb)+s]+dtukey(delta,b[s]); for(j=0;j<*p;j++) { ME(X,c,j)=designX[j*(*nx)+c]*sqrt(w); if (*lin>=1) ME(X,c,*p+j)=designX[j*(*nx)+c]*delta*sqrt(w); if (*lin>=2) ME(X,c,2*(*p)+j)=delta*ME(X,c,*p+j); if (*lin==3) ME(X,c,3*(*p)+j)=delta*ME(X,c,2*(*p)+j); } VE(Y,c)=response[c]*sqrt(w); } dens[s]=dens[s]/(*nx); dens[(*nb)+s]=dens[(*nb)+s]/(*nx); MtA(X,X,A); invertS(A,AI,silent); if (ME(AI,0,0)==0.0){ Rprintf("Non-invertible design in local smoothing at time %lf \n",x); } vM(X,Y,XY); Mv(AI,XY,res); for (k=1;k<((*lin)+1)*(*p)+1;k++){ bhat[k*(*nb)+s]=VE(res,k-1); } } free_mat(A); free_mat(AI); free_mat(X); free_vec(Y); free_vec(XY); free_vec(res); } timereg/src/pava.c0000644000176200001440000000441414421510276013575 0ustar liggesusers/* pava.c: R extension, PAVA (Pool Adjacent Violators Algorithm) */ /* By Bahjat Qaqish */ /************************************************************/ #include typedef double DBL; static void wpool (DBL *y, DBL *w, int i, int j) /* Pool y[i:j] using weights w[i:j] */ { int k; DBL s0=0, s1=0; for (k=i; k<=j; k++) {s1 += y[k]*w[k]; s0 += w[k];} s1 /= s0; for (k=i; k<=j; k++) y[k] = s1; } /*************************************************/ static void wpava (DBL *y, DBL *w, int *np) /* Apply weighted pava to y[0:n-1] using weights w[0:n-1] */ { int npools, n = *np; if (n <= 1) return; n--; /* keep passing through the array until pooling is not needed */ do { int i = 0; npools = 0; while (i < n) { int k = i; /* starting at y[i], find longest non-increasing sequence y[i:k] */ while (k < n && y[k] >= y[k+1]) k++; if (y[i] != y[k]) {wpool(y, w, i, k); npools++;} i = k+1; } } while (npools > 0); } /*************************************************/ static void upool (DBL *y, int i, int j) /* Pool y[i:j] */ { int k; DBL s=0; for (k=i; k<=j; k++) {s += y[k];} s /= (j-i+1); for (k=i; k<=j; k++) y[k] = s; } /*************************************************/ static void upava (DBL *y, int *np) /* Apply pava to y[0:n-1] */ { int npools, n = *np; if (n <= 1) return; n--; /* keep passing through the array until pooling is not needed */ do { int i = 0; npools = 0; while (i < n) { int k = i; /* starting at y[i], find longest non-increasing sequence y[i:k] */ while (k < n && y[k] >= y[k+1]) k++; if (y[i] != y[k]) {upool(y, i, k); npools++;} i = k+1; } } while (npools > 0); } /*************************************************/ void pava (DBL *y, DBL *w, int *np) /* Apply pava to y[0:n-1] using weights w[0:n-1] Calls an unweighted version if all weights are equal and != 0 Does nothing if all weights are == 0 Calls a weighted version otherwise */ { int n = *np, i=1; DBL w0; if (n <= 1) return; w0 = w[0]; while (i < n && w[i] == w0) i++; if (i == n) { if (w0 == 0.0) return; /* all weights are == 0 */ else upava(y, np); /* unweighted */ } else wpava(y, w, np); /* weighted */ } timereg/src/comptest-cmprsk.c0000644000176200001440000001272414421510301015771 0ustar liggesusers//#include #include #include #include "matrix.h" void comptestfunc(double *times,int *Ntimes,int *px,double *cu,double *vcu,double *vcudif,int *antsim,double *test,double *testOBS,double *Ut,double *simUt,matrix **W4t,int *weighted,int *antpers,double *gamma,int *line,double *timepow) //double *times,*cu,*vcu,*vcudif,*test,*testOBS,*Ut,*simUt,*gamma,*timepow; //int *px,*Ntimes,*antsim,*weighted,*antpers,*line; //matrix **W4t; { matrix *Delta,*tmpM1; vector *gammavt,*tmpv1t,*tmpv1,*rowX,*xi,*difX,*ssrow,*VdB, *gammai[*antpers],*gammav; /*float gasdev(),expdev(),ran1(); */ // double norm_rand(); // void GetRNGstate(),PutRNGstate(); int i,k,l,s,c; double xij,vardif,tau,time,dtime,random,stime,mtime;// unused var:x double *cumweight=calloc(*px,sizeof(double)); malloc_vecs(*px,&tmpv1t,&tmpv1,&rowX,&xi,&difX,&ssrow,&VdB,&gammavt,&gammav,NULL); malloc_mat(*Ntimes,*px,Delta); malloc_mat(*Ntimes,*px,tmpM1); for (i=0;i<*antpers;i++) malloc_vec(*px,gammai[i]); /* Rprintf("Simulations start N= %ld \n",*antsim); */ GetRNGstate(); /* to use R random normals */ stime=times[0]; stime=0; mtime=times[(*Ntimes-1)]-stime; tau=times[(*Ntimes-1)]-stime; Ut[0]=times[0]; if (*weighted==3) { if (*line==0) for (i=0;i<*px;i++) cumweight[i]=tau; else for (i=0;i<*px;i++) cumweight[i]=mtime*mtime*0.5; } /* computation of constant effects */ for (i=0;i<*px;i++) { if (fabs(timepow[i])<0.000001) { // timepow ca 0 for (s=0;s<*Ntimes;s++) if (vcu[i*(*Ntimes)+s]>0) { // time=times[s];dtime=times[s]-times[s-1]; if (vcu[(i+1)*(*Ntimes)+s]>0) { cumweight[i]=cumweight[i]+(1/vcu[(i+1)*(*Ntimes)+s]); gamma[i]=gamma[i]+cu[(i+1)*(*Ntimes)+s]/vcu[(i+1)*(*Ntimes)+s]; for (c=0;c<*antpers;c++) VE(gammai[c],i)= VE(gammai[c],i)+ME(W4t[c],s,i)/vcu[(i+1)*(*Ntimes)+s]; } } gamma[i]=gamma[i]/cumweight[i]; VE(gammav,i)=gamma[i]; for (c=0;c<*antpers;c++) VE(gammai[c],i)=VE(gammai[c],i)/cumweight[i]; } else { gamma[i]=cu[(i+1)*(*Ntimes)+(*Ntimes-1)]/pow(mtime,timepow[i]);; VE(gammav,i)=gamma[i]; for (c=0;c<*antpers;c++) VE(gammai[c],i)=ME(W4t[c],*Ntimes-1,i)/pow(mtime,timepow[i]);; } } /* i=1..px */ /* if (*weighted>=1) { for (s=1;s<*Ntimes;s++) { vec_zeros(VdB); for (i=0;i<*antpers;i++) { extract_row(W4t[i],s,tmpv1); vec_subtr(tmpv1,gammai[i],difX); vec_star(difX,difX,rowX); vec_add(rowX,VdB,VdB); } for (k=1;k<=*px;k++) vcudif[k*(*Ntimes)+s]=VE(VdB,k-1); } } */ /* weighted==1 */ /* Computation of observed teststatistics */ for (s=1;s<*Ntimes;s++) if (vcu[0*(*Ntimes)+s]>0) { time=times[s]-stime; dtime=times[s]-times[s-1]; for (i=1;i<=*px;i++) { xij=fabs(cu[i*(*Ntimes)+s])/sqrt(vcu[i*(*Ntimes)+s]); if (xij>testOBS[i-1]) testOBS[i-1]=xij; } for (i=1;i<=*px;i++) VE(xi,i-1)=cu[i*(*Ntimes)+s]; // if (*line==1) scl_vec_mult(time,gammav,gammavt); for (i=0;i<*px;i++) VE(gammavt,i)=VE(gammav,i)*pow(time,timepow[i]); vec_subtr(xi,gammavt,difX); vec_star(difX,difX,ssrow); Ut[s]=times[s]; for (i=0;i<*px;i++) { // if (*weighted>=2) vardif=vcudif[(i+1)*(*Ntimes)+s]; else vardif=1; // if (*weighted>=2) { // if ((s>*weighted) && (s<*Ntimes-*weighted)) // VE(difX,i)=VE(difX,i)/sqrt(vardif); else VE(difX,i)=0.0; // } else VE(difX,i)=VE(difX,i); Ut[(i+1)*(*Ntimes)+s]=VE(difX,i); c=(*px)+i; if (fabs(VE(difX,i))>testOBS[c]) testOBS[c]=fabs(VE(difX,i)); c=2*(*px)+i; if ((s>*weighted) && (s<*Ntimes-*weighted)) testOBS[c]=testOBS[c]+VE(ssrow,i)*dtime; } } /* for (i=0;i<3*(*px);i++) Rprintf(" %lf \n",testOBS[i]); */ /* simulation of testprocesses and teststatistics */ for (k=1;k<*antsim;k++) { mat_zeros(Delta); vec_zeros(tmpv1); for (i=0;i<*antpers;i++) { /* random=gasdev(&idum); */ random=norm_rand(); scl_mat_mult(random,W4t[i],tmpM1);mat_add(tmpM1,Delta,Delta); scl_vec_mult(random,gammai[i],xi); vec_add(xi,tmpv1,tmpv1); } scl_vec_mult(1,tmpv1,tmpv1t); for (s=1;s<*Ntimes;s++) if (vcu[0*(*Ntimes)+s]>0) { time=times[s]-stime; dtime=times[s]-times[s-1]; extract_row(Delta,s,rowX); // if (*line==1) scl_vec_mult(times[s],tmpv1,tmpv1t); for (i=0;i<*px;i++) VE(tmpv1t,i)=VE(tmpv1,i)*pow(time,timepow[i]);; vec_subtr(rowX,tmpv1t,difX); vec_star(difX,difX,ssrow); for (i=0;i<*px;i++) { VE(xi,i)=fabs(ME(Delta,s,i))/sqrt(vcu[(i+1)*(*Ntimes)+s]); if (VE(xi,i)>test[i*(*antsim)+k]) test[i*(*antsim)+k]=VE(xi,i); if (*weighted>=1) vardif=vcudif[(i+1)*(*Ntimes)+s]; else vardif=1; if (*weighted>=2) { if ((s>*weighted) && (s<*Ntimes-*weighted)) VE(difX,i)=VE(difX,i)/sqrt(vardif); else VE(difX,i)=0; } else VE(difX,i)=VE(difX,i); if (k<51) {l=(k-1)*(*px)+i; simUt[l*(*Ntimes)+s]=VE(difX,i);} c=(*px+i); VE(difX,i)=fabs(VE(difX,i)); if (VE(difX,i)>test[c*(*antsim)+k]) test[c*(*antsim)+k]=VE(difX,i); c=2*(*px)+i; if ((s>*weighted) && (s<*Ntimes-*weighted)) test[c*(*antsim)+k]=test[c*(*antsim)+k]+VE(ssrow,i)*dtime/vardif; } } /* s=1..Ntimes */ } /* k=1..antsim */ PutRNGstate(); /* to use R random normals */ free_mats(&Delta,&tmpM1,NULL); free_vecs(&gammavt,&tmpv1t,&VdB,&rowX,&difX,&xi,&tmpv1,&ssrow,&gammav,NULL); for (i=0;i<*antpers;i++) free_vec(gammai[i]); free(cumweight); } timereg/src/Makevars0000644000176200001440000000006114666275266014212 0ustar liggesusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) timereg/src/Gprop-odds.c0000644000176200001440000004672014421510301014657 0ustar liggesusers//#include #include #include #include "matrix.h" /* ====================================================== */ void Gtranssurv(double *times,int *Ntimes,double *designX,int *nx,int *px,double *designG,int *ng,int *pg,int *antpers,double *start,double *stop, double *betaS,int *Nit,double *cu,double *vcu,double *loglike,double *Iinv,double *Vbeta,int *detail,int *sim,int *antsim, int *rani,double *Rvcu,double *RVbeta,double *test,double *testOBS,double *Ut,double *simUt,double *Uit,int *id,int *status, int *wscore,double *score,double *dhatMit,double *dhatMitiid, int *retur,int *exppar,int *sym,int *mlestart,int *stratum) //double *designX,*designG,*times,*betaS,*start,*stop,*cu,*loglike,*Vbeta,*RVbeta, //*vcu,*Rvcu,*Iinv,*test,*testOBS,*Ut,*simUt,*Uit,*score,*dhatMit,*dhatMitiid; //int *nx,*px,*ng,*pg,*antpers,*Ntimes,*Nit,*detail,*sim,*antsim,*rani,*id,*status, //*wscore,*retur,*exppar,*sym,*mlestart,*stratum; { // {{{ matrix *ldesignX,*cdesG,*ldesignG,*cdesX,*cdesX2,*cdesX3,*cdesX4,*CtVUCt,*A,*AI; matrix *dYI,*Ct,*dM1M2,*M1M2t,*COV,*ZX,*ddesG,*ZP,*ZPX; matrix *tmp1,*tmp2,*tmp5,*tmp3,*dS,*S1,*SI,*S2,*M1,*VU,*VUI, *tmp6; // Added tmp6 matrix *RobVbeta,*Delta,*tmpM1,*Utt,*Delta2,*tmpM2; matrix *St[*Ntimes],*M1M2[*Ntimes],*C[*Ntimes],*ZXAIs[*Ntimes],*dYIt[*Ntimes]; matrix *dW3t[*antpers],*W3t[*antpers],*W4t[*antpers],*W2t[*antpers],*AIxit[*antpers],*Uti[*antpers],*tmp4,*Fst[(*Ntimes)*(*Ntimes)]; matrix *dG[*Ntimes],*cumdG,*Ft[*Ntimes],*ZcX2AIs[*Ntimes],*ZcX2[*Ntimes],*S0tI[*Ntimes],*Ident,*gt[*Ntimes],*q2t[*Ntimes],*G1mG2t[*Ntimes],*q1t[*antpers]; vector *dA,*VdA,*MdA,*delta,*zav,*lamt,*plamt,*dlamt; vector *xi,*zi,*U,*beta,*xtilde,*Gbeta,*zcol,*one,*difzzav; vector *offset,*weight,*ZXdA[*Ntimes],*varUthat[*Ntimes],*Uprofile; vector *ta,*ahatt,*risk; vector *tmpv1,*tmpv2,*rowX,*rowZ,*difX,*VdB,*lht; vector *dLamt[*antpers],*dAt[*Ntimes]; vector *W2[*antpers],*W3[*antpers],*reszpbeta,*res1dim; int t,c,robust=1,pers=0,i,j,k,l,s,it,count,pmax; int *ipers=calloc(*Ntimes,sizeof(int)); double time=0,dummy,ll; double tau,dhati,hati=0,random,sumscore; // double norm_rand(); // void GetRNGstate(),PutRNGstate(); for(j=0;j<*Ntimes;j++) { malloc_mat(*px,*px,Ft[j]); malloc_mat(*pg,*px,ZcX2AIs[j]); malloc_mat(*pg,*px,gt[j]); malloc_mat(*pg,*px,G1mG2t[j]); malloc_mat(*pg,*px,q2t[j]); malloc_mat(*pg,*px,ZcX2[j]); malloc_mat(*px,*px,S0tI[j]); malloc_mat(*px,*pg,dG[j]); malloc_mat(*px,*pg,C[j]); malloc_mat(*pg,*px,M1M2[j]); malloc_mat(*pg,*px,ZXAIs[j]); malloc_mat(*px,*pg,dYIt[j]); malloc_vec(*px,dAt[j]); malloc_vec(*pg,ZXdA[j]); malloc_mat(*pg,*pg,St[j]); malloc_vec(*pg,varUthat[j]); for(i=0;i<=j;i++){ malloc_mat(*px,*px,Fst[j*(*Ntimes)+i]); } } for (j=0;j<*antpers;j++) { malloc_vec(*Ntimes,dLamt[j]); malloc_mat(*Ntimes,*px,W3t[j]); malloc_mat(*Ntimes,*px,dW3t[j]); malloc_mat(*Ntimes,*px,W4t[j]); malloc_mat(*Ntimes,*pg,W2t[j]); malloc_mat(*Ntimes,*pg,Uti[j]); malloc_vec(*pg,W2[j]); malloc_vec(*px,W3[j]); malloc_mat(*Ntimes,*pg,q1t[j]); malloc_mat(*Ntimes,*px,AIxit[j]); } malloc_mat(*Ntimes,*px,Delta); malloc_mat(*Ntimes,*px,tmpM1); malloc_mat(*Ntimes,*pg,Delta2); malloc_mat(*Ntimes,*pg,tmpM2); malloc_mat(*Ntimes,*pg,Utt); malloc_mats(*antpers,*px,&ldesignX,&cdesX,&cdesX2,&cdesX3,&cdesX4,NULL); malloc_mats(*antpers,*pg,&ZP,&cdesG,&ldesignG,&ddesG,NULL); malloc_mats(*px,*px,&tmp4,&Ident,&COV,&A,&AI,&M1,&CtVUCt,NULL); malloc_mats(*pg,*pg,&RobVbeta,&tmp1,&tmp2,&dS,&S1,&S2,&SI,&VU,&VUI,NULL); malloc_mats(*pg,*px,&tmp5,&tmp3,&ZX,&dM1M2,&M1M2t,NULL); malloc_mats(*px,*pg,&cumdG,&ZPX,&dYI,&Ct,NULL); malloc_mat(*px,*pg,tmp6); malloc_vec(1,reszpbeta); malloc_vec(1,res1dim); malloc_vec(*Ntimes,lht); malloc_vecs(*antpers,&risk,&weight,&dlamt,&plamt,&lamt,&zcol,&Gbeta,&one,&offset,NULL); malloc_vecs(*px,&ahatt,&tmpv1,&difX,&VdB,&rowX,&xi,&dA,&VdA,&MdA,NULL); malloc_vecs(*px,&ta,&xtilde,NULL); malloc_vecs(*pg,&tmpv2,&rowZ,&zi,&U,&beta,&delta,&zav,&difzzav,&Uprofile,NULL); identity_matrix(Ident); // if (*px>=*pg){ pmax=*px; } else { pmax=*pg; } pmax=max(*px,*pg); ll=0; vec_ones(one); for(j=0;j<*pg;j++){ VE(beta,j)=betaS[j]; } vec_ones(difX); cu[0]=times[0]; // }}} /* Main procedure ================================== */ for (it=0;it<*Nit;it++){ vec_zeros(U); mat_zeros(S1); sumscore=0; for (s=1;s<*Ntimes;s++){ // {{{ time=times[s]; mat_zeros(ldesignX); mat_zeros(ldesignG); // vec_zeros(risk); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { // {{{ if ((start[c]=time)) { VE(risk,id[c])=1.0; for(j=0;j=0) // first time use update hazard est for (j=0;j<*antpers;j++){ if (s<0 && j<5 ) { Rprintf(" %ld %ld \n",(long int) s, (long int)j); print_vec(zi); } extract_row(ddesG,j,zi); scl_vec_mult(VE(lamt,j),zi,zi); replace_row(ZP,j,zi); } MtA(ldesignX,ZP,ZPX); MxA(AI,ZPX,tmp6); // Note the use of tmp6 here, instead of tmp3 mat_subtr(dG[s-1],tmp6,dG[s]); // Note the use of tmp6 here, instead of tmp3 if (s<0) { Rprintf(" %lf \n",ME(A,0,0)); print_mat(ZPX); print_mat(tmp3); print_mat(dG[s]); } MxA(ZXAIs[s],ZPX,SI); mat_transp(SI,tmp2); MtA(ldesignG,ZP,tmp1); mat_subtr( tmp1,tmp2, dS); if (s<0) { Rprintf("=================== %lf \n",ME(A,0,0)); print_mat(tmp1); print_mat(tmp2); print_mat(dS); } if (*sym==1) { mat_transp(dS,tmp1); mat_add(tmp1,dS,dS); scl_mat_mult(0.5,dS,dS); } /* else {m_transp(dS,tmp1); sm_mlt(1,tmp1,dS); } */ mat_add(dS,S1,S1); scl_mat_mult(1.0,S1,St[s]); /* variance and other things */ if (it==((*Nit)-1)) { // {{{ replace_row(Utt,s,U); for (j=0;j<*px;j++) { // {{{ for (i=0;i<*antpers;i++){ dummy=ME(ldesignX,i,j); extract_row(cdesX2,i,xi); scl_vec_mult(dummy,xi,xi); replace_row(cdesX3,i,xi); } MtA(ldesignX,cdesX3,A); MxA(AI,A,tmp4); Mv(tmp4,dA,xi); for (k=0;k<*px;k++){ ME(Ft[s],j,k)=VE(xi,k); } VE(lht,s)=VE(lht,s-1)-ME(A,0,0)*(ME(AI,0,0)*ME(AI,0,0)); /* Rprintf(" %ld %lf %lf \n",s,lht->ve[s],AI->me[0][0]); */ MtA(ldesignG,cdesX3,ZcX2[s]); /* m_mlt(ZcX2[s],AI,ZcX2AIs[s]); */ MxA(ZX,tmp4,tmp3); mat_subtr(tmp3,ZcX2[s],tmp5); Mv(tmp5,dA,zi); for (k=0;k<*pg;k++) { ME(G1mG2t[s],k,j)=ME(G1mG2t[s],k,j)+VE(zi,k); } } // }}} /* for (i=0;i<*px;i++){ for (j=0;j<*pg;j++) dM1M2->me[j][i]=dA->ve[i]*difzzav->ve[j]; for (i=0;i<*pg;i++) for (j=0;j<*pg;j++) VU->me[i][j]=VU->me[i][j]+difzzav->ve[i]*difzzav->ve[j]; m_mlt(AI,ZPX,dYIt[s]); m_sub(Ct,dYIt[s],Ct); C[s]=m_copy(Ct,C[s]); v_star(dA,dA,VdA); m_add(dM1M2,M1M2t,M1M2t); M1M2[s]=m_copy(M1M2t,M1M2[s]); for (k=1;k<=*px;k++) vcu[k*(*Ntimes)+s]=VdA->ve[k-1]+vcu[k*(*Ntimes)+s-1]; */ for (j=0;j<*antpers;j++){ extract_row(ldesignX,j,xi); Mv(S0tI[s],xi,rowX); replace_row(AIxit[j],s,rowX); extract_row(ldesignG,j,zi); Mv(ZX,rowX,rowZ); vec_subtr(zi,rowZ,zi); replace_row(q1t[j],s,zi); VE(dLamt[j],s)=VE(plamt,j)*vec_sum(vec_star(xi,dA,rowX)); } } // }}} /* if (it==((*Nit)-1)) */ } // }}} /* Ntimes */ invertS(S1,SI,1); Mv(SI,U,delta); vec_add(beta,delta,beta); if (*detail>=1) { // {{{ Rprintf("====================Iteration %ld ==================== \n",(long int) it); Rprintf("delta \n"); print_vec(delta); Rprintf("Estimate beta \n"); print_vec(beta); Rprintf("Score D l\n"); print_vec(U); Rprintf("Information -D^2 l\n"); print_mat(SI); Rprintf("simple D2 l\n"); print_mat(S1); } // }}} for (k=0;k<*pg;k++) sumscore += VE(U,k); if ((fabs(sumscore)<0.000001) & (it<*Nit-2)) it=*Nit-2; } /* it */ for (k=0;k<*pg;k++) score[k]=VE(U,k); /* computation of q(t) */ for (s=1;s<*Ntimes;s++) { // {{{ mat_zeros(M1M2t); for (t=s;t<*Ntimes;t++) { identity_matrix(tmp4); identity_matrix(M1); for (k=s;ks) { scl_mat_mult(1,M1,tmp4); } mat_subtr(Ident,Ft[k],A); MxA(tmp4,A,M1); } if (s<0) { Rprintf(" %ld %ld %lf \n",(long int) s,(long int) t,ME(M1,0,0)); matrix *tempTranspose; malloc_mat(ncol_matrix(G1mG2t[t]), nrow_matrix(G1mG2t[t]),tempTranspose); print_mat(mat_transp(G1mG2t[t],tempTranspose)); free_mat(tempTranspose); } MxA(G1mG2t[t],M1,dM1M2); mat_add(dM1M2,M1M2t,M1M2t); } scl_mat_mult(1,M1M2t,q2t[s]); /* m_mlt(M1M2t,S0tI[s],q2t[s]); */ if (s<0){ matrix *tempTranspose; malloc_mat(ncol_matrix(q2t[s]), nrow_matrix(q2t[s]),tempTranspose); print_mat(mat_transp(q2t[s],tempTranspose)); free_mat(tempTranspose); } } // }}} /* terms for robust variances ============================ */ if (robust==1) { // {{{ for (s=1;s<*Ntimes;s++) { // {{{ time=times[s]; cu[s]=times[s]; vcu[s]=times[s]; Rvcu[s]=times[s]; Ut[s]=times[s]; /* terms for robust variance */ for (i=0;i<*antpers;i++) { extract_row(AIxit[i],s,xi); Mv(q2t[s],xi,rowZ); extract_row(q1t[i],s,zi); if (s==0) { print_vec(rowZ); print_vec(zi); } vec_add(zi,rowZ,rowZ); if (s==0) { print_vec(rowZ); } /* mv_mlt(ZXAIs[s],xi,tmpv2); v_sub(zi,tmpv2,tmpv2); */ if (i==ipers[s]) { for (j=0;j<*pg;j++) { for (k=0;k<*pg;k++) { ME(VU,j,k) += VE(rowZ,j)*VE(rowZ,k); } } } scl_vec_mult(VE(dLamt[i],s),rowZ,tmpv2); vec_subtr(W2[i],tmpv2,W2[i]); if (i==ipers[s]) { vec_add(rowZ,W2[i],W2[i]); } /* if (*ratesim==1) {sv_mlt(hati,tmpv2,rowZ); v_sub(W2[i],rowZ,W2[i]);} */ replace_row(W2t[i],s,W2[i]); vec_zeros(W3[i]); for (t=1;t<=s;t++) { if (i==0) { identity_matrix(tmp4); identity_matrix(M1); for (k=t;k<=s;k++) { if (k>t) { scl_mat_mult(1.0,M1,tmp4); } if (k>t || t==s) { mat_subtr(Ident,Ft[k],A); MxA(tmp4,A,M1); } } scl_mat_mult(1,M1,Fst[s*(*Ntimes)+t]); } /* Fst[s*(*Ntimes)+t]->me[0][0]=exp(-lht->ve[t]+lht->ve[s]); */ extract_row(AIxit[i],t,xi); vM(Fst[s*(*Ntimes)+t],xi,rowX); scl_vec_mult(VE(dLamt[i],t),rowX,tmpv1); vec_subtr(W3[i],tmpv1,W3[i]); if (i==ipers[t]){ vec_add(rowX,W3[i],W3[i]); } } replace_row(W3t[i],s,W3[i]); /* if (hati>0) lle=lle+log(hati); llo=llo+hati; */ /* if (*ratesim==1) {sv_mlt(hati,rowX,rowX); v_sub(W3[i],rowX,W3[i]);} */ if (*retur==1){ dhatMit[i*(*Ntimes)+s]=1*(i==pers)-hati; } } /* i=1..antpers */ } // }}} /* s=1 ..Ntimes */ MxA(SI,VU,S2); MxA(S2,SI,VU); /* ROBUST VARIANCES */ for (s=1;s<*Ntimes;s++) { // {{{ if (s<0){ print_mat(dG[s]); } vec_zeros(VdB); for (i=0;i<*antpers;i++) { Mv(SI,W2[i],tmpv2); Mv(dG[s],tmpv2,rowX); extract_row(W3t[i],s,xi); if (s>*Ntimes-5 && i<0){ print_vec(xi); } vec_add(xi,rowX,difX); replace_row(W4t[i],s,difX); if (i==-5){ print_vec(difX); } vec_star(difX,difX,tmpv1); vec_add(tmpv1,VdB,VdB); Mv(St[s],tmpv2,rowZ); extract_row(W2t[i],s,tmpv2); vec_subtr(tmpv2,rowZ,zi); replace_row(Uti[i],s,zi); vec_star(zi,zi,tmpv2); vec_add(tmpv2,varUthat[s],varUthat[s]); if (s==1) { for (j=0;j<*pg;j++){ for (k=0;k<*pg;k++){ ME(RobVbeta,j,k) += VE(W2[i],j)*VE(W2[i],k); } } } if (*retur==1) { mat_zeros(ldesignX); mat_zeros(ldesignG); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { // VE(risk,id[c])=1.0; for(j=0;jtestOBS[i-1]) testOBS[i-1]=VE(xi,i-1); } scl_vec_mult(time/tau,rowX,difX); for (i=1;i<=*px;i++) { VE(xi,i-1)=cu[i*(*Ntimes)+s]; } vec_subtr(xi,difX,difX); for (i=0;i<*px;i++) { VE(difX,i)=fabs(VE(difX,i)); l=(*px+i); if (VE(difX,i)>testOBS[l]) testOBS[l]=VE(difX,i); } if (*wscore>=1) { /* sup beregnes i R */ if ((s>*wscore) && (s<*Ntimes-*wscore)) { extract_row(Utt,s,rowZ); for (i=0;i<*pg;i++) { VE(rowZ,i)=VE(rowZ,i)/sqrt(VE(varUthat[s],i)); } replace_row(Utt,s,rowZ); /* scaled score process */ } else { vec_zeros(rowZ); replace_row(Utt,s,rowZ); } } for (k=1;k<=*pg;k++){ Ut[k*(*Ntimes)+s]=ME(Utt,s,k-1); } } /*s=1..Ntimes Beregning af obs teststorrelser */ for (k=1;k<*antsim;k++) { mat_zeros(Delta); mat_zeros(Delta2); vec_zeros(tmpv1); for (i=0;i<*antpers;i++) { /* random=gasdev(&idum); */ random=norm_rand(); scl_mat_mult(random,W4t[i],tmpM1); mat_add(tmpM1,Delta,Delta); scl_mat_mult(random,Uti[i],tmpM2); mat_add(tmpM2,Delta2,Delta2); } extract_row(Delta,*Ntimes-1,tmpv1); for (s=1;s<*Ntimes;s++) { time=times[s]-times[0]; scl_vec_mult(time/tau,tmpv1,xi); extract_row(Delta,s,rowX); vec_subtr(rowX,xi,difX); for (i=0;i<*px;i++) { VE(difX,i)=fabs(VE(difX,i)); l=(*px+i); if (VE(difX,i)>test[l*(*antsim)+k]) test[l*(*antsim)+k]=VE(difX,i); VE(xi,i)=fabs(ME(Delta,s,i))/sqrt(Rvcu[(i+1)*(*Ntimes)+s]); if (VE(xi,i)>test[i*(*antsim)+k]) test[i*(*antsim)+k]=VE(xi,i); } if (*wscore>=1) { extract_row(Delta2,s,zi); if ((s>*wscore) && (s<*Ntimes-*wscore)) { for (i=0;i<*pg;i++) { VE(zi,i)=fabs(ME(Delta2,s,i))/sqrt(VE(varUthat[s],i)); if (VE(zi,i)>simUt[i*(*antsim)+k]) simUt[i*(*antsim)+k]=VE(zi,i); } if (k<50) { for (i=0;i<*pg;i++) { l=(k-1)*(*pg)+i; Uit[l*(*Ntimes)+s]=ME(Delta2,s,i)/sqrt(VE(varUthat[s],i)); } } } } else { /* weigted score */ extract_row(Delta2,s,zi); for (i=0;i<*pg;i++) { if (fabs(VE(zi,i))>simUt[i*(*antsim)+k]) simUt[i*(*antsim)+k]=fabs(VE(zi,i)); } if (k<50) { for (i=0;i<*pg;i++) { l=(k-1)*(*pg)+i; Uit[l*(*Ntimes)+s]=ME(Delta2,s,i); } } } /* else wscore=0 */ } /* s=1..Ntims */ } /* k=1..antsim */ PutRNGstate(); /* to use R random normals */ } // }}} /* sim==1 */ // {{{ freeing free_mats(&cumdG,&tmp4,&Ident,&ddesG,&Utt,&tmpM2,&VUI,&ZX,&COV, &dM1M2,&AI,&A,&tmp1,&tmp2,&tmp5,&tmp3,&ldesignX,&cdesX, &cdesX2,&cdesX4,&cdesX3,&cdesG,&ldesignG,&M1,&dS,&S1,&SI,NULL); free_mats(&tmp6,&S2,&VU,&ZP,&ZPX,&dYI,&Ct,&M1M2t,&RobVbeta,&Delta,&Delta2, &tmpM1,&CtVUCt,NULL); free_vecs(&lht,&risk,&ta,&ahatt,&Uprofile,&dlamt,&plamt,&lamt,&one,&xi,&zcol,&Gbeta,&VdA,&dA,&MdA,&xtilde,&zi,&U,&beta,&delta,&zav,&difzzav,&weight,&offset,&tmpv1,&tmpv2,&rowX,&rowZ,&difX,&VdB,&reszpbeta,&res1dim,NULL); for (j=0;j<*antpers;j++) { free_vec(dLamt[j]); free_mat(W3t[j]); free_mat(dW3t[j]); free_mat(W4t[j]); free_mat(W2t[j]); free_mat(Uti[j]); free_vec(W2[j]); free_vec(W3[j]); free_mat(q1t[j]); free_mat(AIxit[j]); } for (j=0;j<*Ntimes;j++) { free_mat(Ft[j]); free_mat(ZcX2AIs[j]); free_mat(gt[j]); free_mat(G1mG2t[j]); free_mat(q2t[j]); free_mat(ZcX2[j]); free_mat(S0tI[j]); free_mat(dG[j]); free_mat(C[j]); free_mat(M1M2[j]); free_mat(ZXAIs[j]); free_mat(dYIt[j]); free_vec(dAt[j]); free_vec(ZXdA[j]); free_mat(St[j]); free_vec(varUthat[j]); for(i=0;i<=j;i++) free_mat(Fst[j*(*Ntimes)+i]); } free(ipers); // }}} } timereg/src/comprisk.c0000644000176200001440000010220414421510301014456 0ustar liggesusers//#include #include #include "matrix.h" void itfit(double *times,int *Ntimes,double *x, int *censcode,int *cause,double *KMc, double *z,int *n,int *px, int *Nit,double *betaS, double *score, double *hess,double *est,double *var, int *sim,int *antsim,int *rani, double *test,double *testOBS,double *Ut, double *simUt,int *weighted, double *gamma, double *vargamma,int *semi,double *zsem, int *pg,int *trans,double *gamma2, int *CA,int *line,int *detail, double *biid,double *gamiid,int *resample, double *timepow,int *clusters,int *antclust, double *timepowtest,int *silent,double *convc, double *weights,double *entry,double *trunkp, int *estimator,int *fixgamma,int *stratum, int *ordertime, int *conservative,double *ssf, double *KMtimes,double *gamscore,double *Dscore, int *monotone) { // {{ // {{{ allocation and reading of data from R matrix *wX,*X,*cX,*A,*AI,*cumAt[*antclust],*VAR,*Z,*censX; vector *VdB,*risk,*SCORE,*W,*Y,*Gc,*CAUSE,*bhat,*pbhat,*beta,*xi,*censXv, *rr,*rowX,*difbeta,*qs,*bhatub,*betaub,*dcovs,*pcovs,*zi,*rowZ,*zgam,*vcumentry; vector *cumhatA[*antclust],*cumA[*antclust],*bet1,*gam,*dp,*dp1,*dp2; int clusterj,osilent,convt=1,ps,sing,c,i,j,k,l,s,it,convproblems=0; double step,prede,varp=0.5,nrisk,time,sumscore,totrisk, *vcudif=calloc((*Ntimes)*(*px+1),sizeof(double)), *cifentry=calloc((*n),sizeof(double)), *cumentry=calloc((*n)*(*px+1),sizeof(double)); // float gasdev(),expdev(),ran1(); ps=(*px); // }}} step=ssf[0]; if (*semi==0) { osilent=silent[0]; silent[0]=0; malloc_mats(*n,*px,&wX,&X,&cX,&censX,NULL); if (*trans==2) {malloc_mat(*n,*pg,Z);malloc_vecs(*pg,&zgam,&gam,&zi,&rowZ,NULL);} malloc_mats(ps,ps,&A,&AI,&VAR,NULL); malloc_vecs(*n,&rr,&bhatub,&risk,&W,&Y,&Gc,&CAUSE,&bhat,&pbhat,NULL); malloc_vecs(*px,&vcumentry,&bet1,&xi,&rowX,&censXv,NULL); malloc_vecs(ps,&dp,&dp1,&dp2,&dcovs,&pcovs,&betaub,&VdB,&qs,&SCORE,&beta,&difbeta,NULL); for (i=0;i<*antclust;i++) { malloc_vec(ps,cumhatA[i]); malloc_vec(ps,cumA[i]); malloc_mat(*Ntimes,ps,cumAt[i]); } for (c=0;c=time); totrisk=totrisk+VE(risk,j); extract_row(X,j,xi); if (it==0 && (s==0)) { scl_vec_mult(pow(weights[j],0.5),xi,rowX); replace_row(wX,j,rowX); } VE(bhat,j)=vec_prod(xi,bet1); if (*trans==1) { // {{{ VE(pbhat,j)=1-exp(-VE(bhat,j)); varp=VE(pbhat,j)*(1-VE(pbhat,j)); // if (*monotone==1) scl_vec_mult(1,xi,dp1); else scl_vec_mult(1-VE(pbhat,j),xi,dp); } if (*trans==2) { VE(pbhat,j)=1-exp(-exp(VE(bhat,j))); varp=VE(pbhat,j)*(1-VE(pbhat,j)); // if (*monotone==1) scl_vec_mult(1,xi,dp1); else scl_vec_mult((1-VE(pbhat,j))*exp(VE(bhat,j)),xi,dp); } if (*trans==6) { VE(pbhat,j)=1-exp(-VE(bhat,j)); varp=VE(pbhat,j)*(1-VE(pbhat,j)); // if (*monotone==1) scl_vec_mult(1,xi,dp1); else scl_vec_mult((1-VE(pbhat,j)),xi,dp); } if (*trans==3) { VE(pbhat,j)=exp(VE(bhat,j))/(1+exp(VE(bhat,j))); varp=VE(pbhat,j)*(1-VE(pbhat,j)); // if (*monotone==1) scl_vec_mult(1,xi,dp1); else scl_vec_mult(exp(VE(bhat,j))/pow((1+exp(VE(bhat,j))),2),xi,dp); } if (*trans==7) { VE(pbhat,j)=VE(bhat,j)/(1+VE(bhat,j)); // if (*monotone==1) scl_vec_mult(1,xi,dp1); else scl_vec_mult(1/pow((1+VE(bhat,j)),2),xi,dp); } if (*trans==4) { VE(pbhat,j)=exp(VE(bhat,j)); varp=VE(pbhat,j)*(1-VE(pbhat,j)); // if (*monotone==1) scl_vec_mult(1,xi,dp1); else scl_vec_mult(exp(VE(bhat,j)),xi,dp); } if (*trans==5) { VE(pbhat,j)=VE(bhat,j); varp=VE(pbhat,j)*(1-VE(pbhat,j)); scl_vec_mult(1,xi,dp); } // }}} // scl_vec_mult(1,dp,dp1); if (*estimator<=2) scl_vec_mult(pow(weights[j],0.5),dp,dp); else scl_vec_mult(pow(weights[j],0.5)*(timeentry[j]),dp,dp); replace_row(cX,j,dp); // printf(" %d \n",cause[j]); printf(" %d \n",abs(cause[j])); VE(Y,j)=((x[j]<=time) & (abs(cause[j])==*CA))*1; if (cause[j]<0) VE(Y,j)=-1*VE(Y,j); if (it==(*Nit-1) && (*conservative==0)) { // {{{ for censoring distrubution if (*monotone==1) scl_vec_mult(1,xi,dp1); if (KMc[j]>0.001) scl_vec_mult(weights[j]*VE(Y,j)/KMc[j],dp1,dp1); else scl_vec_mult(weights[j]*VE(Y,j)/0.001,dp1,dp1); vec_add(censXv,dp1,censXv); replace_row(censX,j,dp1); } // }}} if (*estimator==1) { if (KMc[j]<0.001) VE(Y,j)=((VE(Y,j)/0.001)-VE(pbhat,j)); else VE(Y,j)=( (VE(Y,j)/KMc[j])-VE(pbhat,j))*(time>entry[j]); } else if (*estimator==2) // truncation, but not implemented { if (KMc[j]<0.001) VE(Y,j)=(1/0.001)*(VE(Y,j)-VE(pbhat,j)); else VE(Y,j)=(1/KMc[j])*(VE(Y,j)-VE(pbhat,j)/trunkp[j]); } else if (*estimator==3) { VE(Y,j)=(VE(Y,j)-VE(pbhat,j))*(timeentry[j]);; } else if (*estimator==4) { if (KMc[j]<0.001) VE(Y,j)=((VE(Y,j)/0.001)-VE(pbhat,j)); else VE(Y,j)=( (VE(Y,j)/KMc[j])-VE(pbhat,j)); if (varp>0.001) VE(Y,j)=VE(Y,j)/varp; else VE(Y,j)=VE(Y,j)/0.001; } VE(Y,j)=pow(weights[j],0.5)*VE(Y,j); prede=(VE(Y,j)); if (it==(*Nit-1)) ssf[0]+=pow(prede,2); } // j=0;j0.5) && (it==(*Nit-1))) ) { Rprintf("missing values in SCORE or lacking convergence %ld \n",(long int) s); convproblems=1; convt=0; silent[s]=2; it=*Nit-1; for (c=0;c0) convc[0]=1; if (*semi==0) { free_mats(&wX,&censX,&VAR,&X,&cX,&A,&AI,NULL); if (*trans==2) {free_mats(&Z,NULL); free_vecs(&zgam,&gam,&zi,&rowZ,NULL);} free_vecs(&censXv,&rr,&bhatub,&risk,&W,&Y,&Gc,&CAUSE,&bhat,&pbhat,NULL); free_vecs(&vcumentry,&bet1,&xi,&rowX,NULL); free_vecs(&dp,&dp1,&dp2,&dcovs,&pcovs,&betaub,&VdB,&qs,&SCORE,&beta,&difbeta,NULL); for (i=0;i<*antclust;i++) {free_vec(cumhatA[i]); free_vec(cumA[i]); free_mat(cumAt[i]);} } free(vcudif); free(cumentry); free(cifentry); } // }}} void itfitsemi(double *times,int *Ntimes,double *x,int *censcode,int *cause, double *KMc,double *z,int *antpers,int *px,int *Nit, double *score,double *hess,double *est,double *var,int *sim, int *antsim,int *rani,double *test,double *testOBS,double *Ut, double *simUt,int *weighted,double *gamma,double *vargamma,int *semi, double *zsem,int *pg,int *trans,double *gamma2,int *CA, int *line,int *detail,double *biid,double *gamiid,int *resample, double *timepow,int *clusters,int *antclust,double *timepowtest,int *silent,double *convc,double *weights,double *entry,double *trunkp, int *estimator,int *fixgamma,int *stratum,int *ordertime,int *conservative,double *ssf,double *KMtimes, double *gamscore,double *Dscore,int *monotone) { // {{{ // {{{ allocation and reading of data from R matrix *ldesignX,*A,*AI,*cdesignX,*ldesignG,*cdesignG,*censX,*censZ; matrix *wX,*wZ; matrix *S,*dCGam,*CGam,*ICGam,*VarKorG,*dC,*XZ,*ZZ,*ZZI,*XZAI; matrix *Ct,*C[*Ntimes],*Acorb[*Ntimes],*tmpM2,*tmpM3,*tmpM4; matrix *Vargam,*dVargam,*M1M2[*Ntimes],*Delta,*dM1M2,*M1M2t,*RobVargam; matrix *W3t[*antclust],*W4t[*antclust]; // matrix *W3tcens[*antclust],*W4tcens[*antclust]; vector *W2[*antclust],*W3[*antclust]; // vector *W2cens[*antclust],*W3cens[*antclust]; vector *dB,*dN,*VdB,*AIXdN,*AIXlamt,*bhatt,*truncbhatt,*pbhat,*plamt,*ciftrunk; vector *korG,*pghat,*rowG,*gam,*dgam,*ZGdN,*IZGdN,*ZGlamt,*IZGlamt,*censZv,*censXv; vector *qs,*Y,*rr,*bhatub,*xi,*xit,*zit,*rowX,*rowZ,*difX,*zi,*z1,*tmpv1,*tmpv2,*lrisk; vector *dpx,*dpz,*dpx1,*dpz1; int sing,itt,i,j,k,l,s,c,pmax,totrisk,convproblems=0,nagam=0, *n= calloc(1,sizeof(int)), *nx= calloc(1,sizeof(int)), *px1= calloc(1,sizeof(int)); int left=0,clusterj,fixedcov,osilent,*strict=calloc(2,sizeof(int)),*indexleft=calloc((*antpers),sizeof(int)); double nrisk,time,dummy,dtime,phattrunc,bhattrunc=0,lrr,lrrt; double *vcudif=calloc((*Ntimes)*(*px+1),sizeof(double)), *inc=calloc((*Ntimes)*(*px+1),sizeof(double)), *weightt=calloc((*Ntimes),sizeof(double)), *cifentry=calloc((*antpers),sizeof(double)), *cumentry=calloc((*antpers)*(*px+1),sizeof(double)); osilent=silent[0]; silent[0]=0; strict[0]=1; // float gasdev(),expdev(),ran1(); robust[0]=1; fixedcov=1; n[0]=antpers[0]; nx[0]=antpers[0]; double step=ssf[0]; for (j=0;j<*antclust;j++) { malloc_mat(*Ntimes,*px,W3t[j]); malloc_mat(*Ntimes,*px,W4t[j]); malloc_vec(*pg,W2[j]); malloc_vec(*px,W3[j]); } for (j=0;j<*Ntimes;j++) { malloc_mat(*pg,*px,Acorb[j]); malloc_mat(*px,*pg,C[j]); malloc_mat(*px,*pg,M1M2[j]); } malloc_mats(*antpers,*px,&wX,&censX,&ldesignX,&cdesignX,NULL); malloc_mats(*antpers,*pg,&wZ,&censZ,&ldesignG,&cdesignG,NULL); malloc_mats(*px,*px,&A,&AI,NULL); malloc_mats(*pg,*pg,&dVargam,&Vargam,&RobVargam,&tmpM2,&ZZ,&VarKorG,&ICGam,&CGam,&dCGam,&S,&ZZI,NULL); malloc_mats(*px,*pg,&XZAI,&tmpM3,&Ct,&dC,&XZ,&dM1M2,&M1M2t,NULL); malloc_mat(*px,*pg,tmpM4); malloc_mat(*Ntimes,*px,Delta); malloc_vecs(*px,&dpx1,&dpx,&censXv, &xit, &xi, &rowX, &difX, &tmpv1, &korG, &dB, &VdB, &AIXdN, &AIXlamt, &truncbhatt,&bhatt,NULL); malloc_vecs(*pg,&dpz1,&dpz,&censZv, &zit, &zi, &rowZ, &tmpv2,&z1,&rowG,&gam,&dgam, &ZGdN,&IZGdN,&ZGlamt,&IZGlamt,NULL); malloc_vecs(*antpers,&Y,&bhatub,&rr,&lrisk,&dN,&pbhat,&pghat,&plamt,&ciftrunk,NULL); malloc_vec((*px)+(*pg),qs); for (s=0;s<*Ntimes;s++) weightt[s]=1; if (*px>=*pg) pmax=*px; else pmax=*pg; // starting values for (j=0;j<*pg;j++) VE(gam,j)=gamma[j]; px1[0]=*px+1; for (c=0;c<*antpers;c++) if (trunkp[c]<1) {left=1; break;} for(j=0;j<*antpers;j++) for(i=0;i<=*px;i++) cumentry[i*(*antpers)+j]=0; // }}} if (fixedcov==1) // {{{ for (c=0;c<*antpers;c++) for(j=0;j=time); totrisk=totrisk+VE(lrisk,j); extract_row(ldesignX,j,xi); extract_row(ldesignG,j,zi); if (*estimator==2 && *monotone==1) { for(k=0;k0)) { for(i=1;i<=*px;i++) VE(truncbhatt,i-1)=cumentry[i*(*n)+j]; for (l=0;l<*pg;l++) { VE(zit,l)=pow(entry[j],timepow[l])*VE(zi,l); lrrt=lrrt+VE(gam,l)*VE(zit,l); } bhattrunc=vec_prod(xi,truncbhatt); phattrunc=1-exp(-exp(bhattrunc)*exp(lrrt)); } else phattrunc=0; for (l=0;l<*pg;l++) VE(zi,l)=pow(time,timepow[l])*VE(zi,l); if ((entry[j]>0)) { scl_vec_mult((1-phattrunc)*exp(bhattrunc)*exp(lrrt)/trunkp[j],xi,xit); scl_vec_mult((1-phattrunc)*exp(bhattrunc)*exp(lrrt)/trunkp[j],zit,zit); } scl_vec_mult((1-VE(plamt,j))*exp(VE(pbhat,j))*VE(rr,j)/trunkp[j],xi,dpx); scl_vec_mult((1-VE(plamt,j))*exp(VE(pbhat,j))*VE(rr,j)/trunkp[j],zi,dpz); if (entry[j]<1) { vec_subtr(dpx,xit,dpx); vec_subtr(dpz,zit,dpz); VE(plamt,j)=(VE(plamt,j)-phattrunc)/trunkp[j]; } } // }}} if (*trans==6) { // FG-parametrization model="fg" // {{{ for (l=0;l<*pg;l++) { lrr=lrr+VE(gam,l)*VE(zi,l)*pow(time,timepow[l]); VE(zi,l)= pow(time,timepow[l])*VE(zi,l); } VE(rr,j)=exp(lrr); VE(plamt,j)=1-exp(-VE(pbhat,j)*VE(rr,j)); // varp=VE(plamt,j)*(1-VE(plamt,j)); scl_vec_mult((1-VE(plamt,j))*VE(rr,j),xi,dpx); scl_vec_mult((1-VE(plamt,j))*VE(pbhat,j)*VE(rr,j),zi,dpz); if ((entry[j]>0)) { // {{{ for(i=1;i<=*px;i++) VE(truncbhatt,i-1)=cumentry[i*(*n)+j]; extract_row(ldesignG,j,zit); extract_row(ldesignX,j,xit); for (l=0;l<*pg;l++) { VE(zit,l)=pow(entry[j],timepow[l])*VE(zit,l); lrrt=lrrt+VE(gam,l)*VE(zit,l); } bhattrunc=vec_prod(xit,truncbhatt); phattrunc=1-exp(-bhattrunc*exp(lrrt)); if (*monotone==0) { scl_vec_mult((1-phattrunc)*exp(lrrt),xit,xit); scl_vec_mult((1-phattrunc)*bhattrunc*exp(lrrt),zit,zit); vec_subtr(dpx,xit,dpx); vec_subtr(dpz,zit,dpz); scl_vec_mult(1/trunkp[j],dpx,dpx); scl_vec_mult(1/trunkp[j],dpz,dpz); } VE(plamt,j)=(VE(plamt,j)-phattrunc)/trunkp[j]; } // }}} } // }}} if (*trans==3) { // logistic // {{{ for (l=0;l<*pg;l++) { lrr=lrr+VE(gam,l)*VE(zi,l)*pow(time,timepow[l]); VE(zi,l)= pow(time,timepow[l])*VE(zi,l); } VE(rr,j)=exp(lrr); VE(plamt,j)=exp(VE(pbhat,j)+lrr)/(1+exp(VE(pbhat,j)+lrr)); // varp=VE(plamt,j)*(1-VE(plamt,j)); dummy=VE(plamt,j)/(1+exp(VE(pbhat,j)+lrr)); scl_vec_mult(dummy,xi,dpx); scl_vec_mult(dummy,zi,dpz); if ((trunkp[j]<1)) { extract_row(ldesignG,j,zit); extract_row(ldesignX,j,xit); for(i=1;i<=*px;i++) VE(truncbhatt,i-1)=cumentry[i*(*antpers)+j]; bhattrunc=vec_prod(xit,truncbhatt); for (l=0;l<*pg;l++) { VE(zit,l)=pow(entry[j],timepow[l])*VE(zit,l); lrrt=lrrt+VE(gam,l)*VE(zit,l); } phattrunc= exp(bhattrunc+lrrt)/(1+exp(bhattrunc+lrrt)); dummy= phattrunc/(1+exp(bhattrunc+lrrt)); scl_vec_mult(dummy,xit,xit); scl_vec_mult(dummy,zit,zit); vec_subtr(dpx,xit,dpx); vec_subtr(dpz,zit,dpz); scl_vec_mult(1/trunkp[j],dpx,dpx); scl_vec_mult(1/trunkp[j],dpz,dpz); VE(plamt,j)=(VE(plamt,j)-phattrunc)/trunkp[j]; } } // }}} if (*trans==7) { // logistic, baseline direct parametrization // {{{ for (l=0;l<*pg;l++) { VE(zi,l)= pow(time,timepow[l])*VE(zi,l); lrr=lrr+VE(gam,l)*VE(zi,l); } VE(rr,j)=exp(lrr); VE(plamt,j)=VE(pbhat,j)*exp(lrr)/(1+VE(pbhat,j)*exp(lrr)); // varp=VE(plamt,j)*(1-VE(plamt,j)); dummy=exp(lrr)/pow(1+VE(pbhat,j)*exp(lrr),2); scl_vec_mult(dummy,xi,dpx); scl_vec_mult(VE(pbhat,j)*dummy,zi,dpz); if ((trunkp[j]<1)) { extract_row(ldesignG,j,zit); extract_row(ldesignX,j,xit); for(i=1;i<=*px;i++) VE(truncbhatt,i-1)=cumentry[i*(*antpers)+j]; bhattrunc=vec_prod(xit,truncbhatt); for (l=0;l<*pg;l++) { VE(zit,l)=pow(entry[j],timepow[l])*VE(zit,l); lrrt=lrrt+VE(gam,l)*VE(zit,l); } phattrunc= bhattrunc*exp(lrrt)/(1+bhattrunc*exp(lrrt)); dummy=exp(lrrt)/pow(1+bhattrunc*exp(lrrt),2); scl_vec_mult(dummy,xit,xit); scl_vec_mult(bhattrunc*dummy,zit,zit); vec_subtr(dpx,xit,dpx); vec_subtr(dpz,zit,dpz); scl_vec_mult(1/trunkp[j],dpx,dpx); scl_vec_mult(1/trunkp[j],dpz,dpz); VE(plamt,j)=(VE(plamt,j)-phattrunc)/trunkp[j]; } } // }}} if (*trans==4) { // relative risk // {{{ for (l=0;l<*pg;l++) { VE(zi,l)= pow(time,timepow[l])*VE(zi,l); lrr=lrr+VE(gam,l)*VE(zi,l); } VE(rr,j)=lrr; VE(plamt,j)=exp(VE(pbhat,j)+lrr); // varp=VE(plamt,j)*(1-VE(plamt,j)); scl_vec_mult(VE(plamt,j),xi,dpx); scl_vec_mult(VE(plamt,j),zi,dpz); if ((trunkp[j]<1)) { /*{{{*/ extract_row(ldesignG,j,zit); extract_row(ldesignX,j,xit); for(i=1;i<=*px;i++) VE(truncbhatt,i-1)=cumentry[i*(*antpers)+j]; for (l=0;l<*pg;l++) { VE(zit,l)=pow(entry[j],timepow[l])*VE(zi,l); lrrt=lrrt+VE(gam,l)*VE(zit,l); } phattrunc= exp(vec_prod(xit,truncbhatt)+exp(lrrt)); scl_vec_mult(phattrunc,xit,xit); scl_vec_mult(phattrunc,zit,zit); vec_subtr(dpx,xit,dpx); vec_subtr(dpz,zit,dpz); scl_vec_mult(1/trunkp[j],dpx,dpx); scl_vec_mult(1/trunkp[j],dpz,dpz); VE(plamt,j)=(VE(plamt,j)-phattrunc)/trunkp[j]; } /*}}}*/ } // }}} if (*trans==5) { // relative risk, param 2 // {{{ for (l=0;l<*pg;l++) { VE(zi,l)= pow(time,timepow[l])*VE(zi,l); lrr=lrr+VE(gam,l)*VE(zi,l); // *pow(time,timepow[l]); } VE(rr,j)=lrr; VE(plamt,j)=VE(pbhat,j)*exp(lrr); // varp=VE(plamt,j)*(1-VE(plamt,j)); scl_vec_mult(exp(lrr),xi,dpx); scl_vec_mult(VE(plamt,j),zi,dpz); if ((trunkp[j]<1)) { /*{{{*/ extract_row(ldesignG,j,zit); extract_row(ldesignX,j,xit); for(i=1;i<=*px;i++) VE(truncbhatt,i-1)=cumentry[i*(*antpers)+j]; for (l=0;l<*pg;l++) { VE(zit,l)= pow(entry[j],timepow[l])*VE(zit,l); lrrt=lrrt+VE(gam,l)*VE(zit,l); } phattrunc= vec_prod(xit,truncbhatt)*exp(exp(lrrt)); scl_vec_mult(exp(lrrt),xit,xit); scl_vec_mult(phattrunc,zit,zit); vec_subtr(dpx,xit,dpx); vec_subtr(dpz,zit,dpz); scl_vec_mult(1/trunkp[j],dpx,dpx); scl_vec_mult(1/trunkp[j],dpz,dpz); VE(plamt,j)=(VE(plamt,j)-phattrunc)/trunkp[j]; }/*}}}*/ } // }}} if (*trans==8) { // log-relative risk, // {{{ for (l=0;l<*pg;l++) { VE(zi,l)= pow(time,timepow[l])*VE(zi,l); lrr=lrr+VE(gam,l)*VE(zi,l); // *pow(time,timepow[l]); } VE(rr,j)=lrr; VE(plamt,j)=VE(pbhat,j)*exp(exp(lrr)); // varp=VE(plamt,j)*(1-VE(plamt,j)); scl_vec_mult(exp(exp(lrr)),xi,xi); scl_vec_mult(VE(plamt,j)*exp(lrr),zi,zi); if ((trunkp[j]<1)) { extract_row(ldesignG,j,zit); extract_row(ldesignX,j,xit); for(i=1;i<=*px;i++) VE(truncbhatt,i-1)=cumentry[i*(*antpers)+j]; for (l=0;l<*pg;l++) { VE(zit,l)= pow(entry[j],timepow[l])*VE(zit,l); lrrt=lrrt+VE(gam,l)*VE(zit,l); } phattrunc= vec_prod(xit,truncbhatt)*exp(exp(lrrt)); scl_vec_mult(exp(exp(lrrt)),xit,xit); scl_vec_mult(phattrunc*exp(lrr),zit,zit); vec_subtr(dpx,xit,dpx); vec_subtr(dpz,zit,dpz); scl_vec_mult(1/trunkp[j],dpx,dpx); scl_vec_mult(1/trunkp[j],dpz,dpz); VE(plamt,j)=(VE(plamt,j)-phattrunc)/trunkp[j]; } // }}} } // }}} scl_vec_mult(1,dpx,dpx1); scl_vec_mult(1,dpz,dpz1); VE(Y,j)=((x[j]<=time) & (cause[j]==*CA))*1; if ((itt==(*Nit-1)) && (*conservative==0)) { // {{{ for censoring distribution correction if (*monotone==1) { scl_vec_mult(1,xi,dpx1); scl_vec_mult(1,zi,dpz1); } if (KMc[j]>0.001) scl_vec_mult(weights[j]*VE(Y,j)/KMc[j],dpx1,rowX); else scl_vec_mult(weights[j]*VE(Y,j)/0.001,dpx1,rowX); vec_add(censXv,rowX,censXv); replace_row(censX,j,rowX); if (KMc[j]>0.001) scl_vec_mult(weights[j]*VE(Y,j)/KMc[j],dpz1,rowZ); else scl_vec_mult(weights[j]*VE(Y,j)/0.001,dpz1,rowZ); vec_add(censZv,rowZ,censZv); replace_row(censZ,j,rowZ); } // }}} if (*estimator==4) { // if (varp>0.01 && itt>2) svarp=1/pow(varp,0.5); else svarp=1/pow(0.01,0.5); } if (*estimator==1) scl_vec_mult(pow(weights[j],0.5)*(time>entry[j]),dpx,dpx); else scl_vec_mult(pow(weights[j]*KMtimes[s]/KMc[j],0.5)*(time>entry[j]),dpx,dpx); if (*estimator==1) scl_vec_mult(pow(weights[j],0.5)*(time>entry[j]),dpz,dpz); else scl_vec_mult(pow(weights[j]*KMtimes[s]/KMc[j],0.5)*(time>entry[j]),dpz,dpz); replace_row(cdesignX,j,dpx); replace_row(cdesignG,j,dpz); if (*estimator==1 ) { if (KMc[j]<0.001) VE(Y,j)=((VE(Y,j)/0.001)-VE(plamt,j))*(time>entry[j]); else VE(Y,j)=((VE(Y,j)/KMc[j])-VE(plamt,j))*(time>entry[j]); } else if (*estimator==2) VE(Y,j)=(VE(Y,j)-VE(plamt,j)); else if (*estimator==5) if (x[j]0.5 && (itt==(*Nit-2))) silent[s]=2; // lacking convergence for this time if (itt==(*Nit-1)) // {{{ for (i=0;i<*antpers;i++) { // vec_zeros(tmpv1); vec_zeros(z1); j=clusters[i]; if (*monotone==0) extract_row(cdesignX,i,xi); if (*monotone==1) extract_row(wX,i,xi); scl_vec_mult(VE(Y,i),xi,xi); Mv(AI,xi,rowX); for (l=0;l<*px;l++) ME(W3t[j],s,l)+=VE(rowX,l); if (*fixgamma==0) { // {{{ if (*monotone==0) extract_row(cdesignG,i,zi); if (*monotone==1) extract_row(wZ,i,zi); scl_vec_mult(VE(Y,i),zi,zi); vM(C[s],rowX,tmpv2); vec_subtr(zi,tmpv2,rowZ); vec_add(rowZ,W2[j],W2[j]); } // }}} if (*conservative==0) { // {{{ censoring terms k=ordertime[i]; nrisk=(*antpers)-i; clusterj=clusters[k]; if (cause[k]==(*censcode)) { Mv(AI,censXv,rowX); for (l=0;l<*px;l++) ME(W3t[clusterj],s,l)+=VE(rowX,l)/nrisk; if (*fixgamma==0) { vM(C[s],rowX,tmpv2); vec_subtr(censZv,tmpv2,rowZ); // scl_vec_mult(dtime,rowZ,rowZ); for (l=0;l<*pg;l++) VE(W2[clusterj],l)+=VE(rowZ,l)/nrisk; } for (j=i;j<*antpers;j++) { clusterj=clusters[ordertime[j]]; for (l=0;l<*px;l++) ME(W3t[clusterj],s,l)-=VE(rowX,l)/pow(nrisk,2); if (*fixgamma==0) { for (l=0;l<*pg;l++) VE(W2[clusterj],l)-=VE(rowZ,l)/pow(nrisk,2); } } } // fewer where I(s <= T_i) , because s is increasing extract_row(censX,k,xi); vec_subtr(censXv,xi,censXv); extract_row(censZ,k,zi); vec_subtr(censZv,zi,censZv); } // conservative==0 }}} } // if (itt==(*Nit-1)) for (i=0;i<*antpers;i++) // }}} } // sing=0 if (*detail==1) { Rprintf("it %d, timepoint s %d, Estimate beta \n",itt,s); print_vec(bhatt); Rprintf("Information -D^2 l\n"); print_mat(AI); } } /* s=1,...Ntimes */ dummy=0; if (*fixgamma==0) { for (k=0;k<*pg;k++) dummy=dummy+fabs(VE(dgam,k)); invertS(CGam,ICGam,osilent); Mv(ICGam,IZGdN,dgam); if (isnan(vec_sum(dgam))) { if (convproblems==1) convproblems=3; else convproblems=2; if (osilent==0) print_mat(ICGam); if (osilent==0 && (nagam==0)) Rprintf("Missing values in gamma increment, omitted \n"); vec_zeros(dgam); nagam=1; } if (itt<(*Nit-1)) { scl_vec_mult(step,dgam,dgam); vec_add(gam,dgam,gam); } } // do not update estimates for last itteration if (itt<(*Nit-1)) for (s=0;s<*Ntimes;s++) { if (*fixgamma==0) vM(Acorb[s],dgam,korG); est[s]=times[s]; var[s]=times[s]; for (k=1;k<=*px;k++) { est[k*(*Ntimes)+s]=est[k*(*Ntimes)+s]+inc[k*(*Ntimes)+s]-VE(korG,k-1); dummy=dummy+fabs(inc[k*(*Ntimes)+s]-VE(korG,k-1)); } } /* s=1,...Ntimes */ if (dummy<*convc && itt<*Nit-2) itt=*Nit-2; if (*detail==1) { Rprintf(" iteration %d %d \n",itt,*Nit); Rprintf("Total sum of squares %lf \n",ssf[0]); Rprintf("Total sum of changes %lf \n",dummy); Rprintf("Gamma parameters \n"); print_vec(gam); Rprintf("Change in Gamma \n"); print_vec(dgam); Rprintf("===========================================================\n"); } // score for gamma part of model if (itt==(*Nit-1)) for (k=0;k<*pg;k++) gamscore[k]= VE(dgam,k); } /*itt lokke */ // }}} //head_matrix(cdesignX); head_matrix(wX); R_CheckUserInterrupt(); /* ROBUST VARIANCES */ vec_zeros(rowX); for (s=0;s<*Ntimes;s++) { // {{{ robust variances vec_zeros(VdB); for (i=0;i<*antclust;i++) { if (*fixgamma==0) { Mv(ICGam,W2[i],tmpv2); vM(Acorb[s],tmpv2,rowX); } extract_row(W3t[i],s,tmpv1); vec_subtr(tmpv1,rowX,difX); replace_row(W4t[i],s,difX); vec_star(difX,difX,tmpv1); vec_add(tmpv1,VdB,VdB); if (*resample==1) { if ((s==0) & (*fixgamma==0)) for (c=0;c<*pg;c++) gamiid[c*(*antclust)+i]=gamiid[c*(*antclust)+i]+VE(tmpv2,c); for (c=0;c<*px;c++) {l=i*(*px)+c; biid[l*(*Ntimes)+s]=biid[l*(*Ntimes)+s]+VE(difX,c);} } if (*fixgamma==0) if (s==0) { for (j=0;j<*pg;j++) for (k=0;k<*pg;k++) ME(RobVargam,j,k)=ME(RobVargam,j,k)+VE(tmpv2,j)*VE(tmpv2,k);} } /* for (i=0;i<*antclust;i++) */ for (k=1;k<*px+1;k++) var[k*(*Ntimes)+s]=VE(VdB,k-1); } /* s=0..Ntimes*/ // }}} /* MxA(RobVargam,ICGam,tmpM2); MxA(ICGam,tmpM2,RobVargam);*/ /* print_mat(RobVargam); */ if (*fixgamma==0) { for (j=0;j<*pg;j++) {gamma[j]=VE(gam,j); for (k=0;k<*pg;k++) { vargamma[k*(*pg)+j]=ME(RobVargam,j,k); Dscore[k*(*pg)+j]=ME(ICGam,j,k); } } } if (convproblems>=1) convc[0]=convproblems; R_CheckUserInterrupt(); if (*sim==1) { comptestfunc(times,Ntimes,px,est,var,vcudif,antsim,test,testOBS,Ut,simUt,W4t,weighted,antclust,gamma2,line,timepowtest); } // {{{ freeing free_mats(&wX,&wZ,&censX,&censZ,&ldesignX,&A,&AI,&cdesignX,&ldesignG,&cdesignG, &S,&dCGam,&CGam,&ICGam,&VarKorG,&dC,&XZ,&ZZ,&ZZI,&XZAI, &Ct,&tmpM2,&tmpM3,&tmpM4,&Vargam,&dVargam, &Delta,&dM1M2,&M1M2t,&RobVargam,NULL); free_vecs(&dpx1,&dpz1,&dpx,&dpz,&censXv,&censZv,&qs,&Y,&rr,&bhatub,&dB,&dN,&VdB,&AIXdN,&AIXlamt, &bhatt,&pbhat,&plamt,&korG,&pghat,&rowG,&gam,&dgam,&ZGdN,&IZGdN, &ZGlamt,&IZGlamt,&xit,&xi,&rowX,&rowZ,&difX,&zit,&zi,&z1,&tmpv1,&tmpv2,&lrisk,&ciftrunk,&truncbhatt, NULL); for (j=0;j<*Ntimes;j++) {free_mat(Acorb[j]);free_mat(C[j]);free_mat(M1M2[j]);} for (j=0;j<*antclust;j++) {free_mat(W3t[j]); free_mat(W4t[j]); free_vec(W2[j]); free_vec(W3[j]); } free(n); free(nx); free(px1); free(strict); free(indexleft); free(vcudif); free(inc); free(weightt); free(cifentry); free(cumentry); // }}} } // }}} double mypow(double x,double p) { double val; val=exp(log(x)*p); return(val); } timereg/src/timecox.c0000644000176200001440000003553514421510301014313 0ustar liggesusers//#include #include #include "matrix.h" void OStimecox(double *times,int *Ntimes,double *designX,int *nx,int *p,int *antpers, double *start,double *stop,int *nb,double *bhat,double *cu,double *vcu, int *it,double *b,int *degree,int *id,int *status,int *sim, int *antsim,double *cumAit,double *test,int *rani,double *testOBS,double *Ut, double *simUt,double *robvcu,int *retur,int *weighted,double *cumAiid,int *robust, int *covariance,double *covs) //double *designX,*times,*start,*stop,*cu,*vcu,*bhat,*b, //*cumAit,*test,*testOBS,*Ut,*simUt,*robvcu,*cumAiid,*covs; //int *nx,*p,*antpers,*Ntimes,*nb,*it,*degree,*id,*status,*sim,*antsim,*rani,*retur,*weighted,*robust,*covariance; { // {{{ matrix *Vcov,*ldesignX,*A,*AI,*cdesignX; matrix *cumAt[*antpers]; vector *difX,*rowX,*xi,*vtmp,*vtmp1,*diag,*dB,*dN,*dM,*VdB,*AIXdM,*AIXdN,*AIXlamt,*ta,*bhatt,*pbhat,*plamt,*lrisk,*score; vector *cumhatA[*antpers],*cumA[*antpers],*cum,*dN1; int i,j,k,l,s,c,count,pers=0,itt,silent=1, *coef=calloc(1,sizeof(int)), *ps=calloc(1,sizeof(int)), *imin=calloc(1,sizeof(int));; double ahati,time,dummy,dtime; double *vcudif=calloc((*Ntimes)*(*p+1),sizeof(double)), *sbhat=calloc((*Ntimes)*(*p+1),sizeof(double)), *sscore=calloc((*Ntimes)*(*p+1),sizeof(double)); // printf(" %d %d \n",*Ntimes,*p+1); malloc_mats(*antpers,*p,&ldesignX,&cdesignX,NULL); malloc_mats(*p,*p,&Vcov,&A,&AI,NULL); malloc_vecs(*p,&vtmp,&VdB,&rowX,&difX,&cum,&xi,&vtmp1,&diag,&dB,&AIXdM,&AIXdN,&AIXlamt,&bhatt,&score,NULL); malloc_vecs(*antpers,&dN1,&dN,&pbhat,&plamt,&lrisk,&dM,NULL); malloc_vecs(*nb,&ta,NULL); if (*robust==1) for (i=0;i<*antpers;i++) {malloc_vec(*p,cumhatA[i]); malloc_vec(*p,cumA[i]); malloc_mat(*Ntimes,*p,cumAt[i]); } // printf(" %d %d \n",*nx,*antpers); coef[0]=1; ps[0]=*p+1; for (itt=0;itt<*it;itt++) { vec_zeros(score); for (s=1;s<*Ntimes;s++) { time=times[s]; dtime=time-times[s-1]; mat_zeros(ldesignX); vec_zeros(lrisk); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { VE(lrisk,id[c])=1; for(j=0;j<*p;j++) ME(ldesignX,id[c],j)=designX[j*(*nx)+c]; if (time==stop[c] && status[c]==1) { pers=id[c];} count=count+1; } } for(j=0;j<*nb;j++) VE(ta,j)=fabs(bhat[j]-time); dummy=vec_min(ta,imin); for(j=1;j<=*p;j++) VE(bhatt,j-1)=bhat[j*(*nb)+(*imin)]; Mv(ldesignX,bhatt,pbhat); for (j=0;j<*antpers;j++) { VE(plamt,j)=VE(lrisk,j)*exp(VE(pbhat,j)); extract_row(ldesignX,j,dB); scl_vec_mult(VE(plamt,j),dB,dB); replace_row(cdesignX,j,dB); /* sampling corrected design */ } MtA(cdesignX,ldesignX,A); invertS(A,AI,silent); if (ME(AI,0,0)==0) Rprintf(" X'X not invertible at time %lf \n",time); extract_row(ldesignX,pers,xi); Mv(AI,xi,AIXdN); vM(ldesignX,plamt,vtmp1); Mv(AI,vtmp1,AIXlamt); scl_vec_mult(dtime,AIXlamt,AIXlamt); vec_subtr(AIXdN,AIXlamt,AIXdM); extract_row(ldesignX,pers,xi); scl_vec_mult(dtime,vtmp1,vtmp1); vec_subtr(xi,vtmp1,vtmp1); vec_add(vtmp1,score,score); for (k=1;k<=*p;k++) sscore[k*(*Ntimes)+s]=VE(score,k-1); sscore[s]=time; cu[s]=time; vcu[s]=time; robvcu[s]=time; sbhat[s]=time; if (itt==0) for (k=1;k<=*p;k++) sbhat[k*(*Ntimes)+s-1]=bhat[k*(*Ntimes)+s-1]; for (k=1;k<=*p;k++) { cu[k*(*Ntimes)+s]=cu[k*(*Ntimes)+(s-1)]+dtime*VE(bhatt,k-1)+VE(AIXdM,k-1); sbhat[k*(*Ntimes)+s-1]=bhat[k*(*Ntimes)+s-1]+VE(AIXdM,k-1); /* ssscore[s]=time; Rprintf(" %lf %lf ",sbhat[k*(*Ntimes)+s-1]-bhat[k*(*Ntimes)+s-1], ssscore[k*(*Ntimes)+s-1]); Rprintf("\n"); */ vcu[k*(*Ntimes)+s]=vcu[k*(*Ntimes)+(s-1)]+dtime*ME(AI,k-1,k-1);} if (itt==(*it-1)) { if (*robust==1) { // {{{ vec_zeros(VdB); for (i=0;i<*antpers;i++) { extract_row(ldesignX,i,xi); Mv(AI,xi,rowX); ahati=VE(plamt,i)*dtime; vec_star(xi,AIXdM,vtmp1); dummy=vec_sum(vtmp1); if (i==pers) vec_add(rowX,cumhatA[i],cumhatA[i]); scl_vec_mult(ahati,rowX,rowX); vec_add(rowX,cumA[i],cumA[i]); vec_subtr(cumhatA[i],cumA[i],difX); replace_row(cumAt[i],s,difX); vec_star(difX,difX,vtmp); vec_add(vtmp,VdB,VdB); if (*covariance==1) { for (k=0;k<*p;k++) for (j=0;j<*p;j++) ME(Vcov,k,j)=ME(Vcov,k,j)+VE(difX,k)*VE(difX,j);} if (*retur==1) { cumAit[i*(*Ntimes)+s]=1*(i==pers)-ahati; cumAiid[i*(*Ntimes)+s]=cumAit[i*(*Ntimes)+s]-VE(plamt,i)*dummy; /* VE(dN,i)=cumAiid[i*(*Ntimes)+s]; VE(dM,i)=cumAit[i*(*Ntimes)+s]; */ cumAit[i*(*Ntimes)+s]=cumAiid[i*(*Ntimes)+s]; } } for (k=1;k<*p+1;k++){robvcu[k*(*Ntimes)+s]=VE(VdB,k-1); if (*covariance==1) { for (j=0;j<*p;j++) { l=(k-1)*(*p)+j; covs[l*(*Ntimes)+s]=ME(Vcov,k-1,j); }} } } // }}} } } /* s =1,...,*Ntimes */ /* print_vec(score); */ smoothB(cu,Ntimes,ps,bhat,nb,b,degree,coef); } /* itterations lokke */ cu[0]=times[0]; vcu[0]=times[0]; if (*sim==1) { comptest(times,Ntimes,p,cu,robvcu,vcudif,antsim,test,testOBS,Ut,simUt,cumAt,weighted,antpers); } if (*robust==1) for (i=0;i<*antpers;i++) {free_mat(cumAt[i]);free_vec(cumA[i]);free_vec(cumhatA[i]);} free_mats(&Vcov,&ldesignX,&A,&AI,&cdesignX,NULL); free_vecs(&vtmp,&VdB,&rowX,&difX,&cum,&xi,&vtmp1,&diag,&dB,&AIXdM,&AIXdN,&AIXlamt,&bhatt, &score,&dN1,&dN,&pbhat,&plamt,&lrisk,&dM,&ta,NULL); free(coef); free(ps); free(imin); free(vcudif); free(sbhat); free(sscore); } // }}} void OSsemicox(double *times,int *Ntimes,double *designX,int *nx,int *px,double *designG,int *ng,int *pg, int *antpers,double *start,double *stop,int *nb,double *bhat,double *cu,double *vcu,double *gamma,double *Vgamma,double *b,int *degree,int *it, double *RobVgamma,double *robvcu,int *sim,int *antsim,int *retur,double *cumAit,double *test,int *rani,double *testOBS,int *status,double *Ut,double *simUt,int *id,int *weighted,int *robust,int *covariance,double *covs) //double *designX,*times,*start,*stop,*cu,*vcu,*bhat,*b,*designG, //*gamma,*Vgamma,*RobVgamma,*cumAit,*test,*testOBS,*Ut,*simUt,*robvcu,*covs; //int //*nx,*px,*antpers,*Ntimes,*nb,*ng,*pg,*it,*degree,*id,*status,*sim,*antsim,*retur,*rani,*weighted,*robust,*covariance; { // {{{ matrix *ldesignX,*A,*AI,*cdesignX,*ldesignG,*cdesignG; matrix *S,*dCGam,*CGam,*ICGam,*VarKorG,*dC,*XZ,*ZZ,*ZZI,*XZAI; matrix *Ct,*C[*Ntimes],*Acorb[*Ntimes],*Vcov; matrix *tmpM2,*tmpM3,*tmpM4; matrix *Vargam,*dVargam,*M1M2[*Ntimes]; matrix *dM1M2,*M1M2t,*RobVargam; matrix *W3t[*antpers],*W4t[*antpers],*AIxit[*antpers]; vector *W2[*antpers],*W3[*antpers]; vector *diag,*dB,*dN,*VdB,*AIXdN,*AIXlamt,*ta,*bhatt,*pbhat,*plamt; vector *korG,*pghat,*rowG,*gam,*dgam,*ZGdN,*IZGdN,*ZGlamt,*IZGlamt; vector *xi,*rowX,*rowZ,*difX,*zi,*z1,*tmpv1,*tmpv2,*lrisk; int itt,i,j,k,l,s,c,count,pers=0,pmax,silent=1, *coef=calloc(1,sizeof(int)),*ps=calloc(1,sizeof(int)), *imin=calloc(1,sizeof(int));; double time,dtime,hati; double *vcudif=calloc((*Ntimes)*(*px+1),sizeof(double)); int *ipers=calloc(*Ntimes,sizeof(int)); if (*robust==1) for (j=0;j<*antpers;j++) { malloc_mat(*Ntimes,*px,W3t[j]); malloc_mat(*Ntimes,*px,W4t[j]); malloc_vec(*pg,W2[j]); malloc_vec(*px,W3[j]); malloc_mat(*Ntimes,*px,AIxit[j]); } for (j=0;j<*Ntimes;j++) { malloc_mat(*pg,*px,Acorb[j]); malloc_mat(*px,*pg,C[j]); malloc_mat(*px,*pg,M1M2[j]);} malloc_mats(*antpers,*px,&ldesignX,&cdesignX,NULL); malloc_mats(*antpers,*pg,&ldesignG,&cdesignG,NULL); malloc_mats(*px,*px,&VarKorG,&Vcov,&A,&AI,NULL); malloc_mats(*pg,*pg,&dVargam,&Vargam,&RobVargam,&tmpM2,&ZZ,&ICGam,&CGam,&dCGam,&S,&ZZI,NULL); malloc_mats(*px,*pg,&XZAI,&tmpM3,&Ct,&dC,&XZ,&dM1M2,&M1M2t,NULL); malloc_mat(*px,*pg,tmpM4); malloc_vecs(*px,&xi,&rowX,&difX,&tmpv1,&korG,&diag,&dB,&VdB,&AIXdN,&AIXlamt,&bhatt,NULL); malloc_vecs(*pg,&zi,&rowZ,&tmpv2,&z1,&rowG,&gam,&dgam,&ZGdN,&IZGdN,&ZGlamt,&IZGlamt,NULL); malloc_vecs(*antpers,&lrisk,&dN,&pbhat,&pghat,&plamt,NULL); malloc_vecs(*nb,&ta,NULL); coef[0]=1; ps[0]=*px+1; if (*px>=*pg) pmax=*px; else pmax=*pg; for (j=0;j<*pg;j++) VE(gam,j)=gamma[j]; for (itt=0;itt<*it;itt++) { mat_zeros(Ct); mat_zeros(CGam); vec_zeros(IZGdN); vec_zeros(IZGlamt); /* Rprintf("Itteration, it loop, Number Jumps %ld %ld %ld \n",*it,itt,*Ntimes); */ for (s=1;s<*Ntimes;s++) { time=times[s]; dtime=time-times[s-1]; mat_zeros(ldesignX);mat_zeros(ldesignG);vec_zeros(lrisk);vec_zeros(dN); for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { if ((start[c]=time)) { VE(lrisk,id[c])=1; for(j=0;j=time)) { VE(lrisk,id[c])=1; for(j=0;j */ /* #include */ /* TS-help 30/5-2005 gcc -O -c addmult.c gcc -shared -Wl -o addmult.so addmult.o -L/coll/local/lib -lm meschach.a */ //#include #include #include #include "matrix.h" //#include"R_ext/Random.h" /*#include */ /* #########################################################*/ // int *n,*p,*q,*k,*rani,*k1, *antsim ; void addmult(double *time,double *status,double *Xinp,double *Xtilinp,double *Zinp,double *Uinp,double *dUinp,double *optinp, double *excess,double *phi,double *stid,double *beta,int *n,int *p,int *q,int *k,double *tol,double *alpha,double *Psiinp, double *CoVarPsiinp,double *VarPsiinp,int *rani,double *testinp,double *testinpHW,double *testinpCM,double *testinpGOFCM, double *Scoreinp,int *antsim,int *k1) { int i,j,l,l1,l2,it,init_it,nummer; double alpha_tmp,y[*n], y1[*n], y2[*n],tmp1_sc,del,del_old,betaZ[*n],tau,b,beta_tmp[*q],random,testOBSGOFCM,dum1; vector *vtmp1,*vtmp2,*vtmp3,*vtmp4,*vtmp5,*vtmp6,*vtmp7; vector *testOBS, *testOBSHW, *testOBSCM, *testtmp,*testtmpHW,*testtmpCM,*testtmp1, *testtmp2, *testGOFCM,*testtmp1GOFCM,*Ufunkdim1,*Ufunkdim12, *Delta2tmp, *Delta2tmp1; matrix *mtmp1,*mtmp2,*mtmp2t,*mtmp3,*mtmp3m,*mtmp3mm,*mtmp3mmm,*mtmp4,*mtmp5,*mtmp6, *tmtmp1,*testOBS1,*testHW,*testCM; matrix *Xt,*PhiXt,*tmp10_mat,*DdN_Xt,*dM2m; matrix *tXt,*tDdN_Xt,*tdM2m; matrix *X; matrix *Z,*Phi_Z,*DdN_Phi_Z,*tmp3_mat,*tmp4_mat,*tmp5_mat,*tmp6_mat,*ttmpI; matrix *dU_dbeta,*dU_dbeta1,*dU_dbeta_tmp,*dU_dbeta_I,*dU_dbeta_I1,*tmp7_mat, *dU_dbeta_tilv,*tmp13_mat, *opt_tilv,*opt,*dM1,*dM1tmp; matrix *tZ,*tZ_Phi,*tDdN_Phi_Z,*tZ_PhiXt_tXt_Xt_I_tDdN_Xt,*tmpI; matrix *tXt_Xt,*tXt_Xt_I,*tXt_Xt_tmp; matrix *dN,*Phi_dN,*Q_dN,*Xt_tXt_Xt_I_tXt_dN; matrix *Ubeta_tilv,*Ubeta,*tZ_Phi_dN, *tZ_PhiXt_tXt_Xt_I_tXt_dN,*beta_m,*beta_m1,*dU_dbeta_I_Ubeta; matrix *tZ_PhiXt,*tZ_PhiXt_tXt_Xt_I; matrix *tXt_dN,*tXt_Xt_I_tXt_dN; matrix *tmp2_mat,*tmp11_mat,*tmp12_mat; matrix *Psi,*Ufunk,*C1,*dC1,*tdC1, *tC1,*C1_dU_I; matrix *dM1M2,*dM1M2tmp,*dM2,*tdM2; matrix *M1M2,*M2, *M1,*M1tmp1,*M1tmp2, *C1M1M2,*dC1M1M2,*tC1M1M2 ,*C1M1, *C1M1tC1, *VarPsi,*VarPsi1,*VarPsi2,*VarPsi_out; matrix *W1,*W2t[*n],*Ut[*n],*Ui[*k],*Utm[*n],*dU_dbeta_i[*k],*dW2,*Delta,*Delta1,*tmpM1,*Delta2,*tmpM2; // double norm_rand(); // void GetRNGstate(),PutRNGstate(); malloc_vecs((*p+1),&vtmp1,&vtmp3,&testOBS,&testtmp,&testOBSHW,&testOBSCM, &testtmpHW,&testtmpCM,&testtmp1,&testtmp2,NULL); malloc_vecs(*q,&vtmp2,&vtmp4,&vtmp5,NULL); malloc_vecs((*p+1)*(*p+1),&vtmp7,NULL); malloc_vecs(1,&vtmp6,NULL); malloc_vecs(*k,&Ufunkdim1,&Ufunkdim12,&Delta2tmp,&Delta2tmp1,NULL); malloc_vecs(*antsim,&testGOFCM,&testtmp1GOFCM,NULL); malloc_mats(*antsim,(*p+1),&testOBS1,&testHW,&testCM,NULL); malloc_mats((*p+1),1,&mtmp1,&mtmp6,NULL); malloc_mats(1,(*p+1),&tmtmp1,NULL); malloc_mats(1,1,&mtmp4,&mtmp5,NULL); malloc_mats(*q,1,&mtmp2,&mtmp3,&mtmp3m,&mtmp3mm,&mtmp3mmm,NULL); malloc_mats(1,*q,&mtmp2t,NULL); malloc_mats(*n,(*p+1),&Xt,&PhiXt,&tmp10_mat,&DdN_Xt,&dM2m,&dW2,NULL); malloc_mats((*p+1),*n,&tXt,&tDdN_Xt,&tdM2m,NULL); malloc_mats(*n,*p,&X,NULL); malloc_mats(*n,*q,&Z,&Phi_Z,&DdN_Phi_Z,&tmp3_mat,&tmp4_mat,&tmp5_mat, &tmp6_mat,&ttmpI,&W1,&tmp12_mat,NULL); // changed dims of tmp12_mat malloc_mats(*q,*q,&dU_dbeta,&dU_dbeta1,&dU_dbeta_tmp,&dU_dbeta_I,&dU_dbeta_I1,&tmp7_mat,&dU_dbeta_tilv, &tmp13_mat,&opt_tilv,&opt,&dM1,&dM1tmp,&M1,&M1tmp1,&M1tmp2,NULL); malloc_mats(*q,*n,&tZ,&tZ_Phi,&tDdN_Phi_Z, &tZ_PhiXt_tXt_Xt_I_tDdN_Xt,&tmpI,NULL); malloc_mats((*p+1),(*p+1),&tXt_Xt,&tXt_Xt_tmp,&tXt_Xt_I,NULL); malloc_mats(*n,1,&dN,&Phi_dN,&Q_dN,&Xt_tXt_Xt_I_tXt_dN,NULL); malloc_mats(*q,1,&Ubeta_tilv,&Ubeta,&tZ_Phi_dN,&tZ_PhiXt_tXt_Xt_I_tXt_dN,&beta_m,&beta_m1,&dU_dbeta_I_Ubeta,NULL); malloc_mats(*q,(*p+1),&tZ_PhiXt,&tZ_PhiXt_tXt_Xt_I,&dM1M2,&dM1M2tmp,&M1M2,&tdC1,&tC1,NULL); malloc_mats((*p+1),1,&tXt_dN,&tXt_Xt_I_tXt_dN,NULL); malloc_mats((*p+1),*q,&tmp2_mat,&tmp11_mat,&dC1,&C1,&C1M1,&C1_dU_I,NULL); // changed the dims of tmp12_mat malloc_mats((*p+1),*k,&Psi,NULL); malloc_mats((*p+1),(*p+1),&dM2,&M2,&tdM2,&C1M1M2,&dC1M1M2,&tC1M1M2,&C1M1tC1,&VarPsi,&VarPsi1,&VarPsi2,NULL); malloc_mats(((*p+1)*(*p+1)),*k,&VarPsi_out,NULL); /* OBS OBS */ malloc_mats(*k,*p+1,&Delta,&tmpM1,&Delta1,NULL); malloc_mats(*k,*q,&Delta2,&tmpM2,&Ufunk,NULL); for (j=0;j<*n;j++) { malloc_mat(*k,*p+1,W2t[j]); malloc_mat(*k,*q,Ut[j]); malloc_mat(*k,*q,Utm[j]); } for (j=0;j<*k;j++) { malloc_mat(*q,*q,dU_dbeta_i[j]); malloc_mat(*q,1,Ui[j]); } /*for (l=0;l<*q;++l){ U_beta[l]=0;}*/ /* for (l=0;l<((*q)*(*q));++l){dU_beta[l]=0;}*/ /** Newton-iteration **/ for (l=0;l<*q;++l){beta_tmp[l]=beta[l];} /* beta_0 */ // eps=0.01; tau=0; dum1=0; dum1=dum1+0; nummer=50; /* Antal iterationer der hoejst udfoeres */ del=1000; del_old=10000; it=0; // kny=0; /* max(tau_i) for hvilket at design ej sing. */ alpha_tmp=(*alpha); init_it=2; while ( (del>*tol) && (it=stid[i]) ? 1:0; y1[j]=(time[j]>=stid[i]) ? 1:0; y2[j]=(time[j]<=stid[i]) ? 1:0; ME(dN,j,0)=y1[j]*y2[j]; ME(Phi_dN,j,0)=phi[j]*y1[j]*y2[j]; } /******* Konstruktion design-matricer *******/ for (l=0;l<*p;++l){ for (j=0;j<*n;++j){ ME(X,j,l)=y[j]*Xinp[l*(*n)+j]; } } for (l=0;l<(*p+1);++l){ for (j=0;j<*n;++j){ ME(Xt,j,l)=(l<(*p)) ? y[j]*Xinp[l*(*n)+j]:y[j]*phi[j]; /** X.tilde **/ ME(PhiXt,j,l)=(l<(*p)) ? phi[j]*y[j]*Xinp[l*(*n)+j]:phi[j]*y[j]*phi[j]; /** Phi*X.tilde **/ ME(DdN_Xt,j,l)=(l<(*p)) ? y1[j]*y2[j]*Xinp[l*(*n)+j]:y1[j]*y2[j]*phi[j]; /** Diag(dN)*X.tilde **/ } } for (l=0;l<*q;++l){ for (j=0;j<*n;++j){ ME(Z,j,l)=y[j]*excess[j]*Zinp[l*(*n)+j]; ME(Phi_Z,j,l)=phi[j]*y[j]*excess[j]*Zinp[l*(*n)+j]; ME(DdN_Phi_Z,j,l)=y1[j]*y2[j]*phi[j]*y[j]*excess[j]*Zinp[l*(*n)+j]; } } /******** Slut konstruktion design-matricer *******/ /******* Beregning af score U_beta ************/ mat_transp(Z,tZ);mat_transp(Xt,tXt); MxA(tZ,Phi_dN,tZ_Phi_dN); MxA(tZ,PhiXt,tZ_PhiXt); MxA(tXt,Xt,tXt_Xt); /* mat_copy(tXt_Xt,tXt_Xt_tmp); QRfactor(tXt_Xt_tmp,vtmp1); a=1; for (l=0;l<(*p+1);++l){a=a*ME(tXt_Xt_tmp,l,l);} a=sqrt(a*a); b=(a>eps) ? 1:0;*/ b=1; /*mat_zeros(tXt_Xt_I);*/ /* if (a>eps){*/ invert(tXt_Xt,tXt_Xt_I); MxA(tXt,dN,tXt_dN); MxA(tXt_Xt_I,tXt_dN,tXt_Xt_I_tXt_dN); MxA(tZ_PhiXt,tXt_Xt_I_tXt_dN,tZ_PhiXt_tXt_Xt_I_tXt_dN); mat_subtr(tZ_Phi_dN,tZ_PhiXt_tXt_Xt_I_tXt_dN,Ubeta_tilv); scl_mat_mult(b,Ubeta_tilv,Ubeta_tilv); if (i<1){mat_copy(Ubeta_tilv,Ui[i]);} if (i>0){mat_add(Ubeta_tilv,Ui[i-1],Ui[i]);} /* Ui[i] er vard. af scoren til tid tau_i*/ for (l=0;l<*q;++l){ Uinp[l]+=ME(Ubeta_tilv,l,0);} /* Rprintf("%2d %6.4f \n",i,Uinp[0]);*/ /******* Slut beregning af score U_beta ************/ /****** Beregning af dU_dbeta************/ mat_transp(Phi_Z,tZ_Phi); tmp1_sc=ME(tXt_Xt_I_tXt_dN,(*p),0); MxA(Xt,tXt_Xt_I_tXt_dN,Xt_tXt_Xt_I_tXt_dN); mat_subtr(dN,Xt_tXt_Xt_I_tXt_dN,Q_dN); mat_zeros(tmp2_mat); for (l=0;l<*q;++l){for (j=0;j<*n;++j){ ME(tmp2_mat,(*p),l)=ME(tmp2_mat,(*p),l)+ phi[j]*(ME(Z,j,l))*(ME(Q_dN,j,0));}} scl_mat_mult(tmp1_sc,Phi_Z,tmp3_mat); MxA(Xt,tXt_Xt_I,tmp10_mat); MxA(tXt,tmp3_mat,tmp11_mat); MxA(tmp10_mat,tmp11_mat,tmp12_mat); mat_subtr(tmp3_mat,tmp12_mat,tmp4_mat); MxA(tmp10_mat,tmp2_mat,tmp5_mat); /*mat_subtr(tmp4_mat,tmp5_mat,tmp6_mat);*/ mat_add(tmp4_mat,tmp5_mat,tmp6_mat); mat_zeros(tmp7_mat); for (l=0;l<*q;++l){for (l1=0;l1<*q;++l1){for (j=0;j<*n;++j){ ME(tmp7_mat,l,l1)=ME(tmp7_mat,l,l1)+ phi[j]*(ME(Z,j,l))*(ME(Z,j,l1))*(ME(Q_dN,j,0));}}} /* print_mat(tmp7_mat);*/ MxA(tZ_Phi,tmp6_mat,tmp13_mat); /*m_mlt(tZ_Phi,tmp5_mat,tmp13_mat); if (i>(*k-2)){m_output(tmp13_mat);}*/ MxA(tZ_Phi,tmp4_mat,dU_dbeta_tilv);scl_mat_mult(-1,dU_dbeta_tilv,dU_dbeta_tilv);/* Hovedleddet i dU_dbeta*/ scl_mat_mult(b,dU_dbeta_tilv,dU_dbeta_tilv); mat_subtr(tmp7_mat, tmp13_mat,dU_dbeta_tilv); scl_mat_mult(b,dU_dbeta_tilv,dU_dbeta_tilv); mat_add(dU_dbeta_tilv,dU_dbeta1,dU_dbeta1); mat_copy(dU_dbeta1,dU_dbeta_i[i]); /* if (i>(*k-2)) {print_mat(dU_dbeta1); }*/ mat_subtr(tmp7_mat, tmp13_mat,dU_dbeta_tilv); scl_mat_mult(b,dU_dbeta_tilv,dU_dbeta_tilv); mat_add(dU_dbeta_tilv,dU_dbeta,dU_dbeta); /* if (i>(*k-2)) {print_mat(dU_dbeta); } */ /****** Slut beregning af dU_dbeta************/ /***** Beregning af [Ubeta] ************/ mat_transp(DdN_Xt,tDdN_Xt); mat_transp(DdN_Phi_Z,tDdN_Phi_Z); MxA(tZ_PhiXt,tXt_Xt_I,tZ_PhiXt_tXt_Xt_I); MxA(tZ_PhiXt_tXt_Xt_I,tDdN_Xt,tZ_PhiXt_tXt_Xt_I_tDdN_Xt); mat_subtr(tDdN_Phi_Z,tZ_PhiXt_tXt_Xt_I_tDdN_Xt,tmpI); mat_transp(tmpI,ttmpI); MxA(tmpI,ttmpI,opt_tilv); scl_mat_mult(b,opt_tilv,opt_tilv); for (l=0;l<*q;++l){for (l1=0;l1<*q;++l1){ optinp[l*(*q)+l1]+=ME(opt_tilv,l1,l);}} mat_add(opt,opt_tilv,opt); /*if (i<1){Rprintf("%6.4f \n",Uinp[0]);print_mat(opt);}*/ /***** Slut beregning af [Ubeta] ************/ /** Start beregning af ene komponent i robust varians***/ for (l=0;l<*n;++l){ extract_row(Xt,l,vtmp3);scl_vec_mult(ME(dN,l,0),vtmp3,vtmp3); replace_col(mtmp1,0,vtmp3); MxA(tZ_PhiXt_tXt_Xt_I,mtmp1,mtmp2); extract_row(Phi_Z,l,vtmp4);scl_vec_mult(ME(dN,l,0),vtmp4,vtmp4); replace_col(mtmp3,0,vtmp4); mat_subtr(mtmp3,mtmp2,mtmp3);extract_col(mtmp3,0,vtmp4); for (l1=0;l1<*q;++l1){ ME(Utm[l],i,l1)=(i>0) ? (VE(vtmp4,l1)+ME(Utm[l],i-1,l1)):VE(vtmp4,l1); } /* tau_2,...,tau_k */ if (i<1){replace_row(W1,l,vtmp4);} /* tau_1 */ if (i>0){for (l1=0;l1<*q;++l1){ ME(W1,l,l1)=ME(W1,l,l1)+VE(vtmp4,l1);}} /* tau_2,...,tau_k */ } /** Slut beregning af ene komponent i robust varians***/ } /* Slut gennemlob tau_1 til tau_k */ /** Slut beregning af U, dU og [U] **/ for (l=0;l<*q;++l){ME(beta_m,l,0)=beta[l];} /*Rprintf("%6.4f \n",beta[0]);*/ for (l=0;l<*q;++l){ME(Ubeta,l,0)=Uinp[l];} for (l=0;l<*q;++l){for (l1=0;l1<*q;++l1){ dUinp[l*(*q)+l1]=ME(dU_dbeta,l1,l);}}/* dU_dbeta */ tau=(iteps){*/ invert(dU_dbeta,dU_dbeta_I);invert(dU_dbeta1,dU_dbeta_I1); /*Rprintf("%6.4f \n",c);*/ /*print_mat(dU_dbeta_I1); print_mat(dU_dbeta_I);*/ for (i=0;i<*k;++i){ VE(Ufunkdim1,i)=0; VE(Ufunkdim12,i)=0; for (l=0;l<*q;++l){ ME(Ufunk,i,l)=(ME(Ui[i],l,0))*sqrt(fabs(ME(dU_dbeta_I1,l,l))); VE(Ufunkdim1,i)=VE(Ufunkdim1,i)+fabs(ME(Ufunk,i,l)); VE(Ufunkdim12,i) = VE(Ufunkdim12,i)+ME(Ufunk,i,l); }/* Normeret score til tid tau_i */ for (l=0;l<*n;++l){ for (l1=0;l1<*q;++l1){ ME(mtmp3m,l1,0)=ME(Utm[l],(*k-1),l1);} MxA(dU_dbeta_I1,mtmp3m,mtmp3mm); MxA(dU_dbeta_i[i],mtmp3mm,mtmp3mmm); for (l1=0;l1<*q;++l1){ ME(Ut[l],i,l1)=(ME(Utm[l],i,l1)-ME(mtmp3mmm,l1,0)); } } } scl_mat_mult(*alpha,dU_dbeta_I,dU_dbeta_I); /* alpha er skridtlangden */ /* i Newton-iterationen */ mat_copy(opt,M1tmp1); MxA(dU_dbeta_I,M1tmp1,M1tmp2); MxA(M1tmp2,dU_dbeta_I,M1);/* i [M_1](tau_k) */ MxA(dU_dbeta_I,Ubeta,dU_dbeta_I_Ubeta); mat_subtr(beta_m,dU_dbeta_I_Ubeta,beta_m1); /*print_mat(beta_m1);*/ if (del<*tol){dum1=2;} del=0; for (l=0;l<*q;++l){del+=Uinp[l]*Uinp[l];} del=sqrt(del); for (l=0;l<*q;++l){beta[l]=ME(beta_m1,l,0);} /*if (it<7){ Rprintf(" it alpha beta del \t"); Rprintf("%2d %6.4f %6.4f %6.4f \n",it,*alpha,beta[0],del); }*/ if (del<*tol){for (l=0;l<*q;++l){beta[l]=ME(beta_m,l,0);}} /* Rprintf(" it alpha beta del \t"); Rprintf("%2d %6.4f %6.4f %6.4f \n",it,*alpha,beta[0],del);*/ if ((del_oldinit_it) ){ alpha_tmp=0.67*(*alpha); for (l=0;l<*q;++l){beta[l]=beta_tmp[l];}} del_old=del; it=it+1; } /* for (l=0;l<*q;++l){beta[l]=ME(beta_m,l,0);}*/ /** Slut Newton-iteration **/ /*print_vec(Ufunkdim1);*/ /** Start beregning af hat Psi samt varians **/ /*** Initialiseringer ****/ for (j=0;j<*n;++j){ betaZ[j]=0; for (l=0;l<*q;++l){betaZ[j]+=excess[j]* Zinp[l*(*n)+j]*beta[l];} phi[j]=excess[j]*exp(betaZ[j]);} for (l=0;l<(*p+1);++l){for (i=0;i<*k;++i){ ME(Psi,l,i)=0;} } for (l=0;l<(*p+1);++l){for (i=0;i<*q;++i){ ME(C1,l,i)=0;} } /* for (l=0;l<*q;++l){for (i=0;i<*q;++i){ ME(M1,l,i)=0;} }*/ for (l=0;l<(*p+1);++l){for (i=0;i<(*p+1);++i){ ME(M2,l,i)=0;} } for (l=0;l<*q;++l){for (i=0;i<(*p+1);++i){ ME(M1M2,l,i)=0;} } for (i=0;i<*k;++i){ /* Start gennemlob tau_1 til tau_k */ /*** Initialiseringer ****/ /*** Slut initialiseringer ****/ for (j=0;j<*n;++j){ y[j]=(time[j]>=stid[i]) ? 1:0; y1[j]=(time[j]>=stid[i]) ? 1:0; y2[j]=(time[j]<=stid[i]) ? 1:0; ME(dN,j,0)=y1[j]*y2[j]; ME(Phi_dN,j,0)=phi[j]*y1[j]*y2[j]; } /******* Konstruktion design-matricer *******/ for (l=0;l<*p;++l){ for (j=0;j<*n;++j){ ME(X,j,l)=y[j]*Xinp[l*(*n)+j]; } } for (l=0;l<(*p+1);++l){ for (j=0;j<*n;++j){ ME(Xt,j,l)=(l<(*p)) ? y[j]*Xtilinp[l*(*n)+j]:y[j]*phi[j]; /** X.tilde **/ ME(PhiXt,j,l)=(l<(*p)) ? phi[j]*y[j]*Xtilinp[l*(*n)+j]:phi[j]*y[j]*phi[j]; /** Phi*X.tilde **/ ME(DdN_Xt,j,l)=(l<(*p)) ? y1[j]*y2[j]*Xtilinp[l*(*n)+j]:y1[j]*y2[j]*phi[j]; /** Diag(dN)*X.tilde **/ } } for (l=0;l<*q;++l){ for (j=0;j<*n;++j){ ME(Z,j,l)=y[j]*excess[j]*Zinp[l*(*n)+j]; ME(Phi_Z,j,l)=phi[j]*y[j]*excess[j]*Zinp[l*(*n)+j]; ME(DdN_Phi_Z,j,l)=y1[j]*y2[j]*phi[j]*y[j]*excess[j]*Zinp[l*(*n)+j]; } } /******** Slut konstruktion design-matricer *******/ /******* Beregning af score U_beta ************/ mat_transp(Z,tZ); mat_transp(Xt,tXt); MxA(tZ,Phi_dN,tZ_Phi_dN); MxA(tZ,PhiXt,tZ_PhiXt); MxA(tXt,Xt,tXt_Xt);/*print_mat(tXt_Xt);*/ mat_copy(tXt_Xt,tXt_Xt_tmp); /* QRfactor(tXt_Xt_tmp,vtmp1); a=1; for (l=0;l<(*p+1);++l){a=a*ME(tXt_Xt_tmp,l,l);} a=sqrt(a*a); b=(a>eps) ? 1:0;*/ b=1; /* kny=(a>eps) ? i:kny; if (a>eps){*/ invert(tXt_Xt,tXt_Xt_I); MxA(tXt,dN,tXt_dN); MxA(tXt_Xt_I,tXt_dN,tXt_Xt_I_tXt_dN); MxA(tZ_PhiXt,tXt_Xt_I_tXt_dN,tZ_PhiXt_tXt_Xt_I_tXt_dN); mat_subtr(tZ_Phi_dN,tZ_PhiXt_tXt_Xt_I_tXt_dN,Ubeta_tilv); for (l=0;l<*q;++l){ Uinp[l]+=b*ME(Ubeta_tilv,l,0);} /******* Slut beregning af score U_beta ************/ /****** Beregning af dU_dbeta************/ mat_transp(Phi_Z,tZ_Phi); tmp1_sc=ME(tXt_Xt_I_tXt_dN,(*p),0); MxA(Xt,tXt_Xt_I_tXt_dN,Xt_tXt_Xt_I_tXt_dN); mat_subtr(dN,Xt_tXt_Xt_I_tXt_dN,Q_dN); mat_zeros(tmp2_mat); for (l=0;l<*q;++l){for (j=0;j<*n;++j){ ME(tmp2_mat,(*p),l)+=phi[j]*(ME(Z,j,l))*(ME(Q_dN,j,0));}} scl_mat_mult(tmp1_sc,Phi_Z,tmp3_mat); MxA(Xt,tXt_Xt_I,tmp10_mat); MxA(tXt,tmp3_mat,tmp11_mat); MxA(tmp10_mat,tmp11_mat,tmp12_mat); mat_subtr(tmp3_mat,tmp12_mat,tmp4_mat); MxA(tmp10_mat,tmp2_mat,tmp5_mat); mat_add(tmp4_mat,tmp5_mat,tmp6_mat); mat_zeros(tmp7_mat); for (l=0;l<*q;++l){for (l1=0;l1<*q;++l1){for (j=0;j<*n;++j){ ME(tmp7_mat,l,l1)+=phi[j]*(ME(Z,j,l))* (ME(Z,j,l1))*(ME(Q_dN,j,0));}}} MxA(tZ_Phi,tmp6_mat,tmp13_mat); mat_subtr(tmp7_mat, tmp13_mat,dU_dbeta_tilv); scl_mat_mult(b,dU_dbeta_tilv,dU_dbeta_tilv); /*m_mlt(tZ_Phi,tmp4_mat,dU_dbeta_tilv);sm_mlt(-1,dU_dbeta_tilv,dU_dbeta_tilv); sm_mlt(b,dU_dbeta_tilv,dU_dbeta_tilv);*/ mat_add(dU_dbeta_tilv,dU_dbeta,dU_dbeta); /****** Slut beregning af dU_dbeta************/ /***** Beregning af [Ubeta] ************/ mat_transp(DdN_Xt,tDdN_Xt); mat_transp(DdN_Phi_Z,tDdN_Phi_Z); MxA(tZ_PhiXt,tXt_Xt_I,tZ_PhiXt_tXt_Xt_I); MxA(tZ_PhiXt_tXt_Xt_I,tDdN_Xt,tZ_PhiXt_tXt_Xt_I_tDdN_Xt); mat_subtr(tDdN_Phi_Z,tZ_PhiXt_tXt_Xt_I_tDdN_Xt,tmpI); /***** Slut beregning af [Ubeta] ************/ /** Beregning af Psi **/ for (l=0;l<(*p+1);++l){ ME(Psi,l,i)=(i>0) ? ME(Psi,l,i-1)+b*ME(tXt_Xt_I_tXt_dN,l,0):b*ME(tXt_Xt_I_tXt_dN,l,0); } /** Slut beregning Psi **/ /** Beregning af Var(\hat Psi) **/ scl_mat_mult(ME(tXt_Xt_I_tXt_dN,*p,0),tZ_PhiXt_tXt_Xt_I,tdC1); mat_transp(tdC1,dC1); scl_mat_mult(b,dC1,dC1); mat_add(C1,dC1,C1); /* C1(tau_i) */ mat_transp(C1,tC1); MxA(DdN_Xt,tXt_Xt_I,dM2m);mat_transp(dM2m,tdM2m); MxA(tdM2m,dM2m,dM2); /* tilvakst i [M_2] */ scl_mat_mult(b,dM2,dM2); mat_add(M2,dM2,M2); /* [M_2](tau_i) */ MxA(C1,M1,C1M1); MxA(C1M1,tC1,C1M1tC1); /* C1(tau_i)[M_1](tau_k) C1^T(tau_i) */ MxA(tmpI,dM2m,dM1M2tmp); MxA(dU_dbeta_I,dM1M2tmp,dM1M2); /* tilvakst i [M_1,M_2] */ scl_mat_mult(b,dM1M2,dM1M2); mat_add(M1M2,dM1M2,M1M2); /*[M_1,M_2](tau_i) */ MxA(C1,M1M2,C1M1M2); /* C1(tau_i)[M_1,M_2](tau_i) */ mat_transp(C1M1M2,tC1M1M2); mat_add(C1M1M2,tC1M1M2,dC1M1M2); mat_add(M2,C1M1tC1,VarPsi1); mat_subtr(VarPsi1,dC1M1M2,VarPsi);/* Est. Var(hat Phi)(tau_i) */ /* en (p+1)x(p+1)-matrix */ for (l1=0;l1<(*p+1);++l1){ for (l2=0;l2<(*p+1);++l2){ ME(VarPsi_out,l1*(*p+1)+l2,i)=ME(VarPsi,l2,l1);}} /* print_mat(VarPsi);*/ /** Start beregning af anden komponent i robust varians***/ vec_zeros(vtmp7); for (l=0;l<*n;++l){ extract_row(Xt,l,vtmp3); scl_mat_mult(b,tXt_Xt_I_tXt_dN,tXt_Xt_I_tXt_dN); vM(tXt_Xt_I_tXt_dN,vtmp3,vtmp6); VE(vtmp6,0)=y1[l]*y2[l]-VE(vtmp6,0); scl_vec_mult(VE(vtmp6,0),vtmp3,vtmp3); replace_col(mtmp1,0,vtmp3); MxA(tXt_Xt_I,mtmp1,mtmp6); for (l1=0;l1<(*p+1);++l1){ ME(dW2,l,l1)=(i<1) ? ME(mtmp6,l1,0):ME(dW2,l,l1)+ME(mtmp6,l1,0);} MxA(C1,dU_dbeta_I,C1_dU_I); extract_row(W1,l,vtmp5);Mv(C1_dU_I,vtmp5,vtmp3); extract_row(dW2,l,vtmp1); vec_subtr(vtmp1,vtmp3,vtmp1); replace_row(W2t[l],i,vtmp1); for (l1=0;l1<(*p+1);++l1){ for (l2=0;l2<(*p+1);++l2){ VE(vtmp7,l1*(*p+1)+l2)=VE(vtmp7,l1*(*p+1)+l2)+(VE(vtmp1,l1))*(VE(vtmp1,l2));}} } /*print_vec(vtmp7);*/ for (l1=0;l1<(*p+1);++l1){ for (l2=0;l2<(*p+1);++l2){ ME(VarPsi_out,l1*(*p+1)+l2,i)=VE(vtmp7,l1*(*p+1)+l2);}} /** Slut beregning af Var(\hat Psi) **/ /*print_mat(VarPsi);*/ } /* Slut gennemlob tau_1 til tau_k */ /* Beregning af robust varians af beta */ mat_zeros(M1);mat_zeros(M1tmp1);mat_zeros(M1tmp2); for (l=0;l<*n;++l){ extract_row(W1,l,vtmp5); replace_col(mtmp2,0,vtmp5);mat_transp(mtmp2,mtmp2t); MxA(mtmp2,mtmp2t,tmp7_mat); mat_add(M1tmp1,tmp7_mat,M1tmp1); } mat_transp(dU_dbeta_I,dU_dbeta_tmp); MxA(dU_dbeta_I,M1tmp1,M1tmp2); MxA(M1tmp2,dU_dbeta_tmp,M1); /* print_mat(M1); */ /* Slut beregning af robust varians af beta */ /* Beregning af obs. teststorrelse */ for (l=0;l<*p+1;++l){VE(testOBS,l)=0;VE(testOBSHW,l)=0;VE(testOBSCM,l)=0; for (i=0;i<*k1;++i){ VE(testtmp,l)=fabs(ME(Psi,l,i))/sqrt(ME(VarPsi_out,l*(*p+1+1),i)); VE(testOBS,l)=(VE(testOBS,l)>VE(testtmp,l)) ? VE(testOBS,l):VE(testtmp,l); VE(testtmpHW,l)=fabs(ME(Psi,l,i))*sqrt(ME(VarPsi_out,l*(*p+1+1),*k1-1))/ (ME(VarPsi_out,l*(*p+1+1),i)+ME(VarPsi_out,l*(*p+1+1),*k1-1)); VE(testtmpCM,l)=(ME(Psi,l,i))*(ME(Psi,l,i))/ME(VarPsi_out,l*(*p+1+1),i); VE(testOBSHW,l)=(VE(testOBSHW,l)>VE(testtmpHW,l)) ? VE(testOBSHW,l):VE(testtmpHW,l); VE(testOBSCM,l)=VE(testOBSCM,l)+VE(testtmpCM,l); } } testOBSGOFCM=0; for (i=0;i<*k;++i){ testOBSGOFCM=(testOBSGOFCM> sqrt(VE(Ufunkdim1,i)*VE(Ufunkdim1,i))) ? testOBSGOFCM:sqrt(VE(Ufunkdim1,i)*VE(Ufunkdim1,i)); } /* Rprintf("%6.4f \n",testOBSGOFCM);*/ /*** Start simulationer ***/ Rprintf("Simulations start N=\t"); Rprintf("%2d \n",*antsim); GetRNGstate(); /* to use R random normals */ for (j=0;j<*antsim;++j){ mat_zeros(Delta);mat_zeros(Delta2); for (i=0;i<*n;++i){ random=norm_rand(); scl_mat_mult(random,W2t[i],tmpM1);mat_add(tmpM1,Delta,Delta); scl_mat_mult(random,Ut[i],tmpM2);mat_add(tmpM2,Delta2,Delta2); }/* Delta indeholder Simuleret Psi(t) */ /* Delta indeholder Simuleret U(t) */ vec_zeros(Delta2tmp); vec_zeros(Delta2tmp1); for (i=0;i<*k;++i){ for (l=0;l<*q;++l){ VE(Delta2tmp,i)=VE(Delta2tmp,i)+fabs(ME(Delta2,i,l))* sqrt(fabs(ME(dU_dbeta_I1,l,l))); VE(Delta2tmp1,i)=VE(Delta2tmp1,i)+ME(Delta2,i,l)* sqrt(fabs(ME(dU_dbeta_I1,l,l))); } } if (j<51) { /*if (j<1){print_vec(Ufunkdim1);} if (j<6){print_vec(Delta2tmp);}*/ for (l1=0;l1<*q;++l1){ for (l=0;l<*k;++l){ Scoreinp[(j*(*q)+l1)*(*k)+l]=(j<1) ? ME(Ui[l],l1,0):ME(Delta2,l,l1); }}} /*Ui[i] er vard. af scoren til tid tau_i*/ for (l=0;l<*p+1;++l){ME(testOBS1,j,l)=0;ME(testHW,j,l)=0;ME(testCM,j,l)=0; for (i=0;i<*k1;++i){ VE(testtmp,l)=fabs(ME(Delta,i,l))/sqrt(ME(VarPsi_out,l*(*p+1+1),i)); /* testtmp: Simulations baseret konf.band */ VE(testtmp1,l)=fabs(ME(Delta,i,l))*sqrt(ME(VarPsi_out,l*(*p+1+1),*k1-1))/ (ME(VarPsi_out,l*(*p+1+1),i)+ME(VarPsi_out,l*(*p+1+1),*k1-1)); /* testtmp1: Simulering af Hall-Wellner band */ VE(testtmp2,l)=(ME(Delta,i,l))*(ME(Delta,i,l))/ME(VarPsi_out,l*(*p+1+1),i); ME(testOBS1,j,l)=(ME(testOBS1,j,l)>VE(testtmp,l)) ? ME(testOBS1,j,l):VE(testtmp,l); ME(testHW,j,l)=(ME(testHW,j,l)>VE(testtmp1,l)) ? ME(testHW,j,l):VE(testtmp1,l); ME(testCM,j,l)=ME(testCM,j,l)+VE(testtmp2,l); } } VE(testGOFCM,j)=0; for (i=0;i<*k;++i){ VE(testGOFCM,j)=(VE(testGOFCM,j)>sqrt(VE(Delta2tmp,i)*VE(Delta2tmp,i))) ? VE(testGOFCM,j):sqrt(VE(Delta2tmp,i)*VE(Delta2tmp,i)); } for (l=0;l<(*p+1);++l){ testinp[j*(*p+1)+l]=(j<1) ? VE(testOBS,l):ME(testOBS1,j-1,l); testinpHW[j*(*p+1)+l]=(j<1) ? VE(testOBSHW,l):ME(testHW,j-1,l); testinpCM[j*(*p+1)+l]=(j<1) ? VE(testOBSCM,l):ME(testCM,j-1,l); } testinpGOFCM[j]=(j<1) ? testOBSGOFCM:VE(testGOFCM,j-1); } /* Slut simulationer */ PutRNGstate(); /* to use R random normals */ /*print_vec(testGOFCM);*/ for (l=0;l<(*p+1);++l){ testinp[(*antsim)*(*p+1)+l]=ME(testOBS1,*antsim-1,l); testinpHW[(*antsim)*(*p+1)+l]=ME(testHW,*antsim-1,l); testinpCM[(*antsim)*(*p+1)+l]=ME(testCM,*antsim-1,l); } testinpGOFCM[*antsim]=VE(testGOFCM,*antsim-1); for (l=0;l<*q;++l){ for (l1=0;l1<*q;++l1){ optinp[l*(*q)+l1]=ME(M1,l1,l); }} /* Robust varians for beta returneres */ for (l=0;l<*k;++l){ for (l1=0;l1<(*p+1);++l1){ Psiinp[l*(*p+1)+l1]=ME(Psi,l1,l); }} /* Psi returneres */ for (l=0;l<*k;++l){ for (l1=0;l1<(*p+1);++l1){ for (l2=0;l2<(*p+1);++l2){ CoVarPsiinp[l*(*p+1)*(*p+1)+l1*(*p+1)+l2]=ME(VarPsi_out,l1*(*p+1)+l2,l); }}} /* Robust covar-matrix for Psi returneres */ for (l=0;l<*k;++l){ for (l2=0;l2<(*p+1);++l2){ VarPsiinp[l*(*p+1)+l2]=ME(VarPsi_out,l2*(*p+1+1),l); }} /* Robust varians for enkeltkomp. af Psi returneres */ *n=it; /* print_mat(VarPsi_out);*/ free_mats(&mtmp1,&mtmp2,&mtmp2t,&mtmp3,&mtmp3m,&mtmp3mm,&mtmp3mmm, &mtmp4,&mtmp5,&mtmp6,&tmtmp1, &testOBS1,&testHW,&testCM, &Xt,&PhiXt,&tmp10_mat,&DdN_Xt,&dM2m,&tXt,&tDdN_Xt,&tdM2m,&X, &Z,&Phi_Z,&DdN_Phi_Z,&tmp3_mat,&tmp4_mat,&tmp5_mat,&tmp6_mat,&ttmpI, &dU_dbeta,&dU_dbeta1,&dU_dbeta_tmp,&dU_dbeta_I,&dU_dbeta_I1,&tmp7_mat,&dU_dbeta_tilv,&tmp13_mat, &opt_tilv,&opt,&dM1,&dM1tmp, &tZ,&tZ_Phi,&tDdN_Phi_Z,&tZ_PhiXt_tXt_Xt_I_tDdN_Xt,&tmpI, &tXt_Xt,&tXt_Xt_I,&tXt_Xt_tmp,&dN,&Phi_dN,&Q_dN,&Xt_tXt_Xt_I_tXt_dN, &Ubeta_tilv,&Ubeta,&tZ_Phi_dN,&tZ_PhiXt_tXt_Xt_I_tXt_dN,&beta_m,&beta_m1, &dU_dbeta_I_Ubeta,&tZ_PhiXt,&tZ_PhiXt_tXt_Xt_I, &tXt_dN,&tXt_Xt_I_tXt_dN,&tmp2_mat,&tmp11_mat,&tmp12_mat, &Psi,&C1,&dC1,&tdC1, &tC1,&C1_dU_I,&dM1M2,&dM1M2tmp,&dM2,&tdM2, &M1M2,&M2, &M1,&M1tmp1,&M1tmp2, &C1M1M2,&dC1M1M2,&tC1M1M2 ,&C1M1, &C1M1tC1, &VarPsi,&VarPsi1,&VarPsi2,&VarPsi_out,&W1,&Delta,&Delta1,&tmpM1,&dW2, &Delta2,&tmpM2,&Ufunk,NULL); for (j=0;j<*n;j++) { free_mat(W2t[j]); free_mat(Ut[j]);free_mat(Utm[j]);} for (j=0;j<*k;j++) { free_mat(dU_dbeta_i[j]); free_mat(Ui[j]);} free_vecs(&vtmp1,&vtmp2,&vtmp3,&vtmp4,&vtmp5,&vtmp6,&vtmp7, &testOBS, &testOBSHW, &testOBSCM, &testtmp,&testtmpHW,&testtmpCM,&testtmp1, &testtmp2, &testGOFCM,&testtmp1GOFCM,&Ufunkdim1,&Ufunkdim12, &Delta2tmp, &Delta2tmp1,NULL); // free(y); free(y1); free(y2); free(betaZ); free(beta_tmp); } timereg/src/unifConfBandResampling.c0000644000176200001440000000412314421510301017206 0ustar liggesusers//#include #include /* declares malloc() */ #include #include #define USE_FC_LEN_T #include #include "matrix.h" #ifndef FCONE #define FCONE #endif /* DGEMV - perform one of the matrix-vector operations */ /* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, */ //extern void F77_SUB(dgemv)( // const char *trans, const int *m, const int *n, // const double *alpha, const double *a, const int *lda, // const double *x, const int *incx, const double *beta, // double *y, const int *incy); void confBandBasePredict (double *delta, int *nObs, int *nt, int *n, double *se, double *mpt, int *nSims){ int nRowDelta = *nObs * *nt; // nColDelta = *n // se is a vector of length nRowDelta // mpt is a vector of length *n // pt is a vector of length nRowDelta int i,j,k; // dummy variables, counters // The next line does: double g[*n]; // vector of IID random normals double *g = (double *)malloc(*n * sizeof(double)); // The next line does: double pt[nRowDelta]; double *pt = (double *)malloc(nRowDelta * sizeof(double)); double pt1, pt2; // temporary variables used while calculating maxima // Some parameters to give to DGEMV in the BLAS library char trans = 'n'; double alpha = 1.0; double beta = 0.0; int incx = 1; int incy = 1; // double norm_rand(); // void GetRNGstate(),PutRNGstate(); GetRNGstate(); for(i = 0; i < *nSims; i++){ // Number of draws // First generate IID random normal vector of length *n for(j = 0; j < *n; j++){ g[j] = norm_rand(); } // Matrix multiplication: // pt := delta %*% g F77_CALL(dgemv)(&trans, &nRowDelta, n, &alpha, delta, &nRowDelta, g, &incx, &beta, pt, &incy FCONE ); for(k = 0; k < *nObs; k++){ pt1 = -1.0e99; // initially set to -INF for(j = 0; j < *nt; j++){ pt2 = fabs(pt[k * *nt + j])/se[k * *nt + j]; if(pt1 < pt2){ pt1 = pt2; } } mpt[i * *nObs + k] = pt1; } } PutRNGstate(); // prevent memory leaks by unallocating memory allocated by malloc free(g); free(pt); } timereg/src/additive-compSs.c0000644000176200001440000003042314421510301015665 0ustar liggesusers//#include #include #include "matrix.h" void compSs(double *alltimes,int *Nalltimes,int *Ntimes,double *designX,int *nx,int *px,double *designG,int *ng,int *pg,int *antpers,double *start,double *stop,int *id,int *status,int *deltaweight,double *intZHZ,double *intZHdN,int *silent) { // {{{ matrix *X,*A,*AI,*AIXW,*dCGam,*CGam,*Ct,*ICGam,*XWZ,*ZWZ,*XWZAI,*tmpM4,*tmpM2; vector *xi,*tmpv2,*tmpv1,*PLScomp,*Xi,*dA,*rowX,*AIXWdN,*korG,*rowZ,*gam,*ZHdN, *IZHdN,*zi; int j,k,l,c,s,count,pers=0,pmax,*ipers=calloc(*Ntimes,sizeof(int)); int stat,*ls=calloc(*Ntimes,sizeof(int)); double time,dtime; malloc_mats(*antpers,*px,&X,NULL); malloc_mats(*px,*px,&A,&AI,NULL); malloc_mats(*px,*antpers,&AIXW,NULL); // malloc_mats(*antpers,*pg,&Z,NULL); malloc_mats(*pg,*pg,&tmpM2,&ZWZ,&ICGam,&CGam,&dCGam,NULL); malloc_mats(*px,*pg,&Ct,&XWZ,&XWZAI,NULL); malloc_mat(*px,*pg,tmpM4); malloc_vecs(*px,&dA,&xi,&tmpv1,&korG,&rowX,&AIXWdN,NULL); malloc_vecs(*pg,&zi,&tmpv2,&rowZ,&gam,&ZHdN,&IZHdN,NULL); malloc_vecs(*antpers,&PLScomp,&Xi,NULL); if (*px>=*pg) pmax=*px; else pmax=*pg; mat_zeros(Ct); mat_zeros(CGam); vec_zeros(IZHdN); // Rprintf(" test \n"); for (s=1;s<*Nalltimes;s++){ // Rprintf(" test %d %d %d \n",s,*antpers,*nx); time=alltimes[s]; dtime=time-alltimes[s-1]; mat_zeros(A); stat=0; mat_zeros(ZWZ); mat_zeros(XWZ); l=0; stat=0; for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { // Rprintf("times %lf %lf %lf \n",time,start[c],stop[c]); if ((start[c]=time)) { // Rprintf("under risk %d %d %d \n",c,id[c],count); for(j=0;j=*pg) pmax=*px; else pmax=*pg; //mat_zeros(Ct); mat_zeros(CGam); vec_zeros(IZHdN); //mat_zeros(A); mat_zeros(ZWZ); mat_zeros(XWZ); count=nx[0]-1; for (s=(*Nalltimes)-1;s>0;s=s-1){ sstop=0; // Rprintf(" test %d %d %d \n",s,*antpers,*nx); time=alltimes[s]; dtime=time-alltimes[s-1]; stat=0; l=0; stat=0; if (1==0) { for (c=0,count=0;((c<*nx) && (count!=*antpers));c++) { // {{{ // Rprintf("times %lf %lf %lf \n",time,start[c],stop[c]); if ((start[c]=time)) { // Rprintf("under risk %d %d %d \n",c,id[c],count); for(j=0;j=0;c=c-1) { // {{{ // Rprintf("times %d %lf %lf %lf %d %d %d \n",s,time,start[c],stop[c],c,sstop,count); if ((start[c]=time)) { // Rprintf("under risk %d %d %d \n",c,id[c],count); for(j=0;j=*pg) pmax=*px; else pmax=*pg; //mat_zeros(Ct); mat_zeros(CGam); vec_zeros(IZHdN); mat_zeros(A); mat_zeros(ZWZ); mat_zeros(XWZ); count=0; sstop=0; for (s=1;s<*Nalltimes;s++){ // Rprintf(" test %d %d %d \n",s,*antpers,*nx); time=alltimes[s]; dtime=time-alltimes[s-1]; stat=0; l=0; stat=0; sstop=0; if (s==1) { for (c=0;c<*nx;c++) { // {{{ if ((start[c]=time)) { for(j=0;jtime) || (stop[c]time) sstop=1; } } /* Rprintf(" s er %d \n",s); print_mat(A); print_mat(ZWZ); print_mat(XWZ); MtA(X,X,A); */ invertS(A,AI,silent[0]); if (ME(AI,0,0)==0 && *silent==0) Rprintf("time %lf X'X singular \n",time); // MtA(Z,Z,ZWZ);MtA(X,Z,XWZ); MxA(AI,XWZ,XWZAI); MtA(XWZAI,XWZ,tmpM2); mat_subtr(ZWZ,tmpM2,dCGam); scl_mat_mult(dtime,dCGam,dCGam); if (*deltaweight==0) { scl_mat_mult(dtime,dCGam,dCGam); } mat_add(CGam,dCGam,CGam); if (stat==1) { // extract_row(X,pers,tmpv1); Mv(AI,xi,AIXWdN); // extract_row(Z,pers,zi); vM(XWZ,AIXWdN,tmpv2); vec_subtr(zi,tmpv2,ZHdN); if (*deltaweight==0) { scl_vec_mult(dtime,ZHdN,ZHdN); } vec_add(ZHdN,IZHdN,IZHdN); } // scl_mat_mult(dtime,XWZAI,tmpM4);mat_add(tmpM4,Ct,Ct); } /* s =1...Ntimes */ /* invertS(CGam,ICGam,silent[0]); Mv(ICGam,IZHdN,gam); if (ME(ICGam,0,0)==0 && *silent==0) Rprintf(" intZHZ singular\n"); print_mat(CGam); print_vec(IZHdN); */ for(k=0;k<*pg;k++) { intZHdN[k]=VE(IZHdN,k); for(j=0;j<*pg;j++) intZHZ[k*(*pg)+j]=ME(CGam,k,j); } free_mats(&X,&A,&AI,&AIXW,&tmpM2,&ZWZ,&ICGam,&CGam,&dCGam, &Ct,&XWZ,&XWZAI, &tmpM4,NULL); free_vecs(&dA,&xi,&tmpv1,&korG,&rowX,&AIXWdN,&zi,&tmpv2,&rowZ,&gam, &ZHdN,&IZHdN,&PLScomp,&Xi,NULL); free(ipers); free(ls); } // }}} timereg/src/smooth2.c0000644000176200001440000000311214421510301014220 0ustar liggesusers//#include #include #include "matrix.h" void smooth2B(double *designX,int *nx,int *p,double *bhat,int *nb,double *b,int *degree,int *coef) //double *designX,*bhat,*b; //int *coef,*nx,*p,*degree,*nb; { matrix *mat1,*mat2,*I,*XWy,*Y,*sm1,*sm2,*sY,*RES; matrix *sm1sm2t; // not in original int med,j,k,s,count,starti=0,d; double x,w; malloc_mats(*nx,*degree+1,&mat1,&mat2,NULL); malloc_mats(*nx,*p-1,&Y,NULL); malloc_mats((*degree+1),*p-1,&XWy,&RES,NULL); malloc_mats((*degree+1),*degree+1,&I,NULL); for (s=0;s<*nb;s++){ med=0; x=bhat[s]; count=0; for (j=starti;((j<*nx) && (designX[j]x-(*b)) && (med==0)) {med=1; starti=j;} if (fabs(designX[j]-x)<*b) { w=tukey(designX[j]-x,*b);/*Rprintf("%lf %lf \n",designX[j]-x,w);*/ ME(mat1,count,0)=1.0; ME(mat2,count,0)=w; for (d=1;d<=*degree;d++) { ME(mat1,count,d)=pow(designX[j]-x,d); ME(mat2,count,d)=w*ME(mat1,count,d); } for (k=1;k<*p;k++){ ME(Y,count,k-1)=w*designX[k*(*nx)+j]; } count=count+1; } } /* */ malloc_mats(count,*degree+1,&sm1,&sm2,NULL); malloc_mats(count,*p-1,&sY,NULL); malloc_mat(count,count,sm1sm2t); mat_subsec(mat1,0,0,count-1,*degree,sm1); mat_subsec(mat2,0,0,count-1,*degree,sm2); mat_subsec(Y,0,0,count-1,*p-2,sY); MtA(sm1,sm2,sm1sm2t); invert(sm1sm2t,I); MtA(sm1,sY,XWy); MxA(I,XWy,RES); for (k=1;k<*p;k++){ bhat[k*(*nb)+s]=ME(RES,*coef,k-1); } free_mats(&sm1,&sm2,&sY,sm1sm2t,NULL); } free_mats(&mat1,&mat2,&Y,&XWy,&RES,&I,NULL); } timereg/src/prop-odds-subdist2.c0000644000176200001440000005555014421510301016306 0ustar liggesusers#include #include #include #include "matrix.h" #include #include void posubdist2(double *times,int *Ntimes,double *designX,int *nx,int *px,int *antpers,double *start,double *stop,double *betaS,int *Nit,double *cu,double *vcu,double *Iinv, double *Vbeta,int *detail,int *sim,int *antsim,int *rani,double *Rvcu,double *RVbeta,double *test,double *testOBS,double *Ut,double *simUt,double *Uit,int *id,int *status, int *weighted,int *ratesim,double *score,double *dhatMit,double *dhatMitiid,int *retur,double *loglike,int *profile,int *sym, double *KMtimes,double *KMti,double *etime,int *causeS,int *ipers,int *baselinevar,int *clusters,int *antclust,int *ccode,double *biid,double *gamiid,double *wweights) //double *designX,*times,*betaS,*start,*stop,*cu,*Vbeta,*RVbeta,*vcu,*Rvcu,*Iinv,*test,*testOBS,*Ut,*simUt,*Uit,*score,*dhatMit,*dhatMitiid,*loglike, // *KMtimes,*KMti,*etime,*biid,*gamiid,*wweights; //int *nx,*px,*antpers,*Ntimes,*Nit,*detail,*sim,*antsim,*rani,*id,*status,*weighted,*ratesim,*retur,*profile,*sym,*causeS,*ipers,*baselinevar,*clusters,*antclust,*ccode; { // {{{ setting up matrix *ldesignX,*WX,*ldesignG,*CtVUCt,*A,*AI; matrix *dYI,*Ct,*dM1M2,*M1M2t,*COV,*ZX,*ZP,*ZPX; matrix *tmp1,*tmp2,*tmp3,*dS1,*SI,*dS2,*S2,*S2pl,*dS2pl,*M1,*VU,*ZXAI,*VUI; matrix *d2S0,*RobVbeta,*tmpM1,*Utt,*dS0t,*S1start,*tmpM2,*et,*gt,*qt; matrix *St[*Ntimes],*M1M2[*Ntimes],*C[*Ntimes],*ZXAIs[*Ntimes],*dYIt[*Ntimes]; matrix *dotwitowit[*antpers], // *W3tmg[*antclust], *W3t[*antclust],*W4t[*antclust],*W2t[*antclust],*AIxit[*antpers],*Uti[*antclust],*d2G[*Ntimes],*Delta,*Delta2; vector *Ctt,*lht,*S1,*dS0,*incS0t,*S0t,*S0start,*dA,*VdA,*dN,*MdA,*delta,*zav,*dlamt,*plamt,*dG[*Ntimes], *S1star; vector *xav,*difxxav,*xi,*zi,*U,*Upl,*beta,*xtilde; vector *Gbeta,*zcol,*one,*difzzav,*difZ,*neta2[*antclust]; vector *offset,*weight,*ZXdA[*Ntimes],*varUthat[*Ntimes],*Uprofile; vector *ahatt,*risk,*tmpv1,*tmpv2,*rowX,*rowZ,*difX,*VdB,*VdBmg; vector *W2[*antclust],*W3[*antclust],*reszpbeta,*res1dim,*dAt[*Ntimes],*eta2; // vector *W2[*antclust],*W3[*antclust],*W3mg[*antclust],*reszpbeta,*res1dim,*dAt[*Ntimes],*eta2; vector *dLamt[*antpers]; int *pg=calloc(1,sizeof(int)),c,robust=1,pers=0,ci,i,j,k,l,s,it; double weights,risks,RR,S0star,time,alpha,ll; double S0,tau,random,scale,sumscore; // double norm_rand(); // void GetRNGstate(),PutRNGstate(); pg[0]=1; for (j=0;j<*antpers;j++) { malloc_vec(*Ntimes,dLamt[j]); malloc_mat(*Ntimes,*px,dotwitowit[j]); malloc_mat(*Ntimes,*px,AIxit[j]); } for (j=0;j<*antclust;j++) { malloc_mat(*Ntimes,*pg,W3t[j]); // malloc_mat(*Ntimes,*pg,W3tmg[j]); malloc_mat(*Ntimes,*pg,W4t[j]); malloc_mat(*Ntimes,*px,W2t[j]); malloc_mat(*Ntimes,*px,Uti[j]); malloc_vec(*px,W2[j]); malloc_vec(*pg,W3[j]); // malloc_vec(*pg,W3mg[j]); malloc_vec(*Ntimes,neta2[j]) } malloc_mat(*Ntimes,*pg,tmpM1); malloc_mat(*Ntimes,*px,dS0t); malloc_mat(*Ntimes,*px,tmpM2); malloc_mat(*Ntimes,*px,S1start); malloc_mat(*Ntimes,*px,et); malloc_mat(*Ntimes,*px,gt); malloc_mat(*Ntimes,*px,qt); malloc_mat(*Ntimes,*px,Utt); malloc_mat(*Ntimes,*pg,Delta); malloc_mat(*Ntimes,*px,Delta2); malloc_mats(*antpers,*px,&WX,&ldesignX,NULL); malloc_mats(*antpers,*pg,&ZP,&ldesignG,NULL); malloc_mats(*px,*px,&COV,&A,&AI,&M1,&CtVUCt,NULL); malloc_mats(*px,*px,&d2S0,&RobVbeta,&tmp1,&tmp2,&dS1,&S2,&dS2,&S2pl,&dS2pl,&SI,&VU,&VUI,NULL); malloc_mats(*pg,*px,&ZXAI,&ZX,&dM1M2,&M1M2t,NULL); malloc_mats(*px,*pg,&tmp3,&ZPX,&dYI,&Ct,NULL); malloc_vec(*Ntimes,S0t); malloc_vec(*Ntimes,incS0t); malloc_vec(*Ntimes,eta2); malloc_vec(*Ntimes,S0start); malloc_vec(*Ntimes,lht); malloc_vec(1,reszpbeta); malloc_vec(1,res1dim); malloc_vecs(*antpers,&risk,&weight,&plamt,&dlamt,&dN,&zcol,&Gbeta,&one,&offset,NULL); malloc_vecs(*px,&Ctt,&ahatt,&tmpv1,&difX,&rowX,&xi,&dA,&VdA,&MdA,NULL); malloc_vecs(*px,&S1,&dS0,&S1star,&xtilde,&xav,&difxxav,NULL); malloc_vecs(*px,&U,&Upl,&beta,&delta,&difzzav,&Uprofile,NULL); malloc_vecs(*pg,&tmpv2,&rowZ,&zi,&difZ,&zav,&VdB,&VdBmg,NULL); for(j=0;j<*Ntimes;j++) { malloc_mat(*px,*pg,C[j]); malloc_mat(*pg,*px,M1M2[j]); malloc_mat(*pg,*px,ZXAIs[j]); malloc_mat(*px,*pg,dYIt[j]); malloc_vec(*px,dAt[j]); malloc_vec(*pg,ZXdA[j]); malloc_mat(*px,*px,St[j]); malloc_mat(*px,*px,d2G[j]); malloc_vec(*px,dG[j]); malloc_vec(*px,varUthat[j]); } ll=0; for(j=0;j<*px;j++) VE(beta,j)=betaS[j]; // }}} int timing=0; clock_t c0,c1; c0=clock(); double dummy,plamtj,dlamtj,weightp=0; // reading design once and for all for (c=0;c<*nx;c++) for(j=0;j<*px;j++) ME(WX,id[c],j)=designX[j*(*nx)+c]; cu[0]=times[0]; for (it=0;it<*Nit;it++) { // {{{ vec_zeros(U); vec_zeros(Upl); mat_zeros(S2pl); mat_zeros(S2); mat_zeros(COV); ll=0; sumscore=0; R_CheckUserInterrupt(); Mv(WX,beta,Gbeta); for (s=1;s<*Ntimes;s++) {// {{{ time=times[s]; pers=ipers[s]; // person with type 1 jump // printf(" pers=%d weight=%lf cause=%d \n",pers,wweights[pers],status[pers]); vec_zeros(dS0); mat_zeros(d2S0); mat_zeros(dS1); vec_zeros(S1star); vec_zeros(S1); S0star=0; S0=0; // S0p=0; S0cox=0; weightp=1; for (j=0;j<*antpers;j++) { // {{{ int other=((status[j]!=*causeS) && (status[j]!=*ccode))*1; weights=1; if (etime[j]