relsurv/0000755000176200001440000000000014746176252011772 5ustar liggesusersrelsurv/MD50000644000176200001440000000727414746176252012314 0ustar liggesusers3733a8386b2190d0e135573cc7de9bac *DESCRIPTION eb5fe17e9df6d20471829678a3029820 *NAMESPACE f64a3d4d43c5cf4089d8d0d7e060154a *R/Rcode.r 18f2da677fcfa9d26e0cf3733d0a14c5 *R/RcppExports.R 90f14d8947f5b361ce9ec8efa73aae28 *R/cmprel.r c90fe0af1a20d1264a61f7d90d77e670 *R/dLambdaP.R 476d5effd3aff473f5ce65717dd4551a *R/mystrata.r e8c5220a2b671c39c0be09d5991f5aae *R/plotrssurv.r 032740e77c8f550b10ca7cf21918f9af *R/popsurv.R 90deb862d7eaa6f767b3f81ba3ef0703 *R/predict.aalen.relsurv.R 23aa022e053c307521db26cc00734632 *R/predict.rsadd.R d9a2e418b112e5f0d2503335da88f181 *R/ratetable_add_vals.R 87325f93123dd43c4dbe81493e784f9d *R/rformulate.r ee0265466ea110bde459f577a29bd497 *R/rformulate2.r 9014676da9b166a109a81d1a47972882 *R/rsaalen.R 18b0a9aa16dbb131ffb9af62b6d3c805 *R/rsdiff.r 2870af9e8baefdb36cf2d2aa7b43fa06 *R/rssurvrsadd.r 9791eeca7f661a70cdb7bb7e8f829ef2 *R/survaalen.R ad6a3841c5ca78ebce134d96d7092193 *R/survfitrsadd.r 5601e2ac5782d27cfbca32f783b18840 *R/years.R 89fce227e95ea05d61202937dd4c2924 *R/zzz.R 2f582cf1a03223ce54f7b64ce0b4d4d3 *data/colrec.rda d305671f142f259237eabddd2eba54d9 *data/ebmt1wide.rda a37dab9cfd9a03748d7345b819aa57d6 *data/rdata.rda b095651e528285a392843423b6e48de8 *data/slopop.rda 89f161383f120588561c63f7b2f8e7fd *inst/CITATION 8a83e32924e90b4ef972df23bac85c5f *inst/news.Rd 3a2c172f38ee0239b2de982f55452aa6 *man/cmp.rel.Rd e9e43bae88190dd04b902a6e3e4e702c *man/colrec.Rd f5395249d92e04bd9b13d70c3b7953af *man/ebmt1wide.Rd 58a612592ef883ffe1fbe1279f5f76aa *man/epa.Rd e975a463bfb1321932fd65179d4e4f93 *man/expprep2.Rd 5502fadcd140775208d16b1d48f7d49e *man/invtime.Rd 1f40240c08dfb5a71f815361fa65f7e5 *man/joinrate.Rd 8c8ed76ce8831ad0b0c3cfe08518c0b5 *man/nessie.Rd 20bce6009224687971766e0eda63e94a *man/plot.cmp.rel.Rd d48eb82ecd85f409ebbe3e92ab9c0998 *man/plot.rs.zph.Rd c423cc2e6bf6fb5b01cf7cf1bc241ae8 *man/plot_f.Rd b22263efa2422f2d070f970cb7938981 *man/plot_years.Rd 6c51b130f952d72560bf630ac1f38234 *man/popsurv.Rd cb9b310db2d357bb14c324fc3e59fd2d *man/predict.rsadd.Rd c28a88ecfa1f891e98c8fc9ef7566e55 *man/rdata.Rd 6250388945cd3d7d16d350ffdefbc776 *man/residuals.rsadd.Rd f9c97c4a0155e5369b7f3b6efea06f86 *man/rs.br.Rd 529c1371c8eb013a41c6ed1bf9aeff11 *man/rs.diff.Rd 3b3bcb10e4c72963fab85c18800d615a *man/rs.surv.Rd a5550fbce8a033141948f85d4f6c1eab *man/rs.surv.rsadd.Rd 71b9611b79c55318c01aa0e18fbe7689 *man/rs.zph.Rd fd92494a8b60113781a1495bc997a4c6 *man/rsaalen.Rd a6697d0d9ef50d20df717adc1e24b916 *man/rsadd.Rd d9f99576c5183fb661ef83416b7e7011 *man/rsmul.Rd 8efa1879808465a58bfa105b836e1298 *man/rstrans.Rd be655c8edf2364de4cc91c03c6e61487 *man/slopop.Rd 60780237065db36a7286faa8d65ac9db *man/summary.cmp.rel.Rd 0f56f48020fce5e21fba9ef09f6739bf *man/survaalen.Rd cbfa220e137d653bb298d6f190d7c163 *man/survfit.rsadd.Rd 4cb1abb7ba7c0f1cf507a718be8f3308 *man/survsplit.Rd 2ab7a8b43000774d1b441119c0402f7b *man/transrate.Rd db4dfd9c243277e69e98f06719978715 *man/transrate.hld.Rd 98dcd12d9a56835ee73a1e89fe0bfd88 *man/transrate.hmd.Rd 1ed78f04aafd82e135145d581eb6c53c *man/years.Rd 6265bc44ff630fbefabbc6506ba550b7 *src/Makevars 6265bc44ff630fbefabbc6506ba550b7 *src/Makevars.win 71e4e4e99b782d316ab494890d1b4836 *src/RcppExports.cpp 1b0f693a564d29eb03f50d04582c4df9 *src/aalen_beta.cpp 905d41c845358123bdb6790e7eac6d71 *src/cmpfast.c 6853ad4d02cc6b1ff9e2e786f7dad4b5 *src/dmatrix.c 35fe86cf308d11c704de3aaf3e58a629 *src/exps.c 290f6dc48600c3b032c675d00f1e34f0 *src/netfastp.c cf08c1197fb1785378c385b0430c5170 *src/netfastpinter.c 40b37675819c028869b525f1b01ca354 *src/netfastpinter2.c efc2b2569dbe343bd85568e4303b3296 *src/netwei.c cc28deac6535fac9ab5b4be0121035c7 *src/netweiDM.c dc827fc540501192a675ffb139f9da33 *src/pystep.c 93bdb0c6d09be683150878f866cf1730 *src/pystep2.c 6e2403b71ca2b54fddac291e40163574 *src/survprotomoj.h relsurv/R/0000755000176200001440000000000014746172543012172 5ustar liggesusersrelsurv/R/RcppExports.R0000644000176200001440000000146214746172543014611 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 Yt <- function(data, times) { .Call(`_relsurv_Yt`, data, times) } dNt <- function(data, times) { .Call(`_relsurv_dNt`, data, times) } prepareX <- function(Yt, xt) { .Call(`_relsurv_prepareX`, Yt, xt) } fitOLS <- function(mX, dNt, Yt) { .Call(`_relsurv_fitOLS`, mX, dNt, Yt) } fitOLS2 <- function(mX, dNt, Yt) { .Call(`_relsurv_fitOLS2`, mX, dNt, Yt) } fitOLSconst <- function(mX, mZ, dNt, Yt) { .Call(`_relsurv_fitOLSconst`, mX, mZ, dNt, Yt) } rcpp_unlist <- function(listObject) { .Call(`_relsurv_rcpp_unlist`, listObject) } build_array3 <- function(x, dimensions) { .Call(`_relsurv_build_array3`, x, dimensions) } relsurv/R/ratetable_add_vals.R0000644000176200001440000000702014712412167016104 0ustar liggesusersratetable_add_vals <- function(ratetable, add.years=c(), add.ages=c()){ # The function takes a ratetable and adds years and ages to the object. # New attribute object: newat <- attributes(ratetable) # Find dates (3 or 4 values): wh_date <- newat$type>=3 # Find ages: wh_age <- newat$type==2 # Find unique years/ages not present in the ratetable: add.years <- add.years[!(add.years %in% newat$dimnames$year)] add.ages <- add.ages[!(add.ages %in% newat$dimnames$age)] # All years: nova_leta <- sort(c(add.years, newat$dimnames$year)) nove_starosti <- as.character(sort(as.integer(c(add.ages, newat$dimnames$age)))) # Find where the new years appear: m_nova_leta <- match(nova_leta, add.years, nomatch = 0) m_nove_starosti <- match(nove_starosti, add.ages, nomatch = 0) # Adjust newat object: newat$dimnames$year <- nova_leta newat$dim[wh_date] <- length(nova_leta) if(length(add.years)>0) newat$cutpoints[[which(wh_date)]] <- sort(c(newat$cutpoints[[which(newat$dimid=='year')]], as.Date(paste0(add.years, '-01-01')))) # newat$cutpoints[[which(wh_date)]] <- as.date(newat$cutpoints[[which(wh_date)]]) newat$dimnames$age <- nove_starosti newat$dim[wh_age] <- length(nove_starosti) newat$cutpoints[[which(wh_age)]] <- sort(c(newat$cutpoints[[which(newat$dimid=='age')]], as.integer(add.ages)*365.241)) # prepare vecs: vecs <- vector("list", length=length(newat$type)) for(i in 1:length(newat$type)){ vecs[[i]] <- 1:newat$dim[i] } # Define new ratetable: out <- array(NA, dim=newat$dim) # Add values for existing columns: out[m_nove_starosti==0,m_nova_leta==0,] <- ratetable # YEAR: For remaining columns either take earlier or later values: wh_diff0 <- which(m_nova_leta!=0) wh_eq0 <- which(m_nova_leta==0) for(ay in wh_diff0){ # If first year: if(ay==1){ possible_val <- wh_eq0[aywh_eq0] if(length(possible_val)>0){ choose_year <- max(possible_val) # Except if there is no last year, then take next year: } else{ possible_val <- wh_eq0[aywh_eq0] if(length(possible_val)>0){ choose_age <- max(possible_val) # Except if there is no last age, then take next age: } else{ possible_val <- wh_eq0[ay% head() # # newrt[,"1930",] %>% head() # identical(newrt[,"1920",], newrt[,"1930",]) # identical(newrt[,"1950",], newrt[,"1948",]) # identical(newrt[,"2024",], newrt[,"2021",]) relsurv/R/predict.aalen.relsurv.R0000644000176200001440000000274514742212170016522 0ustar liggesuserspredict.aalen.relsurv <- function(object, newdata, ...){ # object: an aalen.model object # newdata: data.frame with one row, in columns add covariate values. # subject-specific prediction. # Zaenkrat delamo z object$times. Treba bo dodati se add.times. Ta add.times bo verjetno v rsadd lin.pred <- object$coefficients[,2] if(ncol(object$coefficients) >= 3){ for(cov in colnames(object$coefficients)[3:length(colnames(object$coefficients))]){ lin.pred <- lin.pred + newdata[1,cov]*object$coefficients[,cov] } } # haz_function(object$formula, rdata, object$ratetable, rmap=list(age=age*365.241), add.times=0, include.all.times = FALSE) kar <- deparse(object$formula[[2]]) autkam <- gsub(' ', '', strsplit(substr(kar, start = 6, stop=nchar(kar)-1), ',')[[1]]) newdata_2 <- data.frame(matrix(1, nrow=1, ncol=length(autkam))) if(length(autkam)==3) newdata_2[,1] <- 0 colnames(newdata_2) <- autkam newdata_2 <- cbind(newdata, newdata_2) rform <- suppressWarnings(rformulate(object$formula, newdata_2, object$ratetable, stats::na.omit(), rmap = object$rmap)) fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) pop.surv <- sapply(1:nrow(object$coefficients), function(i) exp_prep(rform$data[1, 4:(nfk + 3), drop = FALSE], object$coefficients[i,1], object$ratetable)) Haz.p <- -log(pop.surv) data.frame(time=object$coefficients[,1], Haz.e=lin.pred, Haz.p=Haz.p) } relsurv/R/cmprel.r0000644000176200001440000004415414742212233013632 0ustar liggesusers#' Compute crude probability of death #' #' Estimates the crude probability of death due to disease and due to #' population reasons #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' Note that numerical integration is required to calculate the variance #' estimator. The integration precision is set with argument \code{precision}, #' which defaults to daily intervals, a default that should give enough #' precision for any practical purpose. #' #' The area under the curve is calculated on the interval [0,\code{tau}]. #' #' Function \code{summary} may be used to get the output at specific points in #' time. #' #' @aliases cmp.rel print.cmp.rel #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. If no strata are used, \code{~1} should be #' specified. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param tau the maximum follow-up time of interest, all times larger than #' \code{tau} shall be censored. Equals maximum observed time by default #' @param conf.int the level for a two-sided confidence interval on the #' survival curve(s). Default is 0.95. #' @param precision the level of precision used in the numerical integration of #' variance. Default is 1, which means that daily intervals are taken, the #' value may be decreased to get a higher precision or increased to achieve a #' faster calculation. The calculation intervals always include at least all #' times of event and censoring as border points. #' @param add.times specific times at which the value of estimator and its #' variance should be evaluated. Default is all the event and censoring times. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @return An object of class \code{cmp.rel}. Objects of this class have #' methods for the functions \code{print} and \code{plot}. The \code{summary} #' function can be used for printing output at required time points. An object #' of class \code{cmp.rel} is composed of several lists, each pertaining the #' cumulative hazard function for one risk and one strata. Each of the lists #' contains the following objects: \item{time}{the time-points at which the #' curves are estimated} \item{est}{the estimate} \item{var}{the variance of #' the estimate} \item{lower}{the lower limit of the confidence interval} #' \item{upper}{the upper limit of the confidence interval} \item{area}{the #' area under the curve calculated on the interval [0,\code{tau}]} #' \item{index}{indicator of event and censoring times among all the times in #' the output. The times added via paramater \code{add.times} are also #' included} \item{add.times}{the times added via parameter \code{add.times}} #' @seealso \code{rs.surv}, \code{summary.cmp.rel} #' @references Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric #' Relative Survival Analysis with the R Package relsurv". Journal of #' Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" #' @keywords survival #' @examples #' #' #' data(slopop) #' data(rdata) #' #calculate the crude probability of death #' #note that the variable year must be given in a date format and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- cmp.rel(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,tau=3652.41) #' fit #' plot(fit,col=c(1,1,2,2),xscale=365.241,xlab="Time (years)") #' #if no strata are desired: #' fit <- cmp.rel(Surv(time,cens)~1,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,tau=3652.41) #' #' #' cmp.rel <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action,tau,conf.int=0.95,precision=1,add.times,rmap) #formula: for example Surv(time,cens)~1 #not implemented for subgroups - DO IT! #data: the observed data set #ratetable: the population mortality tables #conf.type: confidence interval calculation (plain, log or log-log) #conf.int: confidence interval #tau: max. cas do katerega racuna { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action,rmap) #get the data ready data <- rform$data #the data set se.fac <- sqrt(qchisq(conf.int, 1)) #factor needed for confidence interval if(missing(tau)) tau<-max(rform$Y) p <- rform$m #number of covariates if (p > 0) #if covariates data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make strata according to covariates else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 tab.strata <- table(data$Xs) #unique strata values ntab.strata <- length(tab.strata) #number of strata dtemp <- list(NULL) out <- as.list(rep(dtemp,ntab.strata*2)) for (kt in 1:ntab.strata) { #for each stratum inx <- which(data$Xs == names(tab.strata)[kt]) #individuals within this stratum extra <- as.numeric(seq(1,max(rform$Y[inx]),by=precision)) if(!missing(add.times)) extra <- c(extra,as.numeric(add.times)) tis <- sort(unique(pmin(tau,union(rform$Y[inx],extra))) ) #1-day long intervals used - to take into the account the continuity of the pop. part #if(!all.times)tis <- sort(unique(pmin(rform$Y[inx],tau))) #unique times #else{ # tis <- sort(union(rform$Y[inx], as.numeric(1:floor(max(rform$Y[inx]))))) #1-day long intervals used - to take into the account the continuity of the pop. part # tis <- unique(pmin(tis,tau)) #} k <- length(tis) out[[2*kt-1]]$time <- out[[2*kt]]$time <- c(0,tis) temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE,cmp=T) #calculate the values for each interval of time areae <- sum(temp$areae)/365.241 # sum(diff(c(0,tis))*temp$cumince)/365.241 areap <- sum(temp$areap)/365.241 #sum(diff(c(0,tis))*temp$cumincp)/365.241 options(warn=-1) out[[2*kt-1]]$est <- c(0,temp$cumince) out[[2*kt-1]]$var <- c(0,temp$ve) out[[2*kt-1]]$lower <- temp$cumince-se.fac*sqrt(temp$ve) out[[2*kt-1]]$upper <- temp$cumince+se.fac*sqrt(temp$ve) out[[2*kt-1]]$area <- areae out[[2*kt]]$est <- c(0,temp$cumincp) out[[2*kt]]$var <- c(0,temp$vp) out[[2*kt]]$lower <- temp$cumincp-se.fac*sqrt(temp$vp) out[[2*kt]]$upper <- temp$cumincp+se.fac*sqrt(temp$vp) out[[2*kt]]$area <- areap options(warn=0) ne <- sum(temp$ve<0) if(ne>0) warning(paste(names(tab.strata)[kt],": The estimated variance of crude mortality is negative in ", ne, " out of ", length(temp$ve)," intervals"), call. = FALSE) if(!missing(add.times)){ out[[2*kt-1]]$index <- out[[2*kt]]$index <- unique(c(1,which(tis %in% c(rform$Y[inx],add.times,tau)))) out[[2*kt-1]]$add.times <- out[[2*kt]]$add.times <- add.times } else out[[2*kt-1]]$index <- out[[2*kt]]$index <- unique(c(1,which(tis %in% c(rform$Y[inx],tau)))) } if(p>0)names(out) <- paste(rep(c("causeSpec","population"),ntab.strata),rep(names(tab.strata),each=2)) else names(out) <- c("causeSpec","population") out$tau <- tau class(out) <- "cmp.rel" out } #' Plot the crude probability of death #' #' Plot method for cmp.rel. Plots the cumulative probability of death due to #' disease and due to population reasons #' #' By default, the graph is plotted as a step function for the cause specific #' mortality and as a piecewise linear function for the population mortality. #' It is evaluated at all event and censoring times even though it constantly #' changes also between these time points. #' #' If the argument \code{all.times} is set to \code{TRUE}, the plot is #' evaluated at all times that were used for numerical integration in the #' \code{cmp.rel} function (there, the default is set to daily intervals). If #' only specific time points are to be added, this should be done via argument #' \code{add.times} in \code{cmp.rel}. #' #' @param x a list, with each component representing one curve in the plot, #' output of the function \code{cmp.rel}. #' @param main the main title for the plot. #' @param curvlab Curve labels for the plot. Default is \code{names(x)}, or if #' that is missing, \code{1:nc}, where \code{nc} is the number of curves in #' \code{x}. #' @param ylim yaxis limits for plot. #' @param xlim xaxis limits for plot (default is 0 to the largest time in any #' of the curves). #' @param wh if a vector of length 2, then the upper right coordinates of the #' legend; otherwise the legend is placed in the upper right corner of the #' plot. #' @param xlab X axis label. #' @param ylab y axis label. #' @param lty vector of line types. Default \code{1:nc} (\code{nc} is the #' number of curves in \code{x}). For color displays, \code{lty=1}, #' \code{color=1:nc}, might be more appropriate. If \code{length(lty) 0) { i <- pmatch(names(u), names(formals(legend)), 0) do.call("legend", c(list(x = wh[1], y = wh[2], legend = curvlab[curves], col = col[curves], lty = lty[curves], lwd = lwd[curves], bty = "n", bg = -999999), u[i > 0])) } else { do.call("legend", list(x = wh[1], y = wh[2], legend = curvlab[curves], col = col[curves], lty = lty[curves], lwd = lwd[curves], bty = "n", bg = -999999)) } for(i in conf.int){ if(i%%2==0)with(x[[i]],polygon(c(time[index][!is.na(lower[index])],rev(time[index][!is.na(upper[index])]))/xscale,c(lower[index][!is.na(lower[index])],rev(upper[index][!is.na(upper[index])])),col = col.conf.int[i] , border = FALSE)) else with(x[[i]],my.poly(time[index][!is.na(lower[index])]/xscale,time[index][!is.na(upper[index])]/xscale,lower[index][!is.na(lower[index])],upper[index][!is.na(upper[index])],col = col.conf.int[i] , border = FALSE)) } for (i in curves) { tip <- "s" if(i%%2==0)tip <- "l" lines((x[[i]][[1]]/xscale)[x[[i]]$index], (x[[i]][[2]])[x[[i]]$index], lty = lty[i], col = col[i], lwd = lwd[i], type=tip, ...) } } my.poly <- function(x1,x2,y1,y2,...){ x1 <- rep(x1,each=2)[-1] y1 <- rep(y1,each=2)[-(2*length(y1))] x2 <- rep(x2,each=2)[-1] y2 <- rep(y2,each=2)[-(2*length(y2))] polygon(c(x1,rev(x2)),c(y1,rev(y2)),...) } print.cmp.rel <- function (x, ntp = 4, maxtime,scale=365.241, ...) { tau <- x$tau x$tau <- NULL nc <- length(x) if (missing(maxtime)) { maxtime <- 0 for (i in 1:nc) maxtime <- max(maxtime, x[[i]]$time) } tp <- pretty(c(0, maxtime/scale), ntp + 1) tp <- tp[-c(1, length(tp))] if(length(x[[1]]$add.times)>0 & length(x[[1]]$add.times)<5){ tp <- sort(unique(c(tp,round(x[[1]]$add.times/scale,1)))) } cat("Estimates, variances and area under the curves:\n") x$tau <- tau print(summary(x, tp,scale,area=TRUE), ...) invisible() } #' Summary of the crude probability of death #' #' Returns a list containing the estimated values at required times. #' #' The variance is calculated using numerical integration. If the required time #' is not a time at which the value was estimated, the value at the last time #' before it is reported. The density of the time points is set by the #' \code{precision} argument in the \code{cmp.rel} function. #' #' @param object output of the function \code{cmp.rel}. #' @param times the times at which the output is required. #' @param scale The time scale in which the times are specified. The default #' value is \code{1}, i.e. days. #' @param area Should area under the curves at time \code{tau} be printed out? #' Default is \code{FALSE}. #' @param ... Additional arguments, currently not implemented #' @return A list of values is returned. #' @seealso \code{cmp.rel} #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #calculate the crude probability of death and summarize it #' fit <- cmp.rel(Surv(time,cens)~sex,rmap=list(age=age*365), #' ratetable=slopop,data=rdata,tau=3652.41) #' summary(fit,c(1,3),scale=365.241) #' summary.cmp.rel <- function (object, times,scale=365.241,area=FALSE,...) { tau <- object$tau object$tau <- NULL ng <- length(object) times <- sort(unique(times))*scale nt <- length(times) storage.mode(times) <- "double" storage.mode(nt) <- "integer" ind <- matrix(0, ncol = nt, nrow = ng) oute <- matrix(NA, ncol = nt, nrow = ng) outv <- oute outa <- matrix(NA,ncol=1,nrow=ng) storage.mode(ind) <- "integer" slct <- rep(TRUE, ng) for (i in 1:ng) { if (is.null((object[[i]])$est)) { slct[i] <- FALSE } else { z <- rep(NA,nt) for(kt in 1:nt)z[kt] <- rev(which(object[[i]][[1]]<=times[kt]))[1] ind[i, ] <- z oute[i, ind[i, ] > 0] <- object[[i]][[2]][z] outa[i,] <- object[[i]][[6]] if (length(object[[i]]) > 2) outv[i, ind[i, ] > 0] <- object[[i]][[3]][z] } } dimnames(oute) <- list(names(object)[1:ng], as.character(times/scale)) dimnames(outv) <- dimnames(oute) rownames(outa) <- rownames(oute) colnames(outa) <- paste("Area at tau =",tau/scale) if(area)list(est = oute[slct, , drop = FALSE], var = outv[slct, , drop = FALSE], area=outa[slct,,drop=FALSE]) else list(est = oute[slct, , drop = FALSE], var = outv[slct, , drop = FALSE]) } relsurv/R/zzz.R0000644000176200001440000000532114742212472013143 0ustar liggesusers#.First.lib <- function(lib, pkg) library.dynam("runproba", pkg, lib) # use .onLoad instead of .First.lib for use with NAMESPACE and R(>= 1.7.0) .onLoad <- function(lib, pkg) { # library.dynam <- function (chname, package, lib.loc, verbose = getOption("verbose"), # file.ext = .Platform$dynlib.ext, ...) # { # dll_list <- .dynLibs() # if (missing(chname) || !nzchar(chname)) # return(dll_list) # package # lib.loc # r_arch <- .Platform$r_arch # chname1 <- paste0(chname, file.ext) # # browser() # for (pkg in "C:/Users/dame_/Dropbox (MF Uni LJ)/Damjan Manevski/Research/relsurv/relsurv_2.2-5"){ # #find.package('relsurv_2.2-5', lib.loc, verbose = verbose)) { # DLLpath <- if (nzchar(r_arch)) # # file.path(pkg, "libs", r_arch) # "C:/Users/dame_/Dropbox (MF Uni LJ)/Damjan Manevski/Research/relsurv/relsurv_2.2-5/src" # else file.path(pkg, "libs") # # file <- file.path(DLLpath, chname1) # file <- "C:/Users/dame_/Dropbox (MF Uni LJ)/Damjan Manevski/Research/relsurv/relsurv_2.2-5/src/relsurv.dll" # # browser() # if (file.exists(file)) # break # else file <- "" # } # if (file == "") # if (.Platform$OS.type == "windows") # stop(gettextf("DLL %s not found: maybe not installed for this architecture?", # sQuote(chname)), domain = NA) # else stop(gettextf("shared object %s not found", sQuote(chname1)), # domain = NA) # # browser() # file <- file.path(normalizePath(DLLpath, "/", TRUE), chname1) # ind <- vapply(dll_list, function(x) x[["path"]] == file, # NA) # if (length(ind) && any(ind)) { # if (verbose) # if (.Platform$OS.type == "windows") # message(gettextf("DLL %s already loaded", sQuote(chname1)), # domain = NA) # else message(gettextf("shared object '%s' already loaded", # sQuote(chname1)), domain = NA) # return(invisible(dll_list[[seq_along(dll_list)[ind]]])) # } # if (.Platform$OS.type == "windows") { # PATH <- Sys.getenv("PATH") # Sys.setenv(PATH = paste(gsub("/", "\\\\", DLLpath), # PATH, sep = ";")) # on.exit(Sys.setenv(PATH = PATH)) # } # if (verbose) # message(gettextf("now dyn.load(\"%s\") ...", file), # domain = NA) # dll <- if ("DLLpath" %in% names(list(...))) # dyn.load(file, ...) # else dyn.load(file, DLLpath = DLLpath, ...) # .dynLibs(c(dll_list, list(dll))) # invisible(dll) # } library.dynam("relsurv", pkg, lib) }#end of .onLoad relsurv/R/dLambdaP.R0000644000176200001440000000447114742212410013747 0ustar liggesusersdLambdaPR <- function(data, all_times, event_times, ratetable, atts){ # Objects for exp_prep / expc: fk <- (atts$factor != 1) nfk <- length(fk) cuts <- atts$cutpoints ltype <- length(atts$type) rfac <- rep(0, ltype) for(i in 1:ltype){ if(atts$type[i]==1) rfac[i] <- 1 } rfac <- as.integer(rfac) # rfac <- ifelse(atts$type == 1, 1, 0) adim <- atts$dim acuts <- unlist(cuts) Yt_all <- Yt(data, all_times) ltimes <- length(all_times) nr <- nrow(data) data_m <- as.matrix(data) # outcome <- vector("list", length = ltimes) outcome <- matrix(0, nrow=nr, ncol=ltimes) for(i in 1:ltimes){ if(i==1){ if(all_times[i]==0) next tstart <- 0 } else{ tstart <- all_times[i-1] } tstop <- all_times[i] # ord_id <- order(data$Y) # data <- data[ord_id, ] wh_at_risk <- (Yt_all[[i]] == 1) data_tmp <- data_m[wh_at_risk, 4:(nfk + 3), drop = FALSE] data_tmp[,fk] <- data_tmp[,fk]+tstart # pop_survs <- exp_prep(data_tmp, # rep(tstop-tstart, sum(wh_at_risk)), # ratetable) times <- rep(tstop-tstart, sum(wh_at_risk)) temp <- .Call("expc", rfac, adim, acuts, ratetable, data_tmp, times, PACKAGE = "relsurv") pop_survs <- temp$surv # for(j in 1:nr){ # if(Yt_all[[i]][j] == 1){ # outcome[j,i] <- 1 # pop hazard v tem intervalu # xx <- exp_prep(data[j, 4:(nfk + 3), drop = FALSE], data$Y - # data$start, ratetable) # } # } outcome[wh_at_risk, i] <- -log(pop_survs) } # Cum hazards: outcome <- t(apply(outcome, 1, cumsum)) # Hazards at event times only: # whe <- which(all_times %in% event_times) # outcome <- outcome[, whe] # Add additional zeros for time 0 (for diffs in hazard): outcome <- cbind(rep(0, nrow(outcome)), outcome) return(outcome) } # exp_prep(x,y,ratetable,status,times,fast=FALSE,ys,prec,cmp=F,netweiDM=FALSE) # # jee <- exp_prep(rform$R, rform$Y, rform$ratetable, rform$status, all_times, fast=FALSE, data$start, 1, FALSE, netweiDM=FALSE) # # jee <- exp_prep(rform$R, rform$Y, rform$ratetable, rform$status, all_times[1:2], fast=FALSE, data$start, 1, FALSE, netweiDM=FALSE) relsurv/R/rformulate2.r0000644000176200001440000001752414562671364014631 0ustar liggesusers# Like rformulate, just does not use ratetable/rmap and the remaining relsurv components rformulate2 <- function (formula, data = parent.frame(), ratetable, na.action, rmap, int, centered, cause) { call <- match.call() m <- match.call(expand.dots = FALSE) # keep the parts of the call that we want, toss others m <- m[c(1, match(c("formula", "data", "cause"), names(m), nomatch=0))] m[[1L]] <- quote(stats::model.frame) # per CRAN, the formal way to set it Terms <- if (missing(data)) terms(formula, specials= c("strata","ratetable")) else terms(formula, specials=c("strata", "ratetable"), data = data) Term2 <- Terms # #sorting out the ratetable argument - matching demographic variables # rate <- attr(Terms, "specials")$ratetable # if (length(rate) > 1) # stop("Can have only 1 ratetable() call in a formula") # #matching demographic variables via rmap # if (!missing(rmap)) { # use this by preference # if (length(rate) >0) # stop("cannot have both ratetable() in the formula and a rmap argument") # rcall <- rmap # if (!is.call(rcall) || rcall[[1]] != as.name('list')) # stop ("Invalid rcall argument") # } #done with rmap # else if (length(rate) >0) { #sorting out ratetable # stemp <- untangle.specials(Terms, 'ratetable') # rcall <- as.call(parse(text=stemp$var)[[1]]) # as a call object # rcall[[1]] <- as.name('list') # make it a call to list # Term2 <- Term2[-stemp$terms] # remove from the formula # } # else rcall <- NULL # A ratetable, but no rcall or ratetable() # # Check that there are no illegal names in rcall, then expand it # # to include all the names in the ratetable # if (is.ratetable(ratetable)) { # israte <- TRUE # dimid <- names(dimnames(ratetable)) # if (is.null(dimid)) # dimid <- attr(ratetable, "dimid") # older style # else attr(ratetable, "dimid") <- dimid #put all tables into the old style # # temp <- match(names(rcall)[-1], dimid) # 2,3,... are the argument names # if (any(is.na(temp))) # stop("Variable not found in the ratetable:", (names(rcall))[is.na(temp)]) # # if (any(!(dimid %in% names(rcall)))) { # to.add <- dimid[!(dimid %in% names(rcall))] # temp1 <- paste(text=paste(to.add, to.add, sep='='), collapse=',') # if (is.null(rcall)) rcall <- parse(text=paste("list(", temp1, ")"))[[1]] # else { # temp2 <- deparse(rcall) # rcall <- parse(text=paste("c(", temp2, ",list(", temp1, "))"))[[1]] # } # } # } # else stop("invalid ratetable") # Create a temporary formula, used only in the call to model.frame, # that has extra variables # newvar <- all.vars(rcall) # if (length(newvar) > 0) { # tform <- paste(paste(deparse(Term2), collapse=""), # paste(newvar, collapse='+'), sep='+') # m$formula <- as.formula(tform, environment(Terms)) # } m <- eval(m, parent.frame()) n <- nrow(m) if (n==0) stop("data set has 0 rows") Y <- model.extract(m, "response") offset <- model.offset(m) if (length(offset)==0) offset <- rep(0., n) if (!is.Surv(Y)) stop("Response must be a survival object") Y.surv <- Y if (attr(Y, "type") == "right") { type <- attr(Y, "type") status <- Y[, 2] Y <- Y[, 1] start <- rep(0, n) ncol0 <- 2 } else if (attr(Y, "type") == "counting") { type <- attr(Y, "type") status <- Y[, 3] start <- Y[, 1] Y <- Y[, 2] ncol0 <- 3 } else stop("Illegal response value") if (any(c(Y, start) < 0)) stop("Negative follow up time") # if(max(Y)<30) # warning("The event times must be expressed in days! (Your max time in the data is less than 30 days) \n") # # rdata contains the variables matching the ratetable # rdata <- data.frame(eval(rcall, m), stringsAsFactors=TRUE) # rtemp <- match.ratetable(rdata, ratetable) #this function puts the dates in R and in cutpoints in rtabledate # R <- rtemp$R # cutpoints <- rtemp$cutpoints # if(is.null(attr(ratetable, "factor"))) # attr(ratetable, "factor") <- (attr(ratetable, "type") ==1) # attr(ratetable, "dimid") <- dimid # rtorig <- attributes(ratetable) # nrt <- length(rtorig$dimid) #checking if the ratetable variables are given in days # wh.age <- which(dimid=="age") # wh.year <- which(dimid=="year") # if(length(wh.age)>0){ # if (max(R[,wh.age])<150 & median(diff(cutpoints[[wh.age]]))>12) # warning("Age in the ratetable part of the formula must be expressed in days! \n (Your max age is less than 150 days) \n") # } # TMT -- note the new class # if(length(wh.year)>0){ # if(min(R[,wh.year])>1850 & max(R[,wh.year])<2020& # inherits(cutpoints[[wh.year]], "rtdate")) # warning("The calendar year must be one of the date classes (Date, date, POSIXt)\n (Your variable seems to be expressed in years) \n") # } #checking if one of the continuous variables is fixed: # if(nrt!=ncol(R)){ # nonex <- which(is.na(match(rtorig$dimid,attributes(ratetable)$dimid))) # for(it in nonex){ # if(rtorig$type[it]!=1)warning(paste("Variable ",rtorig$dimid[it]," is held fixed even though it changes in time in the population tables. \n (You may wish to set a value for each individual and not just one value for all)",sep="")) # } # } #NEW in 2.05 (strata) # Now create the X matrix and strata strats <- attr(Term2, "specials")$strata if (length(strats)) { temp_str <- untangle.specials(Term2,"strata",1) if (length(temp_str$vars) == 1) strata.keep <- m[[temp_str$vars]] else strata.keep <- strata(m[,temp_str$vars],shortlabel=TRUE,sep=",") Term2 <- Term2[-temp_str$terms] } else strata.keep <- factor(rep(1,n)) # zgoraj ze definirano n = nrow(m) if (!missing(cause)) strata.keep <- factor(rep(1,n)) attr(Term2, "intercept") <- 1 # ignore a "-1" in the formula X <- model.matrix(Term2, m)[,-1, drop=FALSE] mm <- ncol(X) if (mm > 0 && !missing(centered) && centered) { mvalue <- colMeans(X) X <- X - rep(mvalue, each=nrow(X)) } else mvalue <- double(mm) cause <- model.extract(m, "cause") if(is.null(cause)) cause <- rep(2,nrow(m)) #NEW: ce cause manjka #status[cause==0] <- 0 keep <- Y > start if (!missing(int)) { int <- max(int) status[Y > int * 365.241] <- 0 Y <- pmin(Y, int * 365.241) keep <- keep & (start < int * 365.241) } if (any(start > Y) | any(Y < 0)) stop("Negative follow-up times") if (!all(keep)) { X <- X[keep, , drop = FALSE] Y <- Y[keep] start <- start[keep] status <- status[keep] # R <- R[keep, ,drop=FALSE] strata.keep <- strata.keep[keep] # dodano za strato #NEW in 2.05 offset <- offset[keep] Y.surv <- Y.surv[keep, , drop = FALSE] cause <- cause[keep] n <- sum(keep) # rdata <- rdata[keep,] } # I do not want to preserve variable class here - so paste R onto here, give it names # temp <- R # names(temp) <- paste0("X", 1:ncol(temp)) # with the right names #if variable class needs to be preserved, use this instead # variable class. So paste on rdata, but with the right order and names #temp <- rdata[,match(dimid, names(rdata))] # in the right order #names(temp) <- paste0("X", 1:ncol(temp)) # with the right names data <- data.frame(start = start, Y = Y, stat = status) if (mm != 0) data <- cbind(data, X) # # we pass the altered cutpoints forward, keep them in the date format (could be changed eventually to get rid of the date package dependence) # attr(ratetable, "cutpoints") <- lapply(cutpoints, function(x) { # if(inherits(x, 'rtabledate')) class(x) <- 'date' # x}) out <- list(data = data, X = as.data.frame(X)) out } relsurv/R/survfitrsadd.r0000644000176200001440000001171614070550360015066 0ustar liggesusers#' Compute a Predicited Survival Curve #' #' Computes a predicted survival curve based on the additive model estimated by #' rsadd function. #' #' When predicting the survival curve, the ratetable values for future years #' will be equal to those of the last given year. The same ratetables will be #' used for fitting and predicting. To predict a relative survival curve, use #' \code{rs.surv.rsadd}. #' #' @param formula a rsadd object #' @param newdata a data frame with the same variable names as those that #' appear in the rsadd formula. The curve(s) produced will be representative of #' a cohort who's covariates correspond to the values in newdata. #' @param se.fit a logical value indicating whether standard errors should be #' computed. Default is \code{TRUE}. #' @param conf.int the level for a two-sided confidence interval on the #' survival curve(s). Default is 0.95. #' @param individual a logical value indicating whether the data frame #' represents different time epochs for only one individual (T), or whether #' multiple rows indicate multiple individuals (F, the default). If the former #' only one curve will be produced; if the latter there will be one curve per #' row in newdata. #' @param conf.type One of \code{none}, \code{plain}, \code{log} (the default), #' or \code{log-log}. The first option causes confidence intervals not to be #' generated. The second causes the standard intervals curve +- k *se(curve), #' where k is determined from conf.int. The log option calculates intervals #' based on the cumulative hazard or log(survival). The last option bases #' intervals on the log hazard or log(-log(survival)). #' @param ... Currently not implemented #' @return a \code{survfit} object; see the help on \code{survfit.object} for #' details. The \code{survfit} methods are used for \code{print}, \code{plot}, #' \code{lines}, and \code{points}. #' @seealso \code{survfit}, \code{survexp}, \code{\link{rs.surv}} #' @references Package: Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine,\bold{81}: 272--278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #BTW: work on a smaller dataset here to run the example faster #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata[1:500,],method="EM") #' survfit.rsadd(fit,newdata=data.frame(sex=1,age=60,year=17000)) #' #' survfit.rsadd <- function (formula, newdata, se.fit = TRUE, conf.int = 0.95, individual = FALSE, conf.type = c("log", "log-log", "plain", "none"),...) { call <- match.call() Terms <- terms(formula) #to rabis, ce je model mal bl smotan - as.factor ali splines ali svasta Terms <- delete.response(Terms) popdata <- newdata newdata <- model.frame(Terms,newdata) resp <- list(y=formula$y,x=newdata) n <- formula$n nvar <- length(formula$coef) nx <- nrow(newdata) nt <- length(formula$times) temp <- list(n=formula$n,time=formula$times,call=call,type="right") Lambda0 <- formula$Lambda0 Lambda0 <- matrix(Lambda0,ncol=nt,nrow=nrow(newdata),byrow=TRUE) rate <- attr(Terms, "specials")$ratetable #rat <- attributes(formula$ratetable)$dimid rat <- names(attributes(formula$ratetable)$dimnames) #mein <- attributes(newdata[,rate])$dimnames[[2]] mein <- names(popdata) x <- match(rat,mein) #R <- as.matrix(newdata[, rate, drop = FALSE]) R <- as.matrix(popdata) R <- R[,x,drop=FALSE] R <- data.frame(R) names(R) <- rat #newdata <- newdata[,1:(rate-1),drop=FALSE] labeli <- attr(attr(newdata,"terms"),"term.labels") colnami <- colnames(newdata) if(length(rate>0)){ labeli <- labeli[-rate] colnami <- colnami[-rate] } newdata <- newdata[,match(colnami,labeli),drop=F] if(any(formula$mvalue)>0)newdata <- newdata - matrix(formula$mvalue,nrow=nrow(newdata),byrow=TRUE) nx <- ncol(newdata) #getl <- function(times,data=R,ratetable=formula$ratetable){ # -log(srvxp.fit(data,times,ratetable)) #} #Lambdap <- sapply(formula$times, getl) # Lambdap <- NULL # for(it in 1:nt){ # Lambdap <- cbind(Lambdap,-log(srvxp.fit(R,formula$times[it],formula$ratetable))) # } Lambdap <- NULL for(it in 1:nrow(newdata)){ Lambdap <- rbind(Lambdap,-log(survexp(~1,data=R[it,,drop=FALSE],times=formula$times,ratetable=formula$ratetable)$surv)) } ebx <- exp(as.matrix(formula$coef %*%as.numeric(newdata))) ebx <- matrix(ebx,ncol=nt,nrow=length(ebx)) Lambda <- Lambdap + Lambda0*ebx temp$surv <- t(exp(-Lambda)) temp$n.event <- rep(1,nt) temp$n.risk <- n+1 - cumsum(temp$n.event) class(temp) <- c("rs.surv.rsadd", "rs.surv","survfit") temp } relsurv/R/rsaalen.R0000644000176200001440000004210414742177072013741 0ustar liggesusers# Calculating betas: calculateBetasRelsurv22R <- function(data, xt, event_times, all_times, ratetable, atts, data_mat, variance, var_estimator='dN'){ ncol <- length(all_times) Yt_val <- Yt(data, all_times) dNt_val <- dNt(data, all_times) dLambdaP_val <- dLambdaPR(data_mat, all_times, event_times, ratetable, atts) # dLambdaP_val <- c(0, dLambdaP_val) sample_size = nrow(xt) number_covs = ncol(xt) diag_dNt = matrix(0, nrow=sample_size, ncol=sample_size) beta_var = matrix(0, nrow=number_covs, ncol=number_covs) betas_var_list <- vector("list", ncol) if(variance){ betas_list0 <- lapply(1:ncol, function(i) fitOLS2(prepareX(Yt_val[[i]], xt), dNt_val[[i]] - (dLambdaP_val[,i+1] - dLambdaP_val[,i]), Yt_val[[i]])) if(var_estimator=='dN'){ betas_var_list <- lapply(1:ncol, function(i) betas_list0[[i]][[2]] %*% diag(dNt_val[[i]] - (dLambdaP_val[,i+1] - dLambdaP_val[,i])) %*% t(betas_list0[[i]][[2]])) } else if(var_estimator=='XdB'){ betas_var_list <- lapply(1:ncol, function(i) betas_list0[[i]][[2]] %*% diag(as.vector(prepareX(Yt_val[[i]], xt) %*% betas_list0[[i]][[1]])) %*% t(betas_list0[[i]][[2]])) } betas_list <- lapply(1:ncol, function(i) betas_list0[[i]][[1]]) } else{ betas_list <- lapply(1:ncol, function(i) fitOLS2(prepareX(Yt_val[[i]], xt), dNt_val[[i]] - (dLambdaP_val[,i+1] - dLambdaP_val[,i]), Yt_val[[i]])[[1]]) } # for(i in 1:ncol){ # xx2 = prepareX(Yt_val[[i]], xt) # betas = fitOLS2(xx2, dNt_val[[i]], Yt_val[[i]]) # # betas_list[[i]] = betas[[1]] # # if(var_estimator==1){ # diag(diag_dNt) <- dNt_val[[i]] # } else if(var_estimator == 2){ # betas0_vec <- betas[[1]]; # diag(diag_dNt) <- xx2 %*% betas0 # mogoce je treba dati na betas0 t() # } # # betas1 = betas[[2]] # # betas_var_list[[i]] <- betas1 %*% diag_dNt %*% t(betas1) # } out <- list(betas_list, betas_var_list) return(out) } # Calculating betas and gamma: calculateBetasGammasRelsurv22R <- function(data, xt, zt, event_times, all_times, ratetable, atts, data_mat, var_estimator=1){ ncol <- length(all_times) Yt_val <- Yt(data, all_times) dNt_val <- dNt(data, all_times) dLambdaP_val <- dLambdaPR(data_mat, all_times, event_times, ratetable, atts) # dLambdaP_val <- c(0, dLambdaP_val) sample_size = nrow(xt) number_covs = ncol(xt) diag_dNt = matrix(0, nrow=sample_size, ncol=sample_size) beta_var = matrix(0, nrow=number_covs, ncol=number_covs) diff_t <- diff(c(min(data$start), all_times)) betas_var_list <- vector("list", ncol) mod_list <- lapply(1:ncol, function(i) fitOLSconst(prepareX(Yt_val[[i]], xt), prepareX(Yt_val[[i]], zt)[,2:(ncol(zt)+1), drop=FALSE], dNt_val[[i]] - (dLambdaP_val[,i+1] - dLambdaP_val[,i]), Yt_val[[i]]) ) # Prvi integral: int_ztHz <- Reduce('+', lapply(1:ncol, function(i) mod_list[[i]][[1]]*diff_t[i])) int_ztHz_inv <- solve(int_ztHz) # Drugi integral: int_ztHdN <- Reduce('+', lapply(1:ncol, function(i) mod_list[[i]][[2]])) gamma_coef <- int_ztHz_inv%*%int_ztHdN Xminus <- lapply(1:ncol, function(i) mod_list[[i]][[3]]) betas_list <- lapply(1:ncol, function(i) Xminus[[i]]%*%(matrix(dNt_val[[i]], ncol=1) - zt %*% gamma_coef * diff_t[i])) out <- list(betas_list=betas_list, betas_var_list=betas_var_list, gamma_coef=gamma_coef) return(out) } #' Fit an extended additive hazards model using relative survival #' #' Fits the Aalen additive hazard model using relative survival. The function can be used for multi-state model #' data (as in the package mstate; class msdata) by supplying the start and stop times in the #' Surv object and adding a strata(trans) object in the formula (where trans denotes the #' transition in the multi-state model). #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param variance a logical value indicating whether the variances of the hazards should be computed. #' Default is FALSE. #' @param var_estimator Choose variance estimator, in the same way as in survaalen. The default option 'dN' uses dN(t)-dLambda_P(t) in the variance estimator, equivalent to formula 4.63 in Aalen et al. (2008). Option 'XdB' uses X*dB(t), see formula 4.64 in Aalen et al. (2008). #' @param ratetable a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}. #' @param rmap an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. #' @param split.transitions only relevant if a multi-state model is fitted. An integer vector containing the numbered transitions that should be split. Use same numbering as in the given transition matrix. #' @return An object of class \code{aalen.model}. #' @seealso \code{survaalen} #' @author Damjan Manevski #' @keywords survival #' @examples #' #' # Survival: #' data(rdata) #' mod <- rsaalen(Surv(time, cens)~sex+age, data=rdata, ratetable=slopop, #' rmap=list(age=age*365.241)) #' head(mod$coefficients) #' tail(mod$coefficients) #' #' # Multi-state model: #' data(ebmt1wide) #' # Generate sex and year data (for illustrative purposes since it is not given in the data): #' ebmt1wide$sex <- sample(1:2, size = nrow(ebmt1wide), replace = TRUE) #' ebmt1wide$year <- as.Date('2010-01-01') #' #' mod <- rsaalen(Surv(Tstart, Tstop, status)~age.1+age.2+age.3+strata(trans), data=ebmt1wide, #' ratetable = slopop, rmap = list(age=age*365.241), split.transitions = 2:3) #' head(mod$coefficients$trans1) #' head(mod$coefficients$trans2) #' head(mod$coefficients$trans3) rsaalen <- function(formula, data, variance=FALSE, var_estimator='dN', ratetable=relsurv::slopop, rmap, split.transitions){ # Find covariates and strata: covs <- attr(terms(formula), 'term.labels') strata_obj <- grep("strata\\(", covs, value=TRUE) # Prepare objects in case of const(): formula_new <- formula covs_new <- covs constTRUE <- grepl('const', deparse(formula[[3]])) if(constTRUE){ covs_const <- grepl('const\\(', covs) rnames_gamma <- covs[covs_const] covs_wconst <- covs covs_wconst[covs_const] <- gsub('const\\(', '', covs_wconst[covs_const]) covs_wconst[covs_const] <- gsub('\\)', '', covs_wconst[covs_const]) covs_new <- covs_wconst if(length(covs_wconst)>1){ covs_wconst <- paste0(covs_wconst, collapse = ' + ') } formula_new <- as.formula(paste0(deparse(formula[[2]]), '~', covs_wconst)) } # Run a multi-state model: if(length(strata_obj)>0){ relsurv.mods <- vector("list", length(split.transitions)) # Check: if(length(strata_obj)>1) stop('You have supplied multiple strata() objects in the formula. Please supply only one.') if(missing('split.transitions')) stop('Please define which transitions should be split in the split.transitions argument. If relative survival is not needed, use the survaalen function.') # Take care of rmap: if (!missing(rmap)) { rmap_tmp <- substitute(rmap) if(inherits(rmap_tmp, "call")){ rmap <- rmap_tmp } } # Save original data: data_orig <- data data <- as.data.frame(data) # Find strata object: strata_obj <- gsub("strata\\(|\\)", "", strata_obj) strata_levels <- unique(data[,strata_obj]) coefficients <- list() coefficients.var <- list() gamma <- vector("list", length = length(strata_levels)) # gamma.var <- vector("list", length = length(strata_levels)) all_times <- c() # Find max time: max_time <- max(data[,as.character(formula_new[[2]][3])]) stevec <- 1 # For every strata: for(i in 1:length(strata_levels)){ # Subset data and covs: data_tmp <- data[data[,strata_obj]==strata_levels[i], ] covs_tmp <- covs[endsWith(covs, paste0(".", strata_levels[i])) | endsWith(covs, paste0(".", strata_levels[i], ')'))] # grep(paste0('.', strata_levels[i]), covs_new, value=TRUE) # Prepare formula: covs_tmp2 <- paste0(covs_tmp, collapse=' + ') formula_tmp <- as.formula(paste0(deparse(formula_new[[2]]), '~', covs_tmp2)) # Run model: if(i %in% split.transitions){ mod_tmp <- rsaalen(formula_tmp, data_tmp, variance, var_estimator, ratetable, rmap) relsurv.mods[[stevec]] <- mod_tmp stevec <- stevec+1 } else{ mod_tmp <- survaalen(formula_tmp, data_tmp, variance) } # Remove time 0: # if(mod_tmp$coefficients[1,1]==0){ # mod_tmp$coefficients <- mod_tmp$coefficients[2:nrow(mod_tmp$coefficients),] # } # Save coefficients: coefficients[[i]] <- mod_tmp$coefficients coefficients.var[[i]] <- mod_tmp$coefficients.var all_times <- c(all_times, mod_tmp$coefficients[,1]) if(constTRUE){ if('gamma' %in% names(mod_tmp)){ gamma[[i]] <- mod_tmp$gamma # if(variance){ # gamma.var[[i]] <- mod_tmp$gamma.var # } } } } names(coefficients) <- paste0('trans', strata_levels) if(variance) names(coefficients.var) <- paste0('trans', strata_levels) names(gamma) <- paste0('trans', strata_levels) # names(gamma.var) <- paste0('trans', strata_levels) # Add all times in the mstate model: all_times <- sort(unique(c(all_times, max_time))) for(i in 1:length(strata_levels)){ all_times_tmp <- all_times[!(all_times %in% coefficients[[i]][,1])] tmp_df <- matrix(NA, nrow=length(all_times_tmp), ncol= ncol(coefficients[[i]])) tmp_df[,1] <- all_times_tmp colnames(tmp_df) <- colnames(coefficients[[i]]) coefficients[[i]] <- rbind(coefficients[[i]], tmp_df) coefficients[[i]] <- coefficients[[i]][order(coefficients[[i]][,1]),] if(variance){ if(nrow(coefficients.var[[i]]) != 0){ coefficients.var[[i]] <- rbind(coefficients.var[[i]], tmp_df) coefficients.var[[i]] <- coefficients.var[[i]][order(coefficients.var[[i]][,1]),] } } for(j in 2:ncol(coefficients[[i]])){ coefficients[[i]][,j] <- mstateNAfix(coefficients[[i]][,j], 0) if(variance){ if((nrow(coefficients.var[[i]]) != 0)){ coefficients.var[[i]][,j] <- mstateNAfix(coefficients.var[[i]][,j], 0) } } } } names(relsurv.mods) <- split.transitions if(constTRUE){ if(variance){ out <- list(coefficients=coefficients, coefficients.var=coefficients.var, gamma=gamma, #gamma.var=gamma.var, split.transitions=split.transitions, formula=formula, ratetable=ratetable, rmap=rmap, relsurv.mods=relsurv.mods) } else{ out <- list(coefficients=coefficients, gamma=gamma, split.transitions=split.transitions, formula=formula, ratetable=ratetable, rmap=rmap, relsurv.mods=relsurv.mods) } } else{ if(variance){ out <- list(coefficients=coefficients, coefficients.var=coefficients.var, split.transitions=split.transitions, formula=formula, ratetable=ratetable, rmap=rmap, relsurv.mods=relsurv.mods) } else{ out <- list(coefficients=coefficients, split.transitions=split.transitions, formula=formula, ratetable=ratetable, rmap=rmap, relsurv.mods=relsurv.mods) } } class(out) <- 'aalen.model' return(out) } else{ if(!missing('split.transitions')) warning('The split.transitions argument is ignored since you are not using a multi-state model.') # Save original data: data_orig <- data # Take care of rmap: if (!missing(rmap)) { rmap_tmp <- substitute(rmap) if(inherits(rmap_tmp, "call")){ rmap <- rmap_tmp } } # Standard relsurv format: rform <- rformulate(formula_new, data, ratetable, stats::na.omit(), rmap) # Objects: data <- rform$data xt <- rform$X ratetable <- rform$ratetable # Times: all_times <- unique(c(data$start, data$Y)) event_times <- unique(data$Y[data$stat==1]) all_times <- sort(all_times) event_times <- sort(event_times) # Take only times until last event time: all_times <- all_times[all_times <= event_times[length(event_times)]] # Find Yt / dNt: # dNt <- dNt(data, all_times) # Yt <- Yt(data, all_times) # dLambdaPs_0 <- dLambdaP0(data, all_times, event_times, ratetable, atts) atts <- attributes(ratetable) atts$cutpoints <- atts$cutpoints[lapply(atts$cutpoints,length)>0] # dLambdaPs <- dLambdaP(as.matrix(data), all_times, event_times, as.vector(ratetable), atts) # xx1 <- prepareX(Yt[[1]], as.matrix(xt)) # fuu <- fitOLS2(xx1, dNt[[1]], Yt[[1]]) # Find betas: # betas <- calculateBetas(data, as.matrix(xt), event_times) # betas <- calculateBetasRelsurv(data, as.matrix(xt), event_times, all_times, as.vector(ratetable), atts, as.matrix(data)) # betas <- calculateBetasRelsurv2(data, as.matrix(xt), event_times, all_times, as.vector(ratetable), atts, as.matrix(data)) # betas <- calculateBetasRelsurv22(data, as.matrix(xt), event_times, all_times, as.vector(ratetable), atts, as.matrix(data), 1) if(constTRUE){ zt <- xt[,covs_const, drop=FALSE] xt <- xt[,!covs_const, drop=FALSE] # all_times_w0 <- all_times[2:length(all_times)] # betas0 <- calculateBetasGammasRelsurv22R(data, as.matrix(xt), as.matrix(zt), event_times, all_times_w0, ratetable, atts, as.matrix(data), 1) betas0 <- calculateBetasGammasRelsurv22R(data, as.matrix(xt), as.matrix(zt), event_times, all_times, ratetable, atts, as.matrix(data), 1) } else{ betas0 <- calculateBetasRelsurv22R(data, as.matrix(xt), event_times, all_times, ratetable, atts, as.matrix(data), variance, var_estimator) } # Variance: betas_var <- betas0[[2]] betas_var <- lapply(betas_var, function(x) diag(x)) betas_var2 <- do.call(rbind, betas_var) # Point estimates: betas <- betas0[[1]] # Take care of format: betas2 <- t(do.call(cbind, betas)) # betas2 <- rbind(matrix(0, nrow=1, ncol=(ncol(xt)+1)), # betas2) # Cumulative: for(iu in 1:ncol(betas2)){ betas2[,iu] <- cumsum(betas2[,iu]) if(ncol(betas_var2)!=0){ betas_var2[,iu] <- cumsum(betas_var2[,iu]) } } # Add times: if(constTRUE){ # betas2 <- cbind(all_times_w0, betas2) # betas2 <- betas2[all_times_w0 %in% c(0, event_times),] betas2 <- cbind(all_times, betas2) } else{ betas2 <- cbind(all_times, betas2) } # Add times: if(ncol(betas_var2)!=0){ betas_var2 <- cbind(all_times, betas_var2) } # Add naming: colnames(betas2) <- c('time', '(Intercept)', colnames(xt)) if(ncol(betas_var2)!=0){ colnames(betas_var2) <- c('time', '(Intercept)', colnames(xt)) } # Don't have double zeros: # if(betas2[1,1] == 0 & betas2[2,1] == 0){ # betas2 <- betas2[-1,] # } betas3 <- betas2[betas2[,1] %in% c(0, event_times), ] if(!(0 %in% betas3[,1])){ betas3 <- rbind(matrix(0, nrow=1,ncol=ncol(betas3)), betas3) } if(ncol(betas_var2)!=0){ betas_var2 <- betas_var2[betas_var2[,1] %in% c(0, event_times), ] } # Prepare final object: if(variance){ var.obj <- betas_var2 # var.obj[,2:ncol(var.obj)] <- abs(var.obj[,2:ncol(var.obj)])/4 out <- list(coefficients=betas3, coefficients.var=var.obj, # prej je betas_var2 formula=formula, ratetable=ratetable, rmap=rmap) } else{ out <- list(coefficients=betas3, formula=formula, ratetable=ratetable, rmap=rmap) } if(constTRUE){ rownames(betas0[[3]]) <- rnames_gamma colnames(betas0[[3]]) <- 'gamma' out[[length(out)+1]] <- betas0[[3]] names(out)[length(out)] <- 'gamma' # if(variance){ # out[[length(out)+1]] <- betas0[[3]] # tmp # colnames(out[[length(out)]]) <- 'gamma.var' # names(out)[length(out)] <- 'gamma.var' # } } class(out) <- 'aalen.model' return(out) } } # TO DO: # implement variances # other left-truncation solutions? for now you put 0s # time dependent covariates? # multi-state: # Popravi racunanje vo multi-state - za sea site vreminja gi vlecis, ne zemas vo predvid promeni vo L_P relsurv/R/predict.rsadd.R0000644000176200001440000000353614742212206015035 0ustar liggesusers#' Subject-specific prediction from rsadd #' #' Function #' @param object An rsadd object #' @param newdata A data.frame with one row (add covariate values in columns) #' @param ... Not used for now #' @return A data.frame with times, excess and population hazard. #' #' @author Damjan Manevski \email{damjan.manevski@@mf.uni-lj.si} #' @export predict.rsadd <- function(object, newdata, ...){ # object: a rsadd object # newdata: data.frame with one row, in columns add covariate values. # subject-specific prediction. # Zaenkrat delamo z object$times. Treba bo dodati se add.times. Ta add.times bo verjetno v rsadd lin.pred <- 0 for(cov in names(object$coefficients)){ lin.pred <- lin.pred + sum(newdata[1,cov]*object$coefficients[cov]) } # haz_function(object$formula, rdata, object$ratetable, rmap=list(age=age*365.241), add.times=0, include.all.times = FALSE) kar <- deparse(object$formula[[2]]) autkam <- gsub(' ', '', strsplit(substr(kar, start = 6, stop=nchar(kar)-1), ',')[[1]]) newdata_2 <- data.frame(matrix(1, nrow=1, ncol=length(autkam))) if(length(autkam)==3) newdata_2[,1] <- 0 colnames(newdata_2) <- autkam newdata_2 <- cbind(newdata, newdata_2) if(is.null(object$rmap)){ rform <- suppressWarnings(rformulate(object$formula, newdata_2,object$ratetable)) } else{ rform <- suppressWarnings(rformulate(object$formula, newdata_2,object$ratetable, rmap = object$rmap)) } fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) pop.surv <- sapply(1:length(object$times), function(i) exp_prep(rform$data[1, 4:(nfk + 3), drop = FALSE], object$times[i], object$ratetable)) Haz.p <- -log(pop.surv) data.frame(time=object$times, Haz.e=object$Lambda0*exp(lin.pred), Haz.p=Haz.p) } relsurv/R/rsdiff.r0000644000176200001440000002136714742212277013636 0ustar liggesusers#' Test Net Survival Curve Differences #' #' Tests if there is a difference between two or more net survival curves using #' a log-rank type test. #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' @aliases rs.diff print.rsdiff #' @param formula A formula expression as for other survival models, of the #' form \code{Surv(time, status) ~ predictors}. Each combination of predictor #' values defines a subgroup. A \code{strata} term may be used to produce a #' stratified test. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param precision Precision for numerical integration. Default is 1, which #' means that daily intervals are taken, the value may be decreased to get a #' higher precision or increased to achieve a faster calculation. The #' calculation intervals always include at least all times of event and #' censoring as border points. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @return a \code{rsdiff} object; can be printed with \code{print}. #' @seealso \code{rs.surv}, \code{survdiff} #' @references Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric #' Relative Survival Analysis with the R Package relsurv". Journal of #' Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" Theory: #' Graffeo, N., Castell, F., Belot, A. and Giorgi, R. (2016) "A log-rank-type #' test to compare net survival distributions. Biometrics. doi: #' 10.1111/biom.12477" Theory: Pavlic, K., Pohar Perme, M. (2017) "On #' comparison of net survival curves. BMC Med Res Meth. doi: #' 10.1186/s12874-017-0351-3" #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #calculate the relative survival curve #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' rs.diff(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata) #' rs.diff <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action,precision=1,rmap) #formula: for example Surv(time,cens)~sex #data: the observed data set #ratetable: the population mortality tables { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action,rmap) #get the data ready data <- rform$data #the data set p <- rform$m #number of covariates if (p > 0) #if covariates data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make groups according to covariates else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 # Xs is a vector of factors determining the groups we wish to compare strats <- rform$strata.keep # added for strata str_num <- length(levels(strats)) # number of strata out <- NULL out$n <- table(data$Xs) #table of groups out$time <- out$n.risk <- out$n.event <- out$n.censor <- out$surv <- out$std.err <- out$groups <- NULL #TIMES ARE EQUAL FOR ALL GROUPS if(!precision)tis <- sort(unique(rform$Y)) #unique times else{ extra <- as.numeric(seq(1,max(rform$Y),by=precision)) tis <- sort(union(extra,rform$Y)) #1-day long intervals used - to take into the account the continuity of the pop. part } # start working kgroups <- length(out$n) #number of groups if (kgroups == 1) stop("There is only one group in your data. You should choose another variable.") w.risk <- w.event <- dnisisq <- array(NA,dim=c(length(tis),length(out$n),str_num)) #MATRIX - COLUMNS ARE GROUPS, ROWS ARE TIMES,levels are strata #numOfSmallGrps <- 0 numOfFewEvents <- 0 for (s in 1:str_num){ # added for strata for (kt in 1:kgroups) { #for each group inx <- which(data$Xs == names(out$n)[kt] & strats == levels(strats)[s]) #individuals within this group #if (length(inx)<10)numOfSmallGrps <- numOfSmallGrps + 1 temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE) #calculate the values for each interval of time out$time <- c(out$time, tis) #add times out$n.risk <- c(out$n.risk, temp$yi) #add number at risk for each time out$n.event <- c(out$n.event, temp$dni) #add number of events for each time if (sum(temp$dni) < 10) numOfFewEvents <- numOfFewEvents + 1 out$n.censor <- c(out$n.censor, c(-diff(temp$yi),temp$yi[length(temp$yi)]) - temp$dni) #add number of censored for each time w.risk[,kt,s] <- temp$yisi #Y_h^w w.event[,kt,s] <- temp$dnisi - temp$yidlisi #dN_eh^w dnisisq[,kt,s] <- temp$dnisisq #dN/S_p^2 out$groups <- c(out$groups, length(tis)) #number of times in this group } } #if (numOfSmallGrps > 0) warning(numOfSmallGrps, " out of ", kgroups*str_num, " groups is/are smaller than 10.") if (numOfFewEvents > 0) warning("In ", numOfFewEvents, " out of ", kgroups*str_num, " groups there are less than 10 events.") w.risk.total <- apply(w.risk,c(1,3),sum) #sum over all individuals at each time point ## Y_{.,s}^w w.event.total <- apply(w.event,c(1,3),sum) #sum over all individuals at each time point ## dN_{E,.,s}^w zs <- rep(0,kgroups) # added for strata for (s in 1:str_num){ # znotraj danega stratuma inx_str <- which(w.risk.total[,s] > 0) zhst <- w.event[inx_str,,s,drop=FALSE] - w.risk[inx_str,,s,drop=FALSE]/w.risk.total[inx_str,s]*w.event.total[inx_str,s] #value under the integral of zh # integriramo po casu - sestejemo po casih dogodkov zhs <- apply(zhst,2,sum) # the vector of test statistics zs <- zs + zhs } # cat("vektor testnih statistik je = \n") # print(zs) #covariance matrix: covmats <- matrix(0,nrow=kgroups,ncol=kgroups) d <- diag(kgroups) #identity matrix of groups size (for the kronecker deltas) for (s in 1:str_num){ underint <- 0 inx_str <- which(w.risk.total[,s] > 0) for(kt in 1:kgroups){ #matrix calculation through the groups ys <- matrix(d[kt,],nrow=length(inx_str),ncol=kgroups,byrow=T) - w.risk[inx_str,,s]/w.risk.total[inx_str,s] #preparing the matrix for the first two terms #yslist <- apply(apply(ys,1,list),unlist) #a list, each row of ys (each time point) represents one item yslist <- as.list(data.frame(t(ys))) #a list, each row of ys (each time point) represents one item yprod <- lapply(yslist,function(x)outer(x,x)) #a list of matrices with y products through all the time points, yproda <- array(unlist(yprod),dim=c(kgroups,kgroups,length(inx_str)))#y terms transformed to an array dnisisqa <- array(rep(dnisisq[,kt,s],each=kgroups^2),dim=c(kgroups,kgroups,length(inx_str))) #dnisisq terms transformed into an array of equal size underint <- underint + yproda * dnisisqa #the terms under the integral } covmat <- apply(underint,1:2,sum) #summing down the array covmats <- covmats + covmat } # cat("kovariancna matrika je = \n") # print(covmats) # del za testiranje zs <- zs[-kgroups] # the last one is deleted zs <- matrix(zs,nrow=1) # print(covmats) covmats <- covmats[-kgroups,-kgroups,drop=F] # print(covmats) test.stat <- zs %*% solve(covmats) %*% t(zs) p.value <- 1-pchisq(test.stat,df=kgroups-1) names(out$groups) <- names(out$n) if (p == 0) out$groups <- NULL #if no covariates out$n <- as.vector(out$n) out$call <- call #class(out) <- c("survdiff", "rs.surv") #cat(zh) out$zh <- zs out$covmat <- covmats out$test.stat <- test.stat out$p.value <- p.value out$df <- kgroups-1 class(out) <- "rsdiff" out } print.rsdiff <- function(x,...){ invisible(cat("Value of test statistic:", x$test.stat, "\n")) invisible(cat("Degrees of freedom:", x$df, "\n")) invisible(cat("P value:", x$p.value, "\n")) } relsurv/R/survaalen.R0000644000176200001440000003336014742176744014325 0ustar liggesusers# Calculating betas: calculateBetasR <- function(data, xt, event_times, variance=FALSE, var_estimator='dN'){ ncol <- length(event_times) Yt_val <- Yt(data, event_times) dNt_val <- dNt(data, event_times) sample_size = nrow(xt) number_covs = ncol(xt) # diag_dNt = matrix(0, nrow=sample_size, ncol=sample_size) # beta_var = matrix(0, nrow=number_covs, ncol=number_covs) betas_var_list <- vector("list", ncol) if(variance){ betas_list0 <- lapply(1:ncol, function(i) fitOLS2(prepareX(Yt_val[[i]], xt), dNt_val[[i]], Yt_val[[i]])) if(var_estimator=='dN'){ betas_var_list <- lapply(1:ncol, function(i) betas_list0[[i]][[2]] %*% diag(dNt_val[[i]]) %*% t(betas_list0[[i]][[2]])) } else if(var_estimator=='XdB'){ betas_var_list <- lapply(1:ncol, function(i) betas_list0[[i]][[2]] %*% diag(as.vector(prepareX(Yt_val[[i]], xt) %*% betas_list0[[i]][[1]])) %*% t(betas_list0[[i]][[2]])) } betas_list <- lapply(1:ncol, function(i) betas_list0[[i]][[1]]) } else{ betas_list <- lapply(1:ncol, function(i) fitOLS2(prepareX(Yt_val[[i]], xt), dNt_val[[i]], Yt_val[[i]])[[1]] ) } # for(i in 1:ncol){ # xx2 = relsurv:::prepareX(Yt_val[[i]], xt) # betas = relsurv:::fitOLS2(xx2, dNt_val[[i]], Yt_val[[i]]) # # betas_list[[i]] = betas[[1]] # # if(var_estimator==1){ # diag(diag_dNt) <- dNt_val[[i]] # } else if(var_estimator == 2){ # betas0_vec <- betas[[1]]; # diag(diag_dNt) <- xx2 %*% betas0 # mogoce je treba dati na betas0 t() # } # # betas1 = betas[[2]] # # betas_var_list[[i]] <- betas1 %*% diag_dNt %*% t(betas1) # } out <- list(betas_list, betas_var_list) return(out) } # An R version of the fitOLSconst C function: fitOLSconstR <- function(mX, mZ, dNt, Yt) { no_cov = ncol(mX) no_cov_Z = ncol(mZ) sample_size = nrow(mX) no_at_risk = sum(Yt) Xminus = matrix(0, nrow = sample_size, ncol = no_cov) H = matrix(0, ncol=no_cov, nrow=no_cov) Identity = matrix(0, ncol=sample_size, nrow=sample_size) diag(Identity) <- 1 prvaKomponenta = matrix(0, ncol=no_cov_Z, nrow=no_cov_Z) drugaKomponenta = matrix(0, ncol=no_cov_Z, nrow=1) out <- list() out[[1]] = prvaKomponenta out[[2]] = drugaKomponenta out[[3]] = Xminus if(no_at_risk >= no_cov){ mXtX = t(mX)%*%mX rcf = rcond(mXtX) if(rcf != 0){ Xminus = solve(mXtX)%*%t(mX) H = Identity-mX%*%Xminus prvaKomponenta = t(mZ)%*%H%*%mZ drugaKomponenta = t(mZ)%*%H%*%dNt out[[1]] = prvaKomponenta out[[2]] = drugaKomponenta out[[3]] = Xminus } } return(out) } # Calculating betas and gamma: calculateBetasGammasR <- function(data, xt, zt, event_times, var_estimator='dN'){ ncol <- length(event_times) Yt_val <- Yt(data, event_times) dNt_val <- dNt(data, event_times) sample_size = nrow(xt) number_covs = ncol(xt) diff_t <- diff(c(min(data$start), event_times)) # diag_dNt = matrix(0, nrow=sample_size, ncol=sample_size) # beta_var = matrix(0, nrow=number_covs, ncol=number_covs) betas_var_list <- vector("list", ncol) mod_list <- lapply(1:ncol, function(i) fitOLSconst(prepareX(Yt_val[[i]], xt), prepareX(Yt_val[[i]], zt)[,2:(ncol(zt)+1), drop=FALSE], dNt_val[[i]], Yt_val[[i]])) # Prvi integral: int_ztHz <- Reduce('+', lapply(1:ncol, function(i) mod_list[[i]][[1]]*diff_t[i])) int_ztHz_inv <- solve(int_ztHz) # Drugi integral: int_ztHdN <- Reduce('+', lapply(1:ncol, function(i) mod_list[[i]][[2]])) gamma_coef <- int_ztHz_inv%*%int_ztHdN Xminus <- lapply(1:ncol, function(i) mod_list[[i]][[3]]) betas_list <- lapply(1:ncol, function(i) Xminus[[i]]%*%(matrix(dNt_val[[i]], ncol=1) - zt %*% gamma_coef * diff_t[i])) out <- list(betas_list=betas_list, betas_var_list=betas_var_list, gamma_coef=gamma_coef) # Reduce('+', lapply(1:49, function(i) solve(mod_list[[i]][[1]]) %*% mod_list[[i]][[2]]))/max(data$Y) # sum(lapply(1:ncol, function(i) solve(mod_list[[i]][[1]]) %*% mod_list[[i]][[2]]))/max(data$Y) return(out) } #' Fit an additive hazards model #' #' Fits the Aalen additive hazard model. The function can be used for multi-state model #' data (as in the package mstate; class msdata) by supplying the start and stop times in the #' Surv object and adding a strata(trans) object in the formula (where trans denotes the #' transition in the multi-state model). #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param variance a logical value indicating whether the variances of the hazards should be computed. #' Default is FALSE. #' @param var_estimator Choose variance estimator. The default option 'dN' uses dN(t) in the variance formula, see formula 4.63 in Aalen et al. (2008). Option 'XdB' uses X*dB(t), see formula 4.64 in Aalen et al. (2008). #' @return An object of class \code{aalen.model}. #' @seealso \code{rsaalen} #' @author Damjan Manevski #' @keywords survival #' @examples #' #' # Survival: #' data(rdata) #' mod <- survaalen(Surv(time, cens)~sex+age, data=rdata) #' head(mod$coefficients) #' tail(mod$coefficients) #' #' # Multi-state model: #' data(ebmt1wide) #' mod <- survaalen(Surv(Tstart, Tstop, status)~age.1+age.2+age.3+strata(trans), data=ebmt1wide) #' head(mod$coefficients$trans1) #' head(mod$coefficients$trans2) #' head(mod$coefficients$trans3) survaalen <- function(formula, data, variance=FALSE, var_estimator='dN'){ # Find covariates and strata: covs <- attr(terms(formula), 'term.labels') strata_obj <- grep("strata\\(", covs, value=TRUE) # Prepare objects in case of const(): formula_new <- formula covs_new <- covs constTRUE <- grepl('const', deparse(formula[[3]])) if(constTRUE){ covs_const <- grepl('const\\(', covs) rnames_gamma <- covs[covs_const] covs_wconst <- covs covs_wconst[covs_const] <- gsub('const\\(', '', covs_wconst[covs_const]) covs_wconst[covs_const] <- gsub('\\)', '', covs_wconst[covs_const]) covs_new <- covs_wconst if(length(covs_wconst)>1){ covs_wconst <- paste0(covs_wconst, collapse = ' + ') } formula_new <- as.formula(paste0(deparse(formula[[2]]), '~', covs_wconst)) } # Run a multi-state model: if(length(strata_obj)>0){ # Check: if(length(strata_obj)>1) stop('You have supplied multiple strata() objects in the formula. Please supply only one.') # Save original data: data_orig <- data data <- as.data.frame(data) # Find strata object: strata_obj <- gsub("strata\\(|\\)", "", strata_obj) strata_levels <- unique(data[,strata_obj]) coefficients <- list() coefficients.var <- list() gamma <- vector("list", length = length(strata_levels)) # gamma.var <- vector("list", length = length(strata_levels)) all_times <- c() # Find max time: max_time <- max(data[,as.character(formula_new[[2]][3])]) # For every strata: for(i in 1:length(strata_levels)){ # Subset data and covs: data_tmp <- data[data[,strata_obj]==strata_levels[i], ] covs_tmp <- covs[endsWith(covs, paste0(".", strata_levels[i])) | endsWith(covs, paste0(".", strata_levels[i], ')'))] # grep(paste0('.', strata_levels[i]), covs_new, value=TRUE) # Prepare formula: covs_tmp2 <- paste0(covs_tmp, collapse=' + ') formula_tmp <- as.formula(paste0(deparse(formula_new[[2]]), '~', covs_tmp2)) # Run model: mod_tmp <- survaalen(formula_tmp, data_tmp, variance) # Remove time 0: # if(mod_tmp$coefficients[1,1]==0){ # mod_tmp$coefficients <- mod_tmp$coefficients[2:nrow(mod_tmp$coefficients),] # } # Save coefficients: coefficients[[i]] <- mod_tmp$coefficients if(variance) coefficients.var[[i]] <- mod_tmp$coefficients.var all_times <- c(all_times, mod_tmp$coefficients[,1]) if(constTRUE){ if('gamma' %in% names(mod_tmp)){ gamma[[i]] <- mod_tmp$gamma # gamma.var[[i]] <- mod_tmp$gamma.var } } } names(coefficients) <- paste0('trans', strata_levels) names(gamma) <- paste0('trans', strata_levels) if(variance){ names(coefficients.var) <- paste0('trans', strata_levels) # names(gamma.var) <- paste0('trans', strata_levels) } # Add all times in the mstate model: all_times <- sort(unique(c(all_times, max_time))) for(i in 1:length(strata_levels)){ all_times_tmp <- all_times[!(all_times %in% coefficients[[i]][,1])] tmp_df <- matrix(NA, nrow=length(all_times_tmp), ncol= ncol(coefficients[[i]])) tmp_df[,1] <- all_times_tmp colnames(tmp_df) <- colnames(coefficients[[i]]) coefficients[[i]] <- rbind(coefficients[[i]], tmp_df) coefficients[[i]] <- coefficients[[i]][order(coefficients[[i]][,1]),] if(variance){ if(nrow(coefficients.var[[i]]) != 0){ coefficients.var[[i]] <- rbind(coefficients.var[[i]], tmp_df) coefficients.var[[i]] <- coefficients.var[[i]][order(coefficients.var[[i]][,1]),] } } for(j in 2:ncol(coefficients[[i]])){ coefficients[[i]][,j] <- mstateNAfix(coefficients[[i]][,j], 0) if(variance){ if(nrow(coefficients.var[[i]]) != 0){ coefficients.var[[i]][,j] <- mstateNAfix(coefficients.var[[i]][,j], 0) } } } } if(constTRUE){ if(variance){ out <- list(coefficients=coefficients, coefficients.var=coefficients.var, gamma=gamma#, gamma.var=gamma.var ) } else{ out <- list(coefficients=coefficients, gamma=gamma) } } else{ if(variance){ out <- list(coefficients=coefficients, coefficients.var=coefficients.var) } else{ out <- list(coefficients=coefficients) } } class(out) <- 'aalen.model' return(out) # Run a usual survival model: } else{ # Save original data: data_orig <- data sample_size <- nrow(data_orig) # Standard relsurv format: rform <- rformulate2(formula_new, data) data <- rform$data xt <- rform$X # Times: all_times <- unique(c(data$start, data$Y)) event_times <- unique(data$Y[data$stat==1]) all_times <- sort(all_times) event_times <- sort(event_times) # Take only times until last event time: all_times <- all_times[all_times <= event_times[length(event_times)]] # Find Yt / dNt: # dNt <- dNt(data, event_times) # Yt <- Yt(data, event_times) # xx1 <- prepareX(Yt[[1]], as.matrix(xt)) # fuu <- fitOLS2(xx1, dNt[[1]], Yt[[1]]) # browser() # Find betas: # betas <- calculateBetas(data, as.matrix(xt), event_times, 1) if(constTRUE){ zt <- xt[,covs_const, drop=FALSE] xt <- xt[,!covs_const, drop=FALSE] all_times_w0 <- all_times[2:length(all_times)] betas0 <- calculateBetasGammasR(data, as.matrix(xt), as.matrix(zt), all_times_w0, 1) } else{ betas0 <- calculateBetasR(data, as.matrix(xt), event_times, variance, var_estimator) } # Variance: betas_var <- betas0[[2]] betas_var <- lapply(betas_var, function(x) diag(x)) betas_var2 <- do.call(rbind, betas_var) # Point estimates: betas <- betas0[[1]] # Take care of format: betas2 <- t(do.call(cbind, betas)) # betas2 <- rbind(matrix(0, nrow=1, ncol=(ncol(xt)+1)), # betas2) # Cumulative: for(iu in 1:ncol(betas2)){ betas2[,iu] <- cumsum(betas2[,iu]) if(ncol(betas_var2)!=0){ betas_var2[,iu] <- cumsum(betas_var2[,iu])#*sample_size } } # Add zero: if(0 %in% all_times){ event_times <- c(0, event_times) betas2 <- rbind(matrix(0, nrow=1, ncol=(ncol(xt)+1)), betas2) if(ncol(betas_var2)!=0){ betas_var2 <- rbind(matrix(0, nrow=1, ncol=(ncol(xt)+1)), betas_var2) } } # Add times: if(constTRUE){ betas2 <- cbind(all_times, betas2) betas2 <- betas2[all_times %in% c(0, event_times),] } else{ betas2 <- cbind(event_times, betas2) } if(ncol(betas_var2)!=0){ betas_var2 <- cbind(event_times, betas_var2) } # Add naming: colnames(betas2) <- c('time', '(Intercept)', colnames(xt)) if(ncol(betas_var2)!=0){ colnames(betas_var2) <- c('time', '(Intercept)', colnames(xt)) } # Prepare final object: if(variance){ var.obj <- betas_var2 # var.obj[,2:ncol(var.obj)] <- abs(var.obj[,2:ncol(var.obj)])/4 out <- list(coefficients=betas2, coefficients.var=var.obj) # prej je betas_var2 } else{ out <- list(coefficients=betas2) } if(constTRUE){ rownames(betas0[[3]]) <- rnames_gamma colnames(betas0[[3]]) <- 'gamma' out[[length(out)+1]] <- betas0[[3]] names(out)[length(out)] <- 'gamma' # if(variance){ # out[[length(out)+1]] <- betas0[[3]] # tmp # colnames(out[[length(out)]]) <- 'gamma.var' # names(out)[length(out)] <- 'gamma.var' # } } class(out) <- 'aalen.model' return(out) } } # TO DO: # Scheike vprasanje: zakaj premikas case, ce je ob istem casu vec dogodkov? # Some plot function for mstate output of surv/rsaalen? Za coefficiente? relsurv/R/mystrata.r0000644000176200001440000000607412531603441014212 0ustar liggesusersmy.strata <- function (..., nameslist, sep = ", ") { #nameslist = lista imen spremenljivk words <- as.character((match.call())[-1]) #ime podatkov allf <- list(...) #podatki if (length(allf) == 1 && is.list(ttt <- unclass(allf[[1]]))) #so samo eni podatki allf <- ttt #ohranim le podatke (ne listo podatkov), v obliki list nterms <- length(allf) #nterms= st. spremenljivk +1 (row.names) if (is.null(names(allf))) #ce ni imen argname <- words[1:nterms] #jih dam else argname <- ifelse(names(allf) == "", words[1:nterms], #ce so prazna jih dam names(allf)) #imena so v argname varnames <- names(nameslist) #1. iteracija what <- allf[[1]] #prva spremenljivka for(it in 1:length(varnames)){ if (length(grep(varnames[it],names(allf)[[1]]))) break #poiscem ji mesto v svojem poimenovanju } if (is.null(levels(what))) what <- factor(what) #ce se ni, jo prisilimo v faktorsko levs <- unclass(what) - 1 #nastavim prvi level = 0 wlab <- levels(what) #imena faktorjev labs <- paste(argname[1], wlab, sep = "=") #prvo ime = 0/1 labsnow <- 1 allab <- NULL dd <- length(nameslist[[it]]) if(dd!=2) { mylabs <- rep(argname[1],length(wlab)) mylabs[wlab==0] <- "" } else mylabs <- labs for (i in (1:nterms)[-1]) { if(length(grep(varnames[labsnow],names(allf)[[i]]))==0){ #ce je zdaj to nova spremenljivka, moram najprej ustimat prejsnjo mylabs[mylabs==""] <- nameslist[[labsnow]][1] if(!any(allab!=""))allab <- paste(allab,mylabs,sep="") #the first time - do not separate by comma else allab <- paste(allab,mylabs,sep=",") mylabs <- rep("",length(mylabs)) labsnow <- labsnow+1 } what <- allf[[i]] if (is.null(levels(what))) what <- factor(what) wlev <- unclass(what) - 1 wlab <- levels(what) labsnew <- format(paste(argname[i], wlab, sep = "=")) levs <- wlev + levs * (length(wlab)) a <- rep(labs, rep(length(wlab), length(labs))) b <- rep(wlab, length(labs)) mya <- rep(mylabs, rep(length(wlab), length(labs))) allab <- rep(allab,rep(length(wlab), length(labs))) myb <- rep(argname[i],length(labs)*length(wlab)) for(it in 1:length(varnames)){ #it se ustavi pri trenutni spremenljivki if (length(grep(varnames[it],names(allf)[[i]]))) break } dd <- length(nameslist[[it]]) if(dd==2)myb <- paste(myb,rep(wlab,length(labs)),sep="=") else myb[rep(wlab,length(labs))==0] <- "" mylabs <- paste(mya,myb,sep="") labs <- paste(a,b, sep = sep) } mylabs[mylabs==""] <- nameslist[[labsnow]][1] if(!any(allab!=""))allab <- paste(allab,mylabs,sep="") else allab <- paste(allab,mylabs,sep=",") levs <- levs + 1 ulevs <- sort(unique(levs[!is.na(levs)])) levs <- match(levs, ulevs) labs <- labs[ulevs] allab <- allab[ulevs] factor(levs, labels = allab) } relsurv/R/rformulate.r0000644000176200001440000002051014731636107014526 0ustar liggesusers# This is a version with suggested updates by T Therneau # All updates are stolen from survexp in the survival package, with comments. # Most changes are used, some further corrections were required. rformulate <- function (formula, data = parent.frame(), ratetable, na.action, rmap, int, centered, cause) { call <- match.call() m <- match.call(expand.dots = FALSE) # keep the parts of the call that we want, toss others m <- m[c(1, match(c("formula", "data", "cause"), names(m), nomatch=0))] m[[1L]] <- quote(stats::model.frame) # per CRAN, the formal way to set it Terms <- if (missing(data)) terms(formula, specials= c("strata","ratetable")) else terms(formula, specials=c("strata", "ratetable"), data = data) Term2 <- Terms #sorting out the ratetable argument - matching demographic variables rate <- attr(Terms, "specials")$ratetable if (length(rate) > 1) stop("Can have only 1 ratetable() call in a formula") #matching demographic variables via rmap if (!missing(rmap)) { # use this by preference if (length(rate) >0) stop("cannot have both ratetable() in the formula and a rmap argument") rcall <- rmap if (!is.call(rcall) || rcall[[1]] != as.name('list')) stop ("Invalid rcall argument") } #done with rmap else if (length(rate) >0) { #sorting out ratetable stemp <- untangle.specials(Terms, 'ratetable') rcall <- as.call(parse(text=stemp$var)[[1]]) # as a call object rcall[[1]] <- as.name('list') # make it a call to list Term2 <- Term2[-stemp$terms] # remove from the formula } else rcall <- NULL # A ratetable, but no rcall or ratetable() # Check that there are no illegal names in rcall, then expand it # to include all the names in the ratetable if (is.ratetable(ratetable)) { israte <- TRUE dimid <- names(dimnames(ratetable)) if (is.null(dimid)) dimid <- attr(ratetable, "dimid") # older style else attr(ratetable, "dimid") <- dimid #put all tables into the old style temp <- match(names(rcall)[-1], dimid) # 2,3,... are the argument names if (any(is.na(temp))) stop("Variable not found in the ratetable:", (names(rcall))[is.na(temp)]) if (any(!(dimid %in% names(rcall)))) { to.add <- dimid[!(dimid %in% names(rcall))] temp1 <- paste(text=paste(to.add, to.add, sep='='), collapse=',') if (is.null(rcall)) rcall <- parse(text=paste("list(", temp1, ")"))[[1]] else { temp2 <- deparse(rcall) rcall <- parse(text=paste("c(", temp2, ",list(", temp1, "))"))[[1]] } } } else stop("invalid ratetable") # Create a temporary formula, used only in the call to model.frame, # that has extra variables newvar <- all.vars(rcall) if (length(newvar) > 0) { tform <- paste(paste(deparse(Term2), collapse=""), paste(newvar, collapse='+'), sep='+') m$formula <- as.formula(tform, environment(Terms)) } m <- eval(m, parent.frame()) n <- nrow(m) if (n==0) stop("data set has 0 rows") Y <- model.extract(m, "response") offset <- model.offset(m) if (length(offset)==0) offset <- rep(0., n) if (!is.Surv(Y)) stop("Response must be a survival object") Y.surv <- Y if (attr(Y, "type") == "right") { type <- attr(Y, "type") status <- Y[, 2] Y <- Y[, 1] start <- rep(0, n) ncol0 <- 2 } else if (attr(Y, "type") == "counting") { type <- attr(Y, "type") status <- Y[, 3] start <- Y[, 1] Y <- Y[, 2] ncol0 <- 3 } else stop("Illegal response value") if (any(c(Y, start) < 0)) stop("Negative follow up time") if(max(Y)<30) warning("The event times must be expressed in days! (Your max time in the data is less than 30 days) \n") # rdata contains the variables matching the ratetable rdata <- data.frame(eval(rcall, m), stringsAsFactors=TRUE) rtemp <- match.ratetable(rdata, ratetable) #this function puts the dates in R and in cutpoints in rtabledate R <- rtemp$R cutpoints <- rtemp$cutpoints if(is.null(attr(ratetable, "factor"))) attr(ratetable, "factor") <- (attr(ratetable, "type") ==1) attr(ratetable, "dimid") <- dimid rtorig <- attributes(ratetable) nrt <- length(rtorig$dimid) #checking if the ratetable variables are given in days wh.age <- which(dimid=="age") wh.year <- which(dimid=="year") if(length(wh.age)>0){ if (max(R[,wh.age])<150 & median(diff(cutpoints[[wh.age]]))>12) warning("Age in the ratetable part of the formula must be expressed in days! \n (Your max age is less than 150 days) \n") } # TMT -- note the new class if(length(wh.year)>0){ if(min(R[,wh.year])>1850 & max(R[,wh.year])<2020& inherits(cutpoints[[wh.year]], "rtdate")) warning("The calendar year must be one of the date classes (Date, POSIXt)\n (Your variable seems to be expressed in years) \n") } #checking if one of the continuous variables is fixed: if(nrt!=ncol(R)){ nonex <- which(is.na(match(rtorig$dimid,attributes(ratetable)$dimid))) for(it in nonex){ if(rtorig$type[it]!=1)warning(paste("Variable ",rtorig$dimid[it]," is held fixed even though it changes in time in the population tables. \n (You may wish to set a value for each individual and not just one value for all)",sep="")) } } #NEW in 2.05 (strata) # Now create the X matrix and strata strats <- attr(Term2, "specials")$strata if (length(strats)) { temp_str <- untangle.specials(Term2,"strata",1) if (length(temp_str$vars) == 1) strata.keep <- m[[temp_str$vars]] else strata.keep <- strata(m[,temp_str$vars],shortlabel=TRUE,sep=",") Term2 <- Term2[-temp_str$terms] } else strata.keep <- factor(rep(1,n)) # zgoraj ze definirano n = nrow(m) if (!missing(cause)) strata.keep <- factor(rep(1,n)) attr(Term2, "intercept") <- 1 # ignore a "-1" in the formula X <- model.matrix(Term2, m)[,-1, drop=FALSE] mm <- ncol(X) if (mm > 0 && !missing(centered) && centered) { mvalue <- colMeans(X) X <- X - rep(mvalue, each=nrow(X)) } else mvalue <- double(mm) cause <- model.extract(m, "cause") if(is.null(cause)) cause <- rep(2,nrow(m)) #NEW: ce cause manjka #status[cause==0] <- 0 keep <- Y > start if (!missing(int)) { int <- max(int) status[Y > int * 365.241] <- 0 Y <- pmin(Y, int * 365.241) keep <- keep & (start < int * 365.241) } if (any(start > Y) | any(Y < 0)) stop("Negative follow-up times") if (!all(keep)) { X <- X[keep, , drop = FALSE] Y <- Y[keep] start <- start[keep] status <- status[keep] R <- R[keep, ,drop=FALSE] strata.keep <- strata.keep[keep] # dodano za strato #NEW in 2.05 offset <- offset[keep] Y.surv <- Y.surv[keep, , drop = FALSE] cause <- cause[keep] n <- sum(keep) rdata <- rdata[keep,] } # I do not want to preserve variable class here - so paste R onto here, give it names temp <- R names(temp) <- paste0("X", 1:ncol(temp)) # with the right names #if variable class needs to be preserved, use this instead # variable class. So paste on rdata, but with the right order and names #temp <- rdata[,match(dimid, names(rdata))] # in the right order #names(temp) <- paste0("X", 1:ncol(temp)) # with the right names data <- data.frame(start = start, Y = Y, stat = status, temp) if (mm != 0) data <- cbind(data, X) # we pass the altered cutpoints forward, keep them in the date format (could be changed eventually to get rid of the date package dependence) attr(ratetable, "cutpoints") <- lapply(cutpoints, function(x) { if(inherits(x, 'rtabledate')) class(x) <- 'Date' x}) out <- list(data = data, R = R, status = status, start = start, Y = Y, X = as.data.frame(X), m = mm, n = n, type = type, Y.surv = Y.surv, Terms = Terms, ratetable = ratetable, offset = offset, formula=formula, cause = cause, mvalue=mvalue, strata.keep=strata.keep) # dodano za strato #NEW in 2.05 na.action <- attr(m, "na.action") if (length(na.action)) out$na.action <- na.action out } relsurv/R/plotrssurv.r0000644000176200001440000002345412700667377014632 0ustar liggesusersplot.rs.surv <- function (x, conf.int, mark.time = TRUE, mark = 3, col = 1, lty = 1, lwd = 1, cex = 1, log = FALSE, xscale = 1, yscale = 1, firstx = 0, firsty = 1, xmax, ymin = 0, fun, xlab = "", ylab = "", xaxs = "S", ...) { dotnames <- names(list(...)) if (any(dotnames == "type")) stop("The graphical argument 'type' is not allowed") if (is.logical(log)) { logy <- log logx <- FALSE if (logy) logax <- "y" else logax <- "" } else { logy <- (log == "y" || log == "xy") logx <- (log == "x" || log == "xy") logax <- log } if (missing(firstx)) { if (!is.null(x$start.time)) firstx <- x$start.time else { if (logx || (!missing(fun) && is.character(fun) && fun == "cloglog")) firstx <- min(x$time[x$time > 0]) else firstx <- min(0, x$time) } } firstx <- firstx/xscale if (missing(xaxs) && firstx != 0) xaxs <- par("xaxs") if (!inherits(x, "survfit")) stop("First arg must be the result of survfit") if (missing(conf.int)) { if (is.null(x$strata) && !is.matrix(x$surv)) conf.int <- TRUE else conf.int <- FALSE } #if (all.times == FALSE & x$method == 1){ #if (is.null(x$strata0)){ # nstrat <- 1 # stemp <- rep(1, length(x$index)) # length(x$time[x$index]) == length(x$index) # } # else { # nstrat <- length(x$strata0) # stemp <- rep(1:nstrat,x$strata0) # } #} #else { if (is.null(x$strata)) { nstrat <- 1 stemp <- rep(1, length(x$time)) } else { nstrat <- length(x$strata) stemp <- rep(1:nstrat, x$strata) } #} ssurv <- x$surv stime <- x$time supper <- x$upper slower <- x$lower #if (all.times == FALSE & x$method == 1){ # ssurv <- ssurv[x$index]; stime <- stime[x$index]; supper <- supper[x$index]; slower <- slower[x$index] #} if (!missing(xmax) && any(x$time > xmax)) { keepx <- keepy <- NULL yzero <- NULL tempn <- table(stemp) offset <- cumsum(c(0, tempn)) for (i in 1:nstrat) { ttime <- stime[stemp == i] if (all(ttime <= xmax)) { keepx <- c(keepx, 1:tempn[i] + offset[i]) keepy <- c(keepy, 1:tempn[i] + offset[i]) } else { bad <- min((1:tempn[i])[ttime > xmax]) if (bad == 1) { keepy <- c(keepy, 1 + offset[i]) yzero <- c(yzero, 1 + offset[i]) } else keepy <- c(keepy, c(1:(bad - 1), bad - 1) + offset[i]) keepx <- c(keepx, (1:bad) + offset[i]) stime[bad + offset[i]] <- xmax x$n.event[bad + offset[i]] <- 1 } } stime <- stime[keepx] stemp <- stemp[keepx] x$n.event <- x$n.event[keepx] if (is.matrix(ssurv)) { if (length(yzero)) ssurv[yzero, ] <- firsty ssurv <- ssurv[keepy, , drop = FALSE] if (!is.null(supper)) { if (length(yzero)) supper[yzero, ] <- slower[yzero, ] <- firsty supper <- supper[keepy, , drop = FALSE] slower <- slower[keepy, , drop = FALSE] } } else { if (length(yzero)) ssurv[yzero] <- firsty ssurv <- ssurv[keepy] if (!is.null(supper)) { if (length(yzero)) supper[yzero] <- slower[yzero] <- firsty supper <- supper[keepy] slower <- slower[keepy] } } } stime <- stime/xscale if (!missing(fun)) { if (is.character(fun)) { tfun <- switch(fun, log = function(x) x, event = function(x) 1 - x, cumhaz = function(x) -log(x), cloglog = function(x) log(-log(x)), pct = function(x) x * 100, logpct = function(x) 100 * x, stop("Unrecognized function argument")) if (fun == "log" || fun == "logpct") logy <- TRUE if (fun == "cloglog") { logx <- TRUE if (logy) logax <- "xy" else logax <- "x" } } else if (is.function(fun)) tfun <- fun else stop("Invalid 'fun' argument") ssurv <- tfun(ssurv) if (!is.null(supper)) { supper <- tfun(supper) slower <- tfun(slower) } firsty <- tfun(firsty) ymin <- tfun(ymin) } if (is.null(x$n.event)) mark.time <- FALSE if (is.matrix(ssurv)) ncurve <- nstrat * ncol(ssurv) else ncurve <- nstrat mark <- rep(mark, length.out = ncurve) col <- rep(col, length.out = ncurve) lty <- rep(lty, length.out = ncurve) lwd <- rep(lwd, length.out = ncurve) if (is.numeric(mark.time)) mark.time <- sort(mark.time) if (xaxs == "S") { xaxs <- "i" tempx <- max(stime) * 1.04 } else tempx <- max(stime) tempx <- c(firstx, tempx, firstx) if (logy) { tempy <- range(ssurv[is.finite(ssurv) & ssurv > 0]) if (tempy[2] == 1) tempy[2] <- 0.99 if (any(ssurv == 0)) { tempy[1] <- tempy[1] * 0.8 ssurv[ssurv == 0] <- tempy[1] if (!is.null(supper)) { supper[supper == 0] <- tempy[1] slower[slower == 0] <- tempy[1] } } tempy <- c(tempy, firsty) } else tempy <- c(range(ssurv[is.finite(ssurv)]), firsty) if (missing(fun)) { tempx <- c(tempx, firstx) tempy <- c(tempy, ymin) } plot(tempx, tempy * yscale, type = "n", log = logax, xlab = xlab, ylab = ylab, xaxs = xaxs, ...) if (yscale != 1) { if (logy) par(usr = par("usr") - c(0, 0, log10(yscale), log10(yscale))) else par(usr = par("usr")/c(1, 1, yscale, yscale)) } dostep <- function(x, y) { if (is.na(x[1] + y[1])) { x <- x[-1] y <- y[-1] } n <- length(x) if (n > 2) { dupy <- c(!duplicated(y)[-n], TRUE) n2 <- sum(dupy) xrep <- rep(x[dupy], c(1, rep(2, n2 - 1))) yrep <- rep(y[dupy], c(rep(2, n2 - 1), 1)) list(x = xrep, y = yrep) } else if (n == 1) list(x = x, y = y) else list(x = x[c(1, 2, 2)], y = y[c(1, 1, 2)]) } i <- 0 xend <- NULL yend <- NULL for (j in unique(stemp)) { who <- (stemp == j) xx <- c(firstx, stime[who]) nn <- length(xx) if (x$type == "counting") { #if (all.times == FALSE & x$method == 1){deaths <- c(-1,x$n.censor[x$index][who])} #else { deaths <- c(-1, x$n.censor[who]) #} zero.one <- 1 } else if (x$type == "right") { #if (all.times == FALSE & x$method == 1){deaths <- c(-1,x$n.censor[x$index][who])} #else { deaths <- c(-1, x$n.censor[who]) #} zero.one <- 1 } if (is.matrix(ssurv)) { for (k in 1:ncol(ssurv)) { i <- i + 1 yy <- c(firsty, ssurv[who, k]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) if (is.numeric(mark.time)) { indx <- mark.time for (k in seq(along.with = mark.time)) indx[k] <- sum(mark.time[k] > xx) points(mark.time[indx < nn], yy[indx[indx < nn]], pch = mark[i], col = col[i], cex = cex) } else if (mark.time && any(deaths >= zero.one)) { points(xx[deaths >= zero.one], yy[deaths >= zero.one], pch = mark[i], col = col[i], cex = cex) } xend <- c(xend, max(xx)) yend <- c(yend, min(yy)) if (conf.int && !is.null(supper)) { if (ncurve == 1) lty[i] <- lty[i] + 1 yy <- c(firsty, supper[who, k]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) yy <- c(firsty, slower[who, k]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) } } } else { i <- i + 1 yy <- c(firsty, ssurv[who]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) if (is.numeric(mark.time)) { indx <- mark.time for (k in seq(along = mark.time)) indx[k] <- sum(mark.time[k] > xx) points(mark.time[indx < nn], yy[indx[indx < nn]], pch = mark[i], col = col[i], cex = cex) } else if (mark.time == TRUE && any(deaths >= zero.one)) { points(xx[deaths >= zero.one], yy[deaths >= zero.one], pch = mark[i], col = col[i], cex = cex) } xend <- c(xend, max(xx)) yend <- c(yend, min(yy)) if (conf.int == TRUE && !is.null(supper)) { if (ncurve == 1) lty[i] <- lty[i] + 1 yy <- c(firsty, supper[who]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) yy <- c(firsty, slower[who]) lines(dostep(xx, yy), lty = lty[i], col = col[i], lwd = lwd[i]) } } } invisible(list(x = xend, y = yend)) } relsurv/R/rssurvrsadd.r0000644000176200001440000000654014731635751014743 0ustar liggesusers#' Compute a Relative Survival Curve from an additive relative survival model #' #' Computes the predicted relative survival function for an additive relative #' survival model fitted with maximum likelihood. #' #' Does not work with factor variables - you have to form dummy variables #' before calling the rsadd function. #' #' @param formula a \code{rsadd} object (Implemented only for models fitted #' with the codemax.lik (default) option.) #' @param newdata a data frame with the same variable names as those that #' appear in the \code{rsadd} formula. a predicted curve for each individual #' in this data frame shall be calculated #' @return a \code{survfit} object; see the help on \code{survfit.object} for #' details. The \code{survfit} methods are used for \code{print}, \code{plot}, #' \code{lines}, and \code{points}. #' @seealso \code{survfit}, \code{survexp} #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit a relative survival model #' fit <- rsadd(Surv(time,cens)~sex+age+year,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=c(0:10,15)) #' #' #calculate the predicted curve for a male individual, aged 65, diagnosed in 1982 #' d <- rs.surv.rsadd(fit,newdata=data.frame(sex=1,age=65,year=as.Date("1982-01-01"))) #' #plot the curve (will result in a step function since the baseline is assumed piecewise constant) #' plot(d,xscale=365.241) #' #' #calculate the predicted survival curves for each individual in the data set #' d <- rs.surv.rsadd(fit,newdata=rdata) #' #calculate the average over all predicted survival curves #' p.surv <- apply(d$surv,1,mean) #' #plot the relative survival curve #' plot(d$time/365.241,p.surv,type="b",ylim=c(0,1),xlab="Time",ylab="Relative survival") #' rs.surv.rsadd <- function (formula, newdata) { call <- match.call() Terms <- terms(formula$formula) #to rabis, ce je model mal bl smotan - as.factor ali splines ali svasta Terms <- delete.response(Terms) newdata <- model.frame(Terms,newdata) n <- formula$n if(formula$method=="max.lik"){ nvar <- length(formula$coef) - length(formula$int)+1 formula$coef <- formula$coef[1:nvar] } nvar <- length(formula$coef) nx <- nrow(newdata) nt <- length(formula$times) temp <- list(n=formula$n,time=formula$times,call=call,type="right") Lambda0 <- formula$Lambda0 Lambda0 <- matrix(Lambda0,ncol=nt,nrow=nx,byrow=TRUE) rate <- attr(Terms, "specials")$ratetable R <- as.matrix(newdata[, rate,drop=FALSE]) rat <- attributes(formula$ratetable)$dimid mein <- attributes(newdata[,rate])$dimnames[[2]] x <- match(rat,mein) R <- R[,x,drop=FALSE] newdata <- newdata[,1:nvar,drop=FALSE] if(any(formula$mvalue)>0)newdata <- newdata - matrix(formula$mvalue,nrow=nx,byrow=TRUE) R <- data.frame(R) names(R) <- rat ebx <- exp(data.matrix(newdata)%*%as.vector(formula$coef)) ebx <- matrix(ebx,ncol=nt,nrow=length(ebx)) Lambdae <- Lambda0*ebx temp$surv <- t(exp(-Lambdae)) temp$n.event <- rep(1,nt) temp$n.risk <- n+1 - cumsum(temp$n.event) temp$time <- formula$times class(temp) <- c("rs.surv.rsadd", "rs.surv","survfit") temp } relsurv/R/popsurv.R0000644000176200001440000000745414742212357014037 0ustar liggesusers#' Calculate the expected (population) survival #' #' For a given individual with sex, year, and age, calculate the expected (population) survival at the supplied time points based on the mortality tables. #' #' The follow-up time and age must be specified in days. The calendar year can be in any date format #' (Date and POSIXt are allowed) #' #' #' @param sex Either character ('male'/'female'), or integer (1/2). #' @param year The year from which the individual is followed. Either a Date or POSIXt object. Default is as.Date('1970-01-01'). #' @param age The age from which the individual is followed. Must be in days. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param times The times at which the expected (population) survival should be calculated. Must be in days. #' @return A vector containing the survival estimate at the supplied times. #' @seealso \code{\link{expprep2}} #' @examples #' #' library(relsurv) #' # Estimate P(T>2000 days) for a newborn: #' popsurv(sex='male', year=as.Date('1970-01-01'), age=0, ratetable=slopop, times=2000) #' # P(T>300 days) for a 50-year old: #' popsurv(sex='male', year=as.Date('1970-01-01'), age=50*365.241, ratetable=slopop, times=300) popsurv <- function(sex, year=as.Date('1970-01-01'), age=0, ratetable, times){ # year <- as.Date(paste0(year, '-01-01'), origin=as.Date('1970-01-01')) data <- data.frame(sex=sex, year=year, age=age) data$time <- max(times)+age data$status <- 1 if(age!=0) data$age <- 0 times <- as.numeric(times) formula <- Surv(age, time, status)~1 rform <- suppressWarnings(rformulate(formula, data, ratetable)) data <- rform$data times_arg <- times if(age!=0){ times_arg <- times_arg+age times_arg <- unique(c(age, times_arg)) rform$R[,"year"] <- rform$R[,"year"]-age } temp <- exp_prep(rform$R[,,drop=FALSE], rform$Y,rform$ratetable,rform$status,times=times_arg, fast=FALSE, cmp=FALSE, ys=as.numeric(age), netweiDM = TRUE) # if(age!=0 & length(times)>1) temp$yidli[1] <- 0 # return(exp(-sum(temp$yidli))) # out <- exp(-tail(temp$yidli,1)) out <- temp$yidli if(age!=0){ out <- out[2:length(out)] } out <- exp(-cumsum(out)) names(out) <- paste0('times=', times) return(out) } # TESTING: # library(dplyr) # library(survival) # library(relsurv) # library(ggplot2) # # # Define objects: # slopop <- relsurv::slopop # # slopop[,,] <- slopop["1","1970","male"] # tajms <- 5*365.241 # xvred <- seq(0, 95, 1) # # # Calculate survival at different times since age 0: # yvred <- sapply(xvred, function(xx) popsurv(sex='male', year=as.Date('1970-01-01'), 0, slopop, times=max(1,xx*365.241))) # yvred[1] <- 1 # popravi prvo vrednost # # Calculate 5-year conditional survival: # rez <- data.frame(x=xvred[1:91], y=(yvred/lag(yvred, 5))[6:96]) # # # Calculate 5-year conditional survival directly in popsurv: # yvred2 <- sapply(xvred, function(xx) popsurv(sex='male', year=as.Date('1970-01-01')+xx*365.241, # slopop, times=tajms, age = xx*365.241)) # # # Check: # plot(rez$x, rez$y, xlab='Age', ylab='5-year survival', ylim=c(0,1), type='s') # lines(rez$x[1:length(yvred2)], yvred2, col='red', type='s') # # plot(rez$x, rez$y - yvred2[1:nrow(rez)], type='s') # # plot(rez$x, -log(rez$y) + log(yvred2[1:nrow(rez)]), type='s') # # ggplot(rez)+ # geom_point(aes(x,y))+ # theme_bw()+ # scale_x_continuous(breaks = seq(0, 100, 10))+ # # scale_y_continuous(breaks = seq(0, 1, 0.2), limits=c(0,1))+ # # xlab('Age')+ # # ylab('5-year probability of dying')+ # # ggtitle('5-year probability of dying conditional on being alive at a given age')+ # theme(plot.title = element_text(hjust = 0.5)) relsurv/R/years.R0000644000176200001440000016565714742212124013446 0ustar liggesuserscolVars <- function(x, na.rm = FALSE){ f <- function(v, na.rm = na.rm) { if(is.numeric(v) || is.logical(v) || is.complex(v)) stats::var(v, na.rm = na.rm) else NA } return(unlist(lapply(x, f, na.rm = na.rm))) } # Copied function from mstate:::NAfix. mstateNAfix <- function (x, subst = -Inf) { spec <- max(x[!is.na(x)]) + 1 x <- c(spec, x) while (any(is.na(x))) x[is.na(x)] <- x[(1:length(x))[is.na(x)] - 1] x[x == spec] <- subst x <- x[-1] x } # Helper function: nessie_spi <- function(formula = formula(data), data, ratetable = relsurv::slopop, tis, starting.time, include.censoring=FALSE, arg.example=FALSE, rmap){ data_orig <- data call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } na.action <- NA rform <- rformulate(formula, data, ratetable, na.action, rmap) data <- rform$data data$Xs <- rep(1, nrow(data)) n_rows <- nrow(data) # Fix demographic covariates: if(starting.time == "left.truncated"){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(include.censoring){ # browser() wh <- which(rform$status==1) rform$Y[wh] <- max(rform$Y) if(arg.example){ wh2 <- which(rform$status==1 & data$age==18262) rform$Y[wh2] <- 1826 } } else{ rform$Y <- rep(max(rform$Y), length(rform$Y)) # status is not relevant in this case } out <- NULL out$yi <- NULL out$yidli <- NULL l_tis <- length(tis) temps <- lapply(1:n_rows, function(inx) { temp <- exp_prep(rform$R[inx, , drop = FALSE], rform$Y[inx], rform$ratetable, rform$status[inx], times = tis, fast = TRUE, cmp=FALSE,ys=data$start[inx]) s_pi <- exp(-cumsum(temp$yidli)) s_pi_helper <- which.min(temp$yidli==0)-1 if(s_pi_helper>1){ s_pi[1:s_pi_helper] <- 0} if(include.censoring){ s_pi[(s_pi_helper+1):l_tis] <- pmin(s_pi[(s_pi_helper+1):l_tis], temp$yi[(s_pi_helper+1):l_tis])} c(s_pi, # s_pi temp$yidli*s_pi) # l_pi * s_pi }) temps2 <- do.call("cbind", temps) temps2 <- rowSums(temps2) out$yi <- temps2[1:(length(temps2)/2)] out$yidli <- temps2[(length(temps2)/2+1):length(temps2)] return(out) } # Copied scales::trans_new: # scales_trans_new <- function (name, transform, inverse, breaks = extended_breaks(), # minor_breaks = regular_minor_breaks(), format = format_format(), # domain = c(-Inf, Inf)) # { # if (is.character(transform)) # transform <- match.fun(transform) # if (is.character(inverse)) # inverse <- match.fun(inverse) # structure(list(name = name, transform = transform, inverse = inverse, # breaks = breaks, minor_breaks = minor_breaks, format = format, # domain = domain), class = "trans") # } #' Compute one of the life years measures #' #' Provides an estimate for one of the following measures: years lost (Andersen, 2013), years lost/saved (Andersen, 2017), or #' life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). #' #' The life years difference (\code{measure='yd'}) is taken by default. If other #' measures are of interest, use the \code{measure} argument. #' #' The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with the \code{rmap} argument. For example, if #' age is in years in the data but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' Numerical integration is performed, argument #' precision is set with argument \code{precision}, which defaults to 30-day #' intervals for intergration. For higher accuracy take a smaller value (e.g. precision=1 makes #' the integration on a daily basis). #' #' The observed curves are reported at event and censoring times. The #' population curves are reported at all times used for the numerical integration. #' Note that for the years lost (Andersen, 2013) measure, only the excess absolute risk is reported. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, \code{~1} specified on the right. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param measure choose which measure is used: 'yd' (life years difference; Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022), 'yl2017' (years lost/saved; Andersen 2017), #' 'yl2013' (years lost/saved; Andersen 2013). #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param var.estimator Choose the estimator for the variance ('none', 'bootstrap', 'greenwood'). Default is 'none'. #' The 'greenwood' option is possible only for \code{measure='yd'}. #' @param B if \code{var.estimator} is 'bootstrap'. The number of bootstrap replications. Default is 100. #' @param precision precision for numerical integration of the population curve. Default is 30 (days). #' The value may be decreased to get a #' higher precision or increased to achieve a faster calculation. #' @param add.times specific times at which the curves should be reported. #' @param na.action a missing-data filter function. Default is \code{na.omit}. #' @param conf.int the confidence level for a two-sided confidence interval. Default is 0.95. #' @param timefix the timefix argument in survival::survfit.formula. Default is FALSE. #' @param is.boot if TRUE, the function \code{years} has been called during a bootstrap replication. #' @param first.boot if TRUE, this is the first bootstrap replication. #' @return A list containing the years measure, the observed and population curves (or the excess curve for Andersen 2013). #' The values are given as separate data.frames through time. Times are given in days, all areas are given in years. #' For \code{measure='yl2017'} values are reported only at the last time point. #' Functions \code{plot_f} and \code{plot_years} can be then used for plotting. #' @seealso \code{\link{plot_f}}, \code{\link{plot_years}} #' @examples #' #' library(relsurv) #' # Estimate the life years difference for the rdata dataset. #' mod <- years(Surv(time, cens)~1, data=rdata, measure='yd', ratetable=slopop, #' rmap=list(age=age*365.241), var.estimator = 'none') #' # Plot the absolute risk (observed and population curve): #' plot_f(mod) #' # Plot the life years difference estimate: #' plot_years(mod, conf.int=FALSE) years <- function( formula=formula(data), data, measure=c('yd', 'yl2017', 'yl2013'), # estimator=c("F_P_final"),#, "F_P_Spi", "F_P_Spi2", "F_P", "F_P2", "all"), ratetable=relsurv::slopop, rmap, var.estimator=c('none', 'bootstrap', 'greenwood'), B=100, precision=30, add.times, na.action=stats::na.omit, conf.int=0.95, timefix=FALSE, # admin.cens, # cause.val, is.boot=FALSE, first.boot=FALSE # ,estimator.observed='Kaplan-Meier' ){ # OLD ARGUMENTS: # F_P_Spi: Tako kot F_P_final, ignorira censoring. Ali pa vzame samo admin cens # F_P_Spi2: Vzame ves censoring # @param cause.val for competing risks, to be added. # @param admin.cens if a Date is supplied, administrative censoring is taken into account at that time # in the population curve. Works only if there's late entry, e.g. if the formula is \code{Surv(start,stop,event)~1}. ############ # # PREPARE OBJECTS: ############ # estimator=c("F_P_final") # #' @param estimator which estimator should be used for calculating # estimator <- match.arg(estimator) arg.example <- FALSE # @param arg.example temporary argument, used for checking additionalities. Call <- match.call() if(!missing(rmap) & !is.boot & !first.boot) rmap <- substitute(rmap) measure <- match.arg(measure) var.estimator <- match.arg(var.estimator) if(var.estimator=='bootstrap'){ bootstrap <- TRUE } else if(var.estimator %in% c('none', 'greenwood')){ bootstrap <- FALSE } else{ stop('Incorrect value provided in argument var.estimator.') } if(!is.data.frame(data)) stop('Argument data is not a data.frame object.') data <- as.data.frame(data) out <- NULL late.values <- FALSE # These were arguments. To be deleted? exact.hazards <- FALSE # calculate hazards on a daily basis (to be checked) find.cond.time <- FALSE # if TRUE, return time at which there are at least 5 individuals in the at-risk set. # if(!missing(cause.val)){ # data$status <- ifelse(data$cause == cause.val, 1, 0) # # Remove NAs: # eniNAs <- which(is.na(data$status)) # if(length(eniNAs)>0) data <- data[-eniNAs,] # } # data$age <- round(data$age*365.241) # data$stop <- round(data$stop*365.241) # If Surv(start,stop, event) (possibly + mstate) if_start_stop <- length(as.character(formula[[2]])) %in% c(4,5) if(if_start_stop){ start_col <- as.character(formula[[2]])[2] stop_col <- as.character(formula[[2]])[3] status_col <- as.character(formula[[2]])[4] starting_age <- as.vector(as.matrix(data[, start_col])) } else{ stop_col <- as.character(formula[[2]])[2] if(!(stop_col %in% colnames(data))){ stop(paste0('Instead of \'', stop_col, '\', please use a column from the data in the formula.')) } } # Check if no. at risk falls to zero at some point: if(if_start_stop){ # Prepare at-risk matrix: find_tajms <- unique(sort(c(data[,start_col], data[,stop_col]))) mat <- lapply(1:nrow(data), function(x) ifelse((data[x, start_col] < find_tajms) & (find_tajms <= data[x, stop_col]), 1, 0)) mat2 <- matrix(unlist(mat), nrow = nrow(data), byrow = TRUE) # The sum of the individual at-risk processes: yi_left <- colSums(mat2) # If there's an empty at-risk at a later timepoint, censor the data: wh_yi <- which(yi_left==0) if(length(wh_yi)>1){ if((!is.boot) & (!first.boot)){ warning(paste0('In the time interval ', find_tajms[wh_yi[2]-1], '-', find_tajms[wh_yi[2]], ' the at-risk sample is empty (nobody is followed). Survival cannot be estimated in this time interval.', ' The data is censored at time ', find_tajms[wh_yi[2]-1], '.')) } # Censor data: data <- data[data[,start_col] <= find_tajms[wh_yi[2]-1], ] wh_cen <- which(data[, stop_col] > find_tajms[wh_yi[2]-1]) data[wh_cen, stop_col] <- find_tajms[wh_yi[2]-1] data[wh_cen, status_col] <- 0 if(!missing(add.times)){ if(any(add.times > find_tajms[wh_yi[2]-1])) add.times <- add.times[add.times<=find_tajms[wh_yi[2]-1]] } } rm(mat,mat2) } data_orig <- data # if(starting.time=="left.truncated"){ # if(!missing(admin.cens)){ # if(!inherits(admin.cens, 'Date')) warning('Object of class Date should be supplied to admin.cens.') # end_date <- data$year+(data$stop-data$age) # if(any(end_date > admin.cens)) warning('There are events that occur after the date of administrative censoring. Please check the values in arguments data and admin.cens.') # id_admin_cens <- which(admin.cens==end_date) # } # } if(if_start_stop){ starting.time <- 'left.truncated' } else{ starting.time <- 'zero' } # Starting age starting_age <- rep(0,nrow(data)) if(if_start_stop){ starting_age <- as.vector(as.matrix(data[, start_col])) } starting_age <- as.numeric(starting_age) ############ # # YEARS ON DATA - GENERAL: ############ # surv_obj <- as.character(formula[[2]]) if(missing(formula)){ stop('Missing formula argument value.') } else{ if('mstate' %in% surv_obj){ juh <- 1:nrow(data) mod <- survival::survfit.formula(as.formula(Reduce(paste, deparse(formula))), data=data, timefix=timefix, id = juh, na.action=na.action) } else{ mod <- survival::survfit.formula(formula, data=data, timefix=timefix, na.action=na.action) } } if('mstate' %in% surv_obj){ surv_obj_new <- paste0(surv_obj[1], '(', surv_obj[2], ',', surv_obj[3]) if(length(surv_obj)==5){ surv_obj_new <- paste0(surv_obj_new, ',', surv_obj[4], ')') } else{ surv_obj_new <- paste0(surv_obj_new, ')') } formula <- paste0(surv_obj_new, '~1') } status_obj <- surv_obj[length(surv_obj)] # if(!missing(cause.val)){ # mod$n.risk <- mod$n.risk[,1] # mod$n.event <- mod$n.event[,cause.val+1] # mod$surv <- 1-mod$pstate[,cause.val+1] # mod$std.err <- mod$std.err[,cause.val+1] # mod$cumhaz <- mod$cumhaz[,cause.val] # } if(!missing(add.times)){ mod_sum <- summary(mod, times = sort(unique(c(mod$time, add.times)))) if(any(!(add.times %in% mod_sum$time))){ if(!is.boot){ if(!first.boot){ warning('Some values in add.times are after the last follow-up time. All measures are extrapolated up to these times. Please consider removing them.') } late.values <- TRUE miss_tajms <- add.times[!(add.times %in% mod_sum$time)] mod_sum$time <- c(mod_sum$time, miss_tajms) mod_sum$n.risk <- c(mod_sum$n.risk, rep(mod_sum$n.risk[length(mod_sum$n.risk)], length(miss_tajms))) mod_sum$n.event <- c(mod_sum$n.event, rep(0, length(miss_tajms))) mod_sum$surv <- c(mod_sum$surv, rep(mod_sum$surv[length(mod_sum$surv)], length(miss_tajms))) mod_sum$cumhaz <- c(mod_sum$cumhaz, rep(mod_sum$cumhaz[length(mod_sum$cumhaz)], length(miss_tajms))) # First fix std.err: if(is.nan(mod_sum$std.err[length(mod_sum$std.err)])){ mod_sum$std.err[length(mod_sum$std.err)] <- mod_sum$std.err[length(mod_sum$std.err) - 1] } mod_sum$std.err <- c(mod_sum$std.err, rep(mod_sum$std.err[length(mod_sum$std.err)], length(miss_tajms))) } } mod$time <- mod_sum$time mod$n.risk <- mod_sum$n.risk mod$n.event <- mod_sum$n.event mod$surv <- mod_sum$surv mod$std.err <- mod_sum$std.err mod$cumhaz <- mod_sum$cumhaz } if(find.cond.time) return(mod$time[which.min(mod$n.risk<5)]) # Calculate AUC: if(length(mod$time)>1){ if(if_start_stop){ survs <- c(1, mod$surv[1:(length(mod$surv)-1)]) t_diff <- diff(c(mod$time[1], mod$time)) } else{ survs <- mod$surv t_diff <- diff(c(0, mod$time)) } auc_data <- sum(t_diff*(1 - survs)) auc_data_vec <- cumsum(t_diff*(1 - survs)) } else{ auc_data <- mod$time*mod$surv auc_data_vec <- auc_data } out$F_data <- 1-mod$surv out$auc_data <- auc_data/365.241 out$auc_data_vec <- auc_data_vec/365.241 # Exact hazards: if(exact.hazards){ mod$time <- seq(min(mod$time), max(mod$time), by=1) mod$surv <- exp(-cumsum(rep(ratetable[1,1,1], max(mod$time)-min(mod$time)+1))) out$F_data <- 1-exp(-cumsum(c(0, rep(ratetable[1,1,1], max(mod$time)-min(mod$time))))) out$auc_data <- sum(out$F_data)/365.241 } ############ # # SEPARATE YEARS FOR EVERY MEASURE: ############ # if(measure %in% c('yl2017', 'yl2013')){ # YL_P preparation: data_yi <- data rform <- rformulate(formula, data, ratetable, na.action=na.action, rmap = rmap) data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out_n <- table(data$Xs) #table of strata out$time <- out$haz.excess <- out$haz.pop <- out$std.err <- out$strata <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum # tis <- sort(unique(rform$Y[inx])) #unique times if(!if_start_stop){ tis <- rform$Y[inx] #unique times tis_seq <- seq(0, max(rform$Y[inx]), precision) } else{ tis <- sort(unique(c(rform$Y[inx], data[, start_col]))) #unique times tis_seq <- seq(min(data[, start_col]), max(rform$Y[inx], data[, start_col]), precision) } if(!is.boot){ tis <- sort(unique(c(tis, tis_seq))) } if(!missing(add.times)){ tis <- sort(unique(c(tis, add.times))) } ltis <- length(tis) # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(measure == 'yl2017'){ # YL_O (used only for yl2017): if(if_start_stop){ it_auc <- rep(NA, nrow(data_orig)) mod_sum <- summary(mod, times=tis) # unique(sort(c(data_orig[,start_col], data_orig[,stop_col]))) lsurv <- length(mod_sum$surv) val_mat <- matrix(0, nrow=nrow(data_orig), ncol=lsurv) for(it in 1:nrow(data_orig)){ it_wh <- which(data_orig[it, start_col] == mod_sum$time) it_surv <- mod_sum$surv[it_wh:lsurv]/mod_sum$surv[it_wh] it_auc[it] <- sum(c(0, diff(mod_sum$time[it_wh:lsurv]))*(1 - it_surv))/365.241 val_mat[it, it_wh:lsurv] <- cumsum(c(0, diff(mod_sum$time[it_wh:lsurv]))*(1 - it_surv))/365.241 } # spodaj <- mod_sum$n.risk + cumsum(mod_sum$n.event) + cumsum(mod_sum$n.censor) YL_O_vec <- colMeans(val_mat) # colSums(val_mat)/spodaj YL_O <- mean(it_auc) F_O_time <- mod_sum$time F_O_ext <- data.frame(time=F_O_time, area=YL_O_vec) # Subset: F_O_ext2 <- subset(F_O_ext, time %in% mod$time) F_O_time <- F_O_ext2$time YL_O_vec <- F_O_ext2$area } else{ YL_O_vec <- out$auc_data_vec YL_O <- out$auc_data F_O_time <- mod$time if(!(0 %in% F_O_time)){ F_O_time <- c(0, F_O_time) YL_O_vec <- c(0, YL_O_vec) } # Prepare extended F_O object: if(0 %in% mod$time){ F_O_temp <- data.frame(time=mod$time, surv=mod$surv) } else{ F_O_temp <- data.frame(time=c(0, mod$time), surv=c(1, mod$surv)) } F_O_ext <- data.frame(time=tis) F_O_ext <- merge(F_O_ext, F_O_temp, by='time', all.x=TRUE) F_O_ext$surv <- mstateNAfix(F_O_ext$surv, 0) tis_diff <- diff(c(0, F_O_ext$time)) F_O_ext$area <- cumsum(tis_diff*(1 - F_O_ext$surv))/365.241 F_O_ext <- F_O_ext[,c('time', 'area')] } F_O <- data.frame(time=F_O_time, area=YL_O_vec) ### # YL_P continue: it_auc_P <- rep(NA, nrow(data)) it_auc_P_mat <- matrix(0, nrow=nrow(data), ncol=ltis) for(it in 1:nrow(data)){ temp <- exp_prep(rform$R[it,,drop=FALSE],max(rform$Y),rform$ratetable,rform$status[it],times=tis,fast=FALSE, cmp=FALSE, ys=starting_age[it], netweiDM = FALSE) if(if_start_stop){ it_wh <- which(data[it, start_col] == tis) hazs <- temp$yidli[it_wh:ltis] hazs[1] <- 0 cumhazs <- cumsum(hazs) F_P <- 1 - exp(-cumhazs) it_auc_P[it] <- sum(c(tis[it_wh], diff(tis[it_wh:ltis]))*c(0, F_P[1:(length(F_P)-1)]))/365.241 it_auc_P_mat[it,it_wh:ltis] <- cumsum(c(0, diff(tis[it_wh:ltis]))*c(0, F_P[1:(length(F_P)-1)]))/365.241 } else{ # it_wh <- which(data$age[it] == tis) hazs <- temp$yidli[1:ltis] hazs[1] <- 0 cumhazs <- cumsum(hazs) F_P <- 1 - exp(-cumhazs) it_auc_P[it] <- sum(c(0, diff(tis))*c(0, F_P[1:(length(F_P)-1)]))/365.241 it_auc_P_mat[it,] <- cumsum(c(0, diff(tis))*c(0, F_P[1:(length(F_P)-1)]))/365.241 } } YL_P <- mean(it_auc_P) F_P <- data.frame(time=tis, area=colMeans(it_auc_P_mat)) yd_curve <- data.frame(time=tis, est=F_O_ext$area - F_P$area) # Bootstrap: if(bootstrap){ data_b <- data_orig data_b$id <- 1:nrow(data_b) yl_boot <- ylboot(theta=ylboot.iter, data=data_b, id="id", B=B, verbose=0, #all_times = all_times, ratetable=ratetable#, add.times=add.times , starting.time, estimator, precision, add.times = add.times, formula = formula, rmap = rmap, measure=measure ) if(ncol(yl_boot[[2]])>nrow(F_O)){ varsincol <- colVars(yl_boot[[2]], na.rm=TRUE)^(1/2) varsincol_df <- data.frame(time=yl_boot[[4]], area.se=varsincol) varsincol_df <- varsincol_df[varsincol_df$time %in% F_O$time,] F_O$area.se <- varsincol_df$area.se } else{ F_O$area.se <- colVars(yl_boot[[2]], na.rm=TRUE)^(1/2) } F_P$area.se <- colVars(yl_boot[[3]], na.rm=TRUE)^(1/2) yl_boot <- as.data.frame(t(yl_boot[[1]])) yd_curve$est.se <- (colVars(yl_boot, na.rm=TRUE))^(1/2) } # Add CI: if((!is.boot) & (!first.boot)){ if(!is.null(yd_curve$est.se)){ yd_curve$lower <- yd_curve$est - yd_curve$est.se*stats::qnorm(0.5+conf.int/2) yd_curve$upper <- yd_curve$est + yd_curve$est.se*stats::qnorm(0.5+conf.int/2) } } # Values to be reported: if((!is.boot) & (!first.boot)){ if(if_start_stop){ # Report only at last time point - the values until this time are not suitable to report: out <- list(years=utils::tail(yd_curve,1), F_O=utils::tail(F_O,1), F_P=utils::tail(F_P,1), measure=measure) } else{ # Report full measures: out <- list(years=yd_curve, F_O=F_O, F_P=F_P, measure=measure) } } else{ out <- list(years=yd_curve, F_O=F_O, F_P=F_P, measure=measure) } return(out) } else{ # measure == 'yl2013' temp <- exp_prep(rform$R[,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status,times=tis, fast=TRUE, cmp=FALSE, ys=starting_age) temp$yi[temp$yi==0] <- Inf # Calculate measures: haz.pop <- temp$yidli/temp$yi mod_tis <- summary(mod, times = tis) F_E <- cumsum(mod_tis$surv*(mod_tis$n.event/mod_tis$n.risk - haz.pop)) ltis <- length(tis) # To be checked, doesn't work ok # # Var as in Pavlic2018: # F_E_st <- sapply(1:ltis, function(s){ # (sum(mod_tis$surv[s:ltis]*(mod_tis$n.event[s:ltis]/mod_tis$n.risk[s:ltis] - haz.pop[s:ltis]))/mod_tis$surv[s]) # *c(0, diff(tis[s:ltis])) /365.241 # }) # # Klemnova: # F_Ese <- (cumsum((mod_tis$surv)^2*(1 - F_E_st)^2*((mod_tis$n.event)/(mod_tis$n.risk^2))*c(0, diff(tis)))/365.241)^(1/2) # surv_int <- rev(cumsum(rev(c(0, diff(tis))*c(1, mod_tis$surv[1:(length(mod_tis$surv)-1)])))/365.241) # # # Moja: # F_E_int <- rev(cumsum(rev(c(0, diff(tis))*c(0, F_E[1:(length(F_E)-1)])))/365.241) # F_Ese <- (cumsum((surv_int)^2*(1 - F_E_st)^2*((mod_tis$n.event)/(mod_tis$n.risk^2))*c(0, diff(tis)))/365.241)^(1/2) # # # Observed: # F_Ese <- (cumsum(surv_int^2*((mod_tis$n.event)/(mod_tis$n.risk^2))*c(0, diff(tis)))/365.241)^(1/2) # # # Predlog glede na Andersen 2013: # F_Ese <- (cumsum((surv_int^2*(mod_tis$n.event - temp$yidli) + F_E_int^2*temp$yidli)/(mod_tis$n.risk^2)*c(0, diff(tis)))/365.241)^(1/2) # Calculate measures: YL <- cumsum(F_E*c(0, diff(tis)))/365.241 F_E_area <- cumsum(c(0, diff(tis))*c(0, F_E[1:(length(F_E)-1)]))/365.241 F_E_df <- data.frame(time=tis, prob=F_E, area=F_E_area) # , prob.se=F_Ese yd_curve <- data.frame(time=tis, est=YL) # Bootstrap: if(bootstrap){ data_b <- data_orig data_b$id <- 1:nrow(data_b) yl_boot <- ylboot(theta=ylboot.iter, data=data_b, id="id", B=B, verbose=0, #all_times = all_times, ratetable=ratetable#, add.times=add.times , starting.time, estimator, precision, add.times = add.times, formula = formula, rmap = rmap, measure=measure ) # Calculate area.se: area.se <- yl_boot[[2]] for(itar in 1:nrow(yl_boot[[2]])){ prob_tmp <- as.vector(as.matrix(yl_boot[[2]][itar,])) area_tmp <- cumsum(c(0, diff(tis))*c(0, prob_tmp[1:(length(prob_tmp)-1)]))/365.241 area.se[itar,] <- area_tmp } area.se <- as.vector(colVars(area.se, na.rm=TRUE)) F_E_df$prob.se <- (colVars(yl_boot[[2]], na.rm=TRUE))^(1/2) F_E_df$area.se <- area.se yl_boot <- as.data.frame(t(yl_boot[[1]])) yd_curve$est.se <- (colVars(yl_boot, na.rm=TRUE))^(1/2) } if((!is.boot) & (!first.boot)){ if(!is.null(yd_curve$est.se)){ yd_curve$lower <- yd_curve$est - yd_curve$est.se*stats::qnorm(0.5+conf.int/2) yd_curve$upper <- yd_curve$est + yd_curve$est.se*stats::qnorm(0.5+conf.int/2) } } out <- list(years=yd_curve, F_E=F_E_df, measure=measure) return(out) } } else{ # measure == 'yd' ################################################### # # CIF on population: data_yi <- data rform <- rformulate(formula, data, ratetable, na.action=na.action, rmap = rmap) data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out_n <- table(data$Xs) #table of strata out$time <- out$haz.excess <- out$haz.pop <- out$std.err <- out$strata <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum if(!if_start_stop) tis <- sort(unique(c(rform$Y[inx], seq(0, max(rform$Y[inx]), precision)))) #unique times else tis <- sort(unique(c(rform$Y[inx], data[, start_col], seq(min(data[, start_col]), max(rform$Y[inx], data[, start_col]), precision)))) #unique times if(!missing(add.times)){ tis <- sort(unique(c(tis, add.times))) } # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } ### # # Greenwood Variance of area (not F): # First prepare objects: mod_gw <- summary(mod, times = tis) gw_df <- data.frame(time=mod_gw$time, surv=mod_gw$surv, n.risk=mod_gw$n.risk, n.event=mod_gw$n.event) # Then calculate: times_all2 <- c(0, diff(gw_df$time))/365.241 surv_all <- c(1, gw_df$surv[1:(length(gw_df$surv)-1)]) auc_all <- cumsum(times_all2*surv_all) area_var <- sapply(1:length(auc_all), function(x) { numer <- gw_df$n.risk[1:x]*(gw_df$n.risk[1:x] - gw_df$n.event[1:x]) numer[numer==0] <- Inf sum(((auc_all[x] - auc_all[1:x])^2*gw_df$n.event[1:x])/numer) }) if(is.nan(area_var[length(area_var)])){ area_var[length(area_var)] <- area_var[length(area_var)-1] } ### # if(estimator=='F_P' | estimator=="all"){ # Prepare at-risk matrix: # browser() # mat <- lapply(1:nrow(data), function(x) ifelse((data$start[x] < tis) & (tis <= data$Y[x]), 1, NA)) # mat2 <- matrix(unlist(mat), nrow = nrow(data_yi), byrow = TRUE) # # The sum of the individual at-risk processes: # yi_left <- colSums(mat2) # yi_left[yi_left == 0] <- Inf # # mat3 <- lapply(1:nrow(data), function(x) data$age[x] + c(0, diff(tis))) if(any(rform$Y[inx]<=starting_age)) browser() temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE, cmp=FALSE, ys=starting_age) # Fix at-risk process, if needed: temp$yi[temp$yi==0] <- Inf out$time <- c(out$time, tis) #add times # Calculate hazards: haz.pop <- temp$yidli/temp$yi out$haz.pop <- c(out$haz.pop,haz.pop) out$cum.haz.pop <- cumsum(out$haz.pop) out$F_P <- 1-exp(-out$cum.haz.pop) out$auc_pop <- sum(c(tis[1], diff(tis))*c(0, out$F_P[1:(length(out$F_P)-1)]))/365.241 } data_spi2 <- data if(estimator=='F_P_Spi2' | estimator=="all"){ if(any(data_spi2$start>=data_spi2$Y)) browser() # Take into account censoring: exp.surv2 <- nessie_spi(Surv(start, Y, stat)~1, data=data_spi2, ratetable=ratetable, tis=tis, starting.time=starting.time, include.censoring = TRUE, arg.example) out$haz.pop.spi2 <- exp.surv2$yidli/exp.surv2$yi out$cum.haz.pop.spi2 <- cumsum(out$haz.pop.spi2) out$F_P_Spi2 <- 1-exp(-out$cum.haz.pop.spi2) out$auc_pop_Spi2 <- sum(c(tis[1], diff(tis))*c(0, out$F_P_Spi2[1:(length(out$F_P_Spi2)-1)]))/365.241 } if(estimator=='F_P_Spi' | estimator=="all"){ if(TRUE){ # (!missing(admin.cens)) - tega nimamo vec data_spi2$stat <- 1 # data_spi2$stat[id_admin_cens] <- 0 # - tole ni bilo zakomentirano, ko smo imeli admin.cens exp.surv <- nessie_spi(Surv(start, Y, stat)~1, data=data_spi2, ratetable=ratetable, tis=tis, starting.time=starting.time, include.censoring = TRUE, arg.example) } else{ # Don't take into account censoring: exp.surv <- nessie_spi(Surv(start, Y, stat)~1, data=data_spi2, ratetable=ratetable, tis=tis, starting.time=starting.time, include.censoring = FALSE, arg.example) } out$haz.pop.spi <- exp.surv$yidli/exp.surv$yi out$cum.haz.pop.spi <- cumsum(out$haz.pop.spi) out$F_P_Spi <- 1-exp(-out$cum.haz.pop.spi) out$auc_pop_Spi <- sum(c(tis[1], diff(tis))*c(0, out$F_P_Spi[1:(length(out$F_P_Spi)-1)]))/365.241 } if(estimator=='F_P_final'){ # Shift all to the end: if(if_start_stop) data_yi[,stop_col] <- max(data_yi[,stop_col]) rform2 <- rform rform <- rformulate(formula, data_yi, ratetable, na.action=na.action, rmap = rmap) # Shift all to the end: if(!if_start_stop){ rform$Y <- rep(max(rform$Y), length(rform$Y)) rform$data[,"Y"] <- rform$Y } data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out$haz.pop2 <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(any(starting_age>=rform$Y[inx])) browser() temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=FALSE, cmp=FALSE, ys=starting_age, netweiDM = TRUE) temp$sidliD[1] <- 0 # temp$sisD[1] <- 1 temp$sisD[temp$sisD==0] <- Inf haz.pop2 <- temp$sidliD/temp$sisD out$haz.pop2 <- c(out$haz.pop2, haz.pop2) out$cum.haz.pop2 <- cumsum(out$haz.pop2) out$F_P2 <- 1-exp(-out$cum.haz.pop2) out$auc_pop2 <- sum(c(tis[1], diff(tis))*c(0, out$F_P2[1:(length(out$F_P2)-1)]))/365.241 out$sidli <- temp$sidli out$sis <- temp$sis # DODATEK: haz.pop.ves.cas <- temp$sidli haz.pop.ves.cas[1] <- 0 haz.pop.ves.cas <- haz.pop.ves.cas/temp$sis out$cum.haz.pop.ves.cas <- cumsum(haz.pop.ves.cas) out$F_P_ves_cas <- 1 - exp(-out$cum.haz.pop.ves.cas) out$auc_pop_ves_cas <- sum(c(tis[1], diff(tis))*c(0, out$F_P_ves_cas[1:(length(out$F_P_ves_cas)-1)]))/365.241 } if(estimator=='F_P2' | estimator=="all"){ # Shift all to the end: if(if_start_stop) data_yi[,stop_col] <- max(data_yi[,stop_col]) rform2 <- rform rform <- rformulate(formula, data_yi, ratetable, na.action=na.action, rmap = rmap) # Shift all to the end: if(!if_start_stop){ rform$Y <- rep(max(rform$Y), length(rform$Y)) rform$data[,"Y"] <- rform$Y } data <- rform$data if(if_start_stop){ if(!(start_col %in% colnames(data))){ data[,start_col] <- data_orig[, start_col] } } # Check covariates: p <- rform$m if (p > 0) stop("There shouldn't be any covariates in the formula. This function gives non-parametric estimates of the hazards.") else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 out$haz.pop2 <- NULL kt <- 1 # the only stratum inx <- which(data$Xs == names(out_n)[kt]) #individuals within this stratum # Fix demographic covariates: if(if_start_stop){ rform$R[,"year"] <- rform$R[,"year"] - rform$R[,"age"] rform$R[,"age"] <- 0 } if(any(starting_age>=rform$Y[inx])) browser() # temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE, cmp=FALSE, ys=0) temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=TRUE, cmp=FALSE, ys=starting_age) # Fix at-risk process, if needed: temp$yi[temp$yi==0] <- Inf # Calculate hazards: haz.pop2 <- temp$yidli/temp$yi out$haz.pop2 <- c(out$haz.pop2, haz.pop2) out$cum.haz.pop2 <- cumsum(out$haz.pop2) out$F_P2 <- 1-exp(-out$cum.haz.pop2) # out$auc_pop2 <- sum(c(tis[1], diff(tis))*out$F_P2)/365.241 out$auc_pop2 <- sum(c(tis[1], diff(tis))*c(0, out$F_P2[1:(length(out$F_P2)-1)]))/365.241 } ### # Bootstrap: if(bootstrap){ # browser() data_b <- data_orig data_b$id <- 1:nrow(data_b) yl_boot <- ylboot(theta=ylboot.iter, data=data_b, id="id", B=B, verbose=0, #all_times = all_times, ratetable=ratetable#, add.times=add.times , starting.time, estimator, precision, add.times = add.times, formula = formula, rmap = rmap, measure=measure ) L_OP <- yl_boot[[3]] F_boot <- yl_boot[[2]] yl_boot <- as.data.frame(t(yl_boot[[1]])) } ### estimator.orig <- estimator if(estimator=='F_P_final') estimator = 'F_P2' out$strata <- c(out$strata, length(tis)) #number of times in this strata names(out$strata) <- names(out_n) out$strata <- NULL out$auc <- c(auc_data=out$auc_data, auc_pop=out$auc_pop, auc_pop2=out$auc_pop2, auc_pop_Spi=out$auc_pop_Spi, auc_pop_Spi2=out$auc_pop_Spi2) if(estimator=='all'){ F_P_final <- data.frame(time=out$time,F_P=out$F_P, F_P2=out$F_P2, F_P_Spi=out$F_P_Spi, F_P_Spi2=out$F_P_Spi2) } else if(estimator=='F_P'){ F_P_final <- data.frame(time=tis,prob=out$F_P) } else if(estimator=='F_P2'){ F_P_final <- data.frame(time=tis,prob=out$F_P2) } else if(estimator=='F_P_Spi'){ F_P_final <- data.frame(time=tis,prob=out$F_P_Spi) } else if(estimator=='F_P_Spi2'){ F_P_final <- data.frame(time=tis,prob=out$F_P_Spi2) } # YD through time: F_data_yd <- data.frame(time=mod$time, F_data=out$F_data) pop.times <- F_P_final$time[!(F_P_final$time %in% mod$time)] if(length(pop.times) > 0){ F_data_yd_tmp <- data.frame(time=pop.times, F_data=NA) F_data_yd <- rbind(F_data_yd, F_data_yd_tmp) F_data_yd <- F_data_yd[order(F_data_yd$time),] F_data_yd$F_data <- mstateNAfix(F_data_yd$F_data, 0) } F_data_yd$var <- area_var yd_data <- cumsum(c(F_data_yd$time[1], diff(F_data_yd$time))*c(0, F_data_yd$F_data[1:(nrow(F_data_yd)-1)]))/365.241 # Population part: F_P_yd <- F_P_final yd_pop <- cumsum(c(F_P_yd$time[1], diff(F_P_yd$time))*c(0, F_P_yd$prob[1:(nrow(F_P_yd)-1)]))/365.241 yd_curve <- data.frame(time=F_data_yd$time, yd=yd_data - yd_pop, obs_var=F_data_yd$var, # obs_var22=obs_var_time22, yd_data=yd_data, yd_pop=yd_pop ) ### # Greenwood for prob: greenwood_est <- (mod$surv^2*cumsum(mod$n.event/((mod$n.risk - mod$n.event)*mod$n.risk)))^(1/2) # If Surv(t)=0 in the end, take the last var estimate: if(any(rev(mod$surv)==0)){ greenwood_wh <- which(mod$surv==0) greenwood_est[greenwood_wh] <- greenwood_est[greenwood_wh[1]-1] } F_data_tmp <- data.frame(time=mod$time, prob=out$F_data, prob.se=greenwood_est, area=NA, area.se=NA) # Add values at time zero: F_tmp <- F_data_tmp[1,] F_tmp$time <- min(starting_age) F_tmp$prob <- 0 F_tmp$prob.se <- 0 if(!(F_tmp$time %in% F_data_tmp$time)) F_data_tmp <- rbind(F_tmp, F_data_tmp) if(!if_start_stop){ F_P_final_tmp <- F_P_final[1,] F_P_final_tmp$time <- min(starting_age) F_P_final_tmp$prob <- 0 if(!(F_P_final_tmp$time %in% F_P_final$time)) F_P_final <- rbind(F_P_final_tmp, F_P_final) } yd_curve_tmp <- yd_curve[1,] yd_curve_tmp$time <- min(starting_age) yd_curve_tmp[,2:ncol(yd_curve_tmp)] <- 0 if(!(yd_curve_tmp$time %in% yd_curve$time)) yd_curve <- rbind(yd_curve_tmp, yd_curve) # Bootstrap: if(bootstrap){ yd_curve$boot_var <- colVars(yl_boot, na.rm=TRUE) if(late.values){ last_val <- utils::tail(yd_curve$boot_var[!is.na(yd_curve$boot_var)],1) yd_curve$boot_var[is.na(yd_curve$boot_var)] <- last_val } yl_sd_boot <- stats::sd(yl_boot[, ncol(yl_boot)], na.rm=TRUE) } # Add areas: F_data_tmp$area <- yd_curve$yd_data[yd_curve$time %in% F_data_tmp$time] F_P_final$area <- yd_curve$yd_pop#[yd_curve$time %in% F_P_final$time] F_data_tmp$area.se <- yd_curve$obs_var[yd_curve$time %in% F_data_tmp$time]^(1/2) # If, add boot variance: if(bootstrap & (!is.boot)){ F_data_tmp$prob.se <- (F_boot$F_data[F_boot$time %in% F_data_tmp$time])^(1/2) F_P_final$prob.se <- (F_boot$F_P#[F_boot$time %in% F_P_final$time] )^(1/2) F_data_tmp$area.se <- L_OP$L_O[L_OP$time %in% F_data_tmp$time]^(1/2) F_P_final$area.se <- L_OP$L_P^(1/2) } # Column order: F_data_tmp <- F_data_tmp[, c('time', 'prob', 'area', 'prob.se', 'area.se')] # Choose relevant columns: if(bootstrap){ yd_curve <- yd_curve[,c('time', 'yd', 'boot_var')] } else{ yd_curve <- yd_curve[,c('time', 'yd', 'obs_var')] } yd_curve[,3] <- yd_curve[,3]^(1/2) colnames(yd_curve)[2:3] <- c('est', 'est.se') yd_curve$lower <- yd_curve$est - yd_curve$est.se*stats::qnorm(0.5+conf.int/2) yd_curve$upper <- yd_curve$est + yd_curve$est.se*stats::qnorm(0.5+conf.int/2) return_obj <- list(F_data=F_data_tmp, F_P=F_P_final, auc=out$auc, yd_curve=yd_curve, starting.time=starting.time, estimator=estimator.orig, out=out ) if(bootstrap){ return_obj[[length(return_obj)+1]] <- F_boot names(return_obj)[length(return_obj)] <- 'F_boot' return_obj[[length(return_obj)+1]] <- L_OP names(return_obj)[length(return_obj)] <- 'L_OP' return_obj <- append(return_obj, yl_sd_boot) names(return_obj)[length(return_obj)] <- 'yl_sd_boot' } return_short <- list(years=return_obj$yd_curve, F_O=return_obj$F_data, F_P=return_obj$F_P, measure=measure) if((bootstrap & (!is.boot)) #| ((!bootstrap) & (!is.boot)) ){ return_obj <- return_short } if((!bootstrap) & (!is.boot)){ return_obj <- return_short } if(is.boot){ return_obj <- return_short } if(var.estimator=='none'){ return_obj$years <- return_obj$years[,1:2] find_cols <- (!grepl('.se', colnames(return_obj[[2]]))) return_obj[[2]] <- return_obj[[2]][,find_cols] if(length(return_obj)==4){ find_cols <- (!grepl('.se', colnames(return_obj[[3]]))) return_obj[[3]] <- return_obj[[3]][,find_cols] } } return(return_obj) } } utils::globalVariables(c("time", "prob", "Curve", "est", "lower", "upper")) # Bootstrap function: ylboot <- function(theta, data, B = 5, id = "id", verbose = 0, #all_times, ratetable=relsurv::slopop, #add.times, starting.time, estimator, precision, add.times, formula, rmap, measure, ...){ ids <- unique(data[, id]) n <- length(ids) if(!missing(add.times)){ th <- ylboot.iter(formula, data, starting.time = starting.time, estimator = estimator, precision = precision, ratetable=ratetable, first=TRUE, add.times = add.times, rmap = rmap, measure=measure, ...) } else{ th <- ylboot.iter(formula, data, starting.time = starting.time, estimator = estimator, precision = precision, ratetable=ratetable, first=TRUE, rmap = rmap, measure=measure, ...) } simple_par <- TRUE if(missing(add.times)) simple_par <- FALSE # Prepare objects: res <- data.frame(matrix(NA, nrow=B, ncol=nrow(th[[1]]))) if(!missing(add.times)){ add.times <- sort(unique(c(th[[1]]$time, add.times))) } else{ add.times <- th[[1]]$time } Fdata <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) Fo <- data.frame(matrix(NA, nrow=B, ncol=nrow(th[[2]]))) Fp <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) L_O <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) L_P <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) F_E <- data.frame(matrix(NA, nrow=B, ncol=length(add.times))) # Iteration: for (b in 1:B) { nek_obj <- ylboot.apply(formula, b, verbose, ids, data, id, add.times, starting.time, estimator, precision, ratetable, th, simple_par, rmap, measure, ...) res[b,1:length(nek_obj[[1]])] <- nek_obj[[1]] if(measure=='yl2013'){ F_E[b,1:length(nek_obj[[2]])] <- nek_obj[[2]] } if(measure=='yl2017'){ Fo[b,1:length(nek_obj[[2]])] <- nek_obj[[2]] Fp[b,1:length(nek_obj[[3]])] <- nek_obj[[3]] } if(measure=='yd'){ subnek <- subset(nek_obj[[2]], time %in% add.times) sub_vec <- 1:nrow(subnek) Fdata[b,sub_vec] <- subnek$F_data Fp[b,sub_vec] <- subnek$F_P subnek2 <- subset(nek_obj[[3]], time %in% add.times) sub2_vec <- 1:nrow(subnek2) L_O[b,sub2_vec] <- subnek2$yd_data L_P[b,sub2_vec] <- subnek2$yd_pop } } res <- as.data.frame(t(res)) if(measure == 'yl2013'){ return(list(res, F_E)) } if(measure == 'yl2017'){ return(list(res, Fo, Fp, add.times)) } else{ if (verbose) cat("\n") F_obj <- data.frame(time=add.times, F_data=colVars(Fdata, na.rm = TRUE), F_P=colVars(Fp, na.rm = TRUE)) L_OP <- data.frame(time=add.times, L_O=colVars(L_O, na.rm = TRUE), L_P=colVars(L_P, na.rm = TRUE)) return(list(res, F_obj, L_OP)) } } ylboot.apply <- function(formula, b, verbose, ids, data, id, add.times, starting.time, estimator, precision, ratetable, th, simple_par, rmap, measure, ...){ if(starting.time=='left.truncated'){ start_col <- as.character(formula[[2]])[2] stop_col <- as.character(formula[[2]])[3] } else{ stop_col <- as.character(formula[[2]])[2] } if (verbose > 0) { cat("\nBootstrap replication", b, "\n") } bootdata <- NULL bids <- sample(ids, replace = TRUE) bidxs <- unlist(sapply(bids, function(x) which(x == data[, id]))) bootdata <- data[bidxs, ] if (verbose > 0) { cat("applying theta ...") } if(length(unique(bootdata[,id]))==1){ next } if(!missing(add.times) & simple_par){ add.times.arg <- sort(unique(c(th[[1]]$time, add.times))) } else{ add.times.arg <- th[[1]]$time } add.times.arg2 <- add.times.arg # Remove unnecessary times if(starting.time == 'left.truncated'){ add.times.arg <- add.times.arg[add.times.arg<=max(bootdata[,stop_col])] } else{ add.times.arg <- add.times.arg[add.times.arg<=max(bootdata[,stop_col])]# - bootdata[,start_col])] } thstar <- ylboot.iter(formula, bootdata, starting.time = starting.time, estimator = estimator, precision = precision, ratetable=ratetable, add.times=add.times.arg, rmap=rmap, measure=measure, ...) if(measure == 'yl2013'){ return(list(thstar[[1]]$est, thstar[[2]]$prob)) } if(measure == 'yl2017'){ FoO <- thstar[[2]] FpP <- thstar[[3]] thstar <- thstar[[1]] # if(nrow(th[[1]]) != nrow(thstar)) browser() if(nrow(FoO) < nrow(th[[2]])){ mis.tajms <- th[[2]]$time[!(th[[2]]$time %in% FoO$time)] mis.tajms <- mis.tajms[mis.tajms <= max(FoO$time)] temp_df <- data.frame(time=mis.tajms, area=NA) FoO <- rbind(FoO, temp_df) FoO <- FoO[order(FoO$time),] FoO$area <- mstateNAfix(FoO$area, 0) } if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] FpP <- FpP[FpP$time %in% th[[1]]$time, ] foO <- foO[foO$time %in% th[[1]]$time, ] } if(length(th[[1]]$time[th[[1]]$time <= max(thstar$time)]) != length(thstar$time)) browser() pogoj <- any(th[[1]]$time[th[[1]]$time <= max(thstar$time)] != thstar$time) if(pogoj){ missing_times <- th[[1]]$time[which(!(th[[1]]$time %in% thstar$time))] if(length(missing_times)>0){ # There are times missing in thstar, add them: add_df <- thstar[1:length(missing_times),] add_df$time <- missing_times add_df$yd <- NA add_df$obs_var <- NA add_df$yd_data <- NA thstar <- rbind(thstar, add_df) thstar <- thstar[order(thstar$time),] # redundantno thstar$yd <- mstateNAfix(thstar$yd, 0) thstar$obs_var <- mstateNAfix(thstar$obs_var, 0) thstar$yd_data <- mstateNAfix(thstar$yd_data, 0) if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] } if(nrow(th[[1]]) != nrow(thstar)) browser() } else{ # This means there's more times in thstar than needed. Remove unnecessary times: thstar <- thstar[-which(!(thstar$time %in% th[[1]]$time)),] FpP <- FpP[-which(!(FpP$time %in% th[[1]]$time)),] foO <- foO[-which(!(foO$time %in% th[[1]]$time)),] if(nrow(th[[1]]) != nrow(thstar)) browser() } } return(list(thstar$est, FoO$area, FpP$area)) } L_OP <- thstar[[3]] Fobj <- thstar[[2]] thstar <- thstar[[1]] if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] L_OP <- L_OP[L_OP$time %in% th[[1]]$time, ] Fobj <- Fobj[Fobj$time %in% th[[1]]$time, ] } # Ali kaksne vrednosti manjkajo: if(length(th[[1]]$time[th[[1]]$time <= max(thstar$time)]) != length(thstar$time)) browser() pogoj <- any(th[[1]]$time[th[[1]]$time <= max(thstar$time)] != thstar$time) if(pogoj){ missing_times <- th[[1]]$time[which(!(th[[1]]$time %in% thstar$time))] if(length(missing_times)>0){ # There are times missing in thstar, add them: add_df <- thstar[1:length(missing_times),] add_df$time <- missing_times add_df$yd <- NA add_df$obs_var <- NA add_df$yd_data <- NA thstar <- rbind(thstar, add_df) thstar <- thstar[order(thstar$time),] # redundantno thstar$yd <- mstateNAfix(thstar$yd, 0) thstar$obs_var <- mstateNAfix(thstar$obs_var, 0) thstar$yd_data <- mstateNAfix(thstar$yd_data, 0) if(nrow(th[[1]]) < nrow(thstar)){ thstar <- thstar[thstar$time %in% th[[1]]$time, ] } if(nrow(th[[1]]) != nrow(thstar)) browser() } else{ # This means there's more times in thstar than needed. Remove unnecessary times: thstar <- thstar[-which(!(thstar$time %in% th[[1]]$time)),] L_OP <- L_OP[-which(!(L_OP$time %in% th[[1]]$time)),] Fobj <- Fobj[-which(!(Fobj$time %in% th[[1]]$time)),] if(nrow(th[[1]]) != nrow(thstar)) browser() } } # thstar$b <- b # Save result: # res[b,] <- list(thstar$est, Fobj, L_OP) } ylboot.iter <- function(formula, data, #all_times, starting.time, estimator, precision, ratetable=relsurv::slopop, first=FALSE, add.times, rmap, measure ){ if(!missing(rmap)) rmap <- as.call(rmap) if(first){ is.boot <- FALSE first.boot <- TRUE } else{ is.boot <- TRUE first.boot <- FALSE } # Round, if needed: tolerance <- 1e-15 if(missing(add.times)){ object <- years(formula = formula, data = data, ratetable = ratetable, precision=precision, var.estimator='greenwood', is.boot=is.boot, first.boot = first.boot, rmap = rmap, measure=measure) # estimator = estimator, } else{ object <- years(formula = formula, data = data, ratetable = ratetable, precision=precision, var.estimator='greenwood', add.times=add.times, is.boot=is.boot, first.boot = first.boot, rmap = rmap, measure=measure) # estimator = estimator, } if(measure=='yd'){ if(first) return(list(object$years, object$F_O)) else{ # return(object$yd_curve) Fobj <- merge(object$F_P[,c('time','prob')], object$F_O[,c('time','prob')], by='time', all.x=TRUE) Fobj <- Fobj[,c(1,3,2)] colnames(Fobj)[2:3] <- c('F_data','F_P') L_OP <- merge(object$F_P[,c('time','area')], object$F_O[,c('time','area')], by='time', all.x = TRUE) L_OP <- L_OP[,c(1,3,2)] colnames(L_OP)[2:3] <- c('yd_data', 'yd_pop') return(list(object$years, Fobj, L_OP)) } } else if(measure=='yl2013'){ return(list(object$years, object$F_E)) } else{ return(list(object$years, object$F_O, object$F_P)) } } plot_helper_years <- function(years, obj){ df_poly <- data.frame(time=years[[obj]]$time/365.241, prob=years[[obj]]$prob) df_st <- df_poly[1,] df_st$prob <- 0 df_end <- df_poly[nrow(df_poly),] df_end$prob <- 0 df_poly <- rbind(df_st, df_poly, df_end) df_poly } gg_color_hue <- function(n) { hues = seq(15, 375, length = n + 1) grDevices::hcl(h = hues, l = 65, c = 100)[1:n] } #' Plot the absolute risk (observed and population curve) #' #' Plots the estimated observed and population curve for the #' life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). #' #' A ggplot2 implementation for plotting the observed and population curves. The type of curves is #' dependent upon the measure calculated using \code{years} function (argument \code{measure}). #' @param years the object obtained using function \code{years}. #' @param xlab a title for the x axis. #' @param ylab a title for the y axis. #' @param xbreak the breaks on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ybreak the breaks on the y axis (this is supplied to \code{scale_y_continuous}). #' @param xlimits define the limits on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ylimits define the limits on the y axis (this is supplied to \code{scale_y_continuous}). #' @param show.legend if TRUE, the legend is shown on the graph. #' @return A ggplot object #' @seealso \code{\link{years}}, \code{\link{plot_years}} #' plot_f <- function(years, xlab='Time interval', ylab='Absolute risk', xbreak, ybreak, xlimits, ylimits, show.legend=TRUE){ # years: object given from the years() function # xlab: define xlab # ylab: define ylab # xbreak: The breaks on x axis # ybreak: The breaks on y axis # xlimits: Define the limits on the x axis # ylimits: Define the limits on the y axis # show.legend: TRUE by default (shows the legend) # Checks: if(years$measure != 'yd'){ stop("The plot_f function is available only for the YD measure (argument measure='yd' in the years function).") } out <- rbind( cbind(years$F_O[,c('time', 'prob')], Curve='Observed'), cbind(years$F_P[,c('time', 'prob')], Curve='Population') ) if(missing(xlimits)){ xlimits <- c(min(out$time), max(out$time))/365.241 } if(missing(ylimits)){ ylimits <- c(0,max(out$prob))*1.1 } colorji <- gg_color_hue(3) colorji <- colorji[c(1,3)] g <- ggplot2::ggplot(out)+ ggplot2::geom_step(ggplot2::aes(time/365.241, prob, color=Curve)#, size=1.001 )+ ggplot2::scale_color_manual(values=colorji)+ ggplot2::xlab(xlab)+ ggplot2::ylab(ylab) poly_data <- plot_helper_years(years, 'F_O') poly_P <- plot_helper_years(years, 'F_P') g <- g+ pammtools::geom_stepribbon(ggplot2::aes(x=time/365.241, ymin=0, ymax=prob, fill=Curve), alpha=0.3, linetype='dashed')+ ggplot2::scale_fill_manual(values = colorji) if(!missing(xbreak)){ g <- g + ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits, breaks = xbreak) } else{ g <- g + ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits) } if(!missing(ybreak)){ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits=ylimits, breaks = ybreak) } else{ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits=ylimits) } g <- g + ggplot2::theme_bw()+ ggplot2::theme(legend.position = 'bottom', legend.title = ggplot2::element_blank())+ ggplot2::theme(text = ggplot2::element_text(size=14))+ ggplot2::theme( panel.grid.major.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.major.y = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.y = ggplot2::element_line(linetype='dashed', colour = 'grey85')) if(!show.legend){ g <- g + ggplot2::theme(legend.position = 'none') } g } #' Plot the years measure #' #' Plot the years measure obtained from the \code{years} function. #' #' A ggplot2 implementation for plotting the years measure. The type of curve is #' dependent upon the measure calculated using the \code{years} function (argument \code{measure}). #' @param years the object obtained using function \code{years}. #' @param xlab a title for the x axis. #' @param ylab a title for the y axis. #' @param xbreak the breaks on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ybreak the breaks on the y axis (this is supplied to \code{scale_y_continuous}). #' @param xlimits define the limits on the x axis (this is supplied to \code{scale_x_continuous}). #' @param ylimits define the limits on the y axis (this is supplied to \code{scale_y_continuous}). #' @param conf.int if TRUE, the confidence interval is plotted. #' @param ymirror mirror the y values (w.r.t. the x axis). #' @param yminus use function y -> -y when plotting. #' @return A ggplot object #' @seealso \code{\link{years}}, \code{\link{plot_f}} #' plot_years <- function(years, xlab='Time interval', ylab='Years', xbreak, ybreak, xlimits, ylimits, conf.int=FALSE, ymirror=FALSE, yminus=FALSE){ out <- years$years if(conf.int){ if(is.null(out$lower)){ stop('Confidence intervals not present in the years object. Please set conf.int=FALSE or use the var.estimator argument in the years function.') } } if(years$measure=='yl2017' & nrow(out)==1){ stop('The years measure is reported at the end of follow-up thus it is not plotted.') } if(yminus){ out$est <- -out$est if(!is.null(out$lower)){ tmp_lower <- out$lower out$lower <- -out$upper out$upper <- -tmp_lower } } if(missing(xlimits)){ xlimits <- c(min(out$time[1]), max(out$time))/365.241 } if(missing(ylimits)){ tmp_vec <- out$est if(!is.null(out$lower)) tmp_vec <- c(out$est, out$lower, out$upper) ymax <- max(tmp_vec) ymin <- min(tmp_vec) ylimits <- c(ymin,ymax)*1.1 } g <- ggplot2::ggplot(out)+ ggplot2::geom_step(ggplot2::aes(time/365.241, est)#, size=1.001 ) if(conf.int){ g <- g+ ggplot2::geom_step(ggplot2::aes(time/365.241, lower), linetype='dashed')+ ggplot2::geom_step(ggplot2::aes(time/365.241, upper), linetype='dashed') } g <- g+ ggplot2::xlab(xlab)+ ggplot2::ylab(ylab) if(!missing(xbreak)){ g <- g+ ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits, breaks = xbreak) } else{ g <- g+ ggplot2::scale_x_continuous(expand = c(0, 0), limits=xlimits) } # Helper: trans <- function(x) -x inv <- function(x) -x reverse_fun <- scales::trans_new(name = "reverse_new", transform = trans, inverse = inv ) if(!missing(ybreak)){ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits = ylimits, breaks = ybreak) } else{ g <- g + ggplot2::scale_y_continuous(expand = c(0, 0), limits = ylimits) } if(ymirror){ g <- g + ggplot2::coord_trans(y=reverse_fun) } g <- g + ggplot2::theme_bw()+ ggplot2::theme(text = ggplot2::element_text(size=14))+ ggplot2::expand_limits(y = 0)+ ggplot2::theme( panel.grid.major.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.x = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.major.y = ggplot2::element_line(linetype='dashed', colour = 'grey85'), panel.grid.minor.y = ggplot2::element_line(linetype='dashed', colour = 'grey85')) g } relsurv/R/Rcode.r0000644000176200001440000051130414744715604013414 0ustar liggesusersrsfitterem<-function(data,b,maxiter,ratetable,tol,bwin,p,cause,Nie){ # cause: = 2 (unknown), 0 in 1 known. Lahko preko argumenta cause v rsadd dolocis, ce kdo ima znan cause of death (ne rabijo vsi) . # Nie: to je lambda_0 (ti), ki se oceni v M koraku v EM algoritmu pr.time<-proc.time()[3] if (maxiter<1) stop("There must be at least one iteration run") n<-nrow(data) m <- p dtimes <- which(data$stat==1) #the positions of event times in data$Y td <- data$Y[dtimes] #event times ntd <- length(td) #number of event times utimes <- which(c(1,diff(td))!=0) #the positions of unique event times among td utd <- td[utimes] #unique event times nutd <- length(utd) #number of unique event times udtimes <- dtimes[utimes] #the positions of unique event times among data$Y razteg <- function(x){ # x is a 0/1 vector, the output is a vector of length sum(x), with the corresponding rep numbers n <- length(x) repu <- rep(1,n) repu[x==1] <- 0 repu <- rev(cumsum(rev(repu))) repu <- repu[x==1] repu <- -diff(c(repu,0))+1 if(sum(repu)!=n)repu <- c(n-sum(repu),repu) #ce je prvi cas censoring, bo treba se kej narest?? repu } rutd <- rep(0,ntd) rutd[utimes] <- 1 rutd <- razteg(rutd) #from unique event times to event times rtd <- razteg(data$stat) #from event times to data$Y a <- data$a[data$stat==1] if(bwin[1]!=0){ #the vector of change points for the smoothing bandwidth nt4 <- c(1,ceiling(c(nutd*.25,nutd/2,nutd*.75,nutd))) if(missing(bwin))bwin <- rep(1,4) else bwin <- rep(bwin,4) for(it in 1:4){ bwin[it] <- bwin[it]*max(diff(utd[nt4[it]:nt4[it+1]])) } while(utd[nt4[2]]0){ whtemp <- data$stat==1&cause==2 dataded <- data[data$stat==1&cause==2,] #events with unknown cause datacens <- data[data$stat==0|cause<2,] #censorings or known cause datacens$cause <- cause[data$stat==0|cause<2]*data$stat[data$stat==0|cause<2] databig <- lapply(dataded, rep, 2) databig <- do.call("data.frame", databig) databig$cause <- rep(2,nrow(databig)) nded <- nrow(databig) databig$cens <- c(rep(1,nded/2),rep(0,nded/2)) datacens$cens <- rep(0,nrow(datacens)) datacens$cens[datacens$cause<2] <- datacens$cause[datacens$cause<2] names(datacens) <- names(databig) databig <- rbind(databig,datacens) cause <- cause[data$stat==1] #NEW IN 2.05 (next 4 lines) fk <- (attributes(ratetable)$factor != 1) nfk <- length(fk) varstart <- 3+nfk+1 #first column of covariates varstop <- 3+nfk+m #last column of covariates #model matrix for relative survival xmat <- as.matrix(data[,varstart:varstop]) #NEW IN 2.05 #ebx at initial values of b ebx <- as.vector(exp(xmat%*%b)) # exp(linear.predictor) #model matrix for coxph modmat <- as.matrix(databig[,varstart:varstop]) #NEW IN 2.05 varnames <- names(data)[varstart:varstop] #NEW IN 2.05 } else{ cause <- cause[data$stat==1] ebx <- rep(1,n) # exp(linear.predictor) } #for time-dependent data: starter <- sort(data$start) starter1<-c(starter[1],starter[-length(starter)]) #the values of interest in the cumsums of the obsolete values (there is at least one value - the 1st) index <- c(TRUE,(starter!=starter1)[-1]) starter <- starter[index] #the number of repetitions in each cumsum difference - needed for s0 calculation val1 <- apply(matrix(starter,ncol=1),1,function(x,Y)sum(x>=Y),data$Y) val1 <- c(val1[1],diff(val1),length(data$Y)-val1[length(val1)]) eb <- ebx[data$stat==1] # s0 je sum_{at risk set} ebx s0 <- cumsum((ebx)[n:1])[n:1] ebx.st <- ebx[order(data$start)] s0.st <- ((cumsum(ebx.st[n:1]))[n:1])[index] s0.st <- rep(c(s0.st,0),val1) s0 <- s0 - s0.st #s0 only at times utd s0 <- s0[udtimes] #find the corresponding value of Y for each start!=0 - needed for likelihood calculation start <- data$start # if(any(start!=0)){ # wstart <- rep(NA,n) # ustart <- unique(start[start!=0]) # for(its in ustart){ # wstart[start==its] <- min(which(data$Y==its)) # } # } #tale del je zelo sumljiv - kako se racuna likelihood za ties??? difft <- c(data$Y[data$stat==1][1],diff(td)) difft <- difftu <- difft[difft!=0] difft <- rep(difft,rutd) a0 <- a*difft if(sum(Nie==.5)!=0)maxit0 <- maxiter else maxit0<- maxiter - 3 for(i in 1:maxit0){ #Nie is of length ntd, should be nutd, with the values at times being the sum nietemp <- rep(1:nutd,rutd) Nies <- as.vector(by(Nie,nietemp,sum)) #shorter Nie - only at times utd lam0u <- lam0 <- Nies/s0 #the smooting of lam0 if(bwin[1]!=0){ lam0s <- krn%*%lam0 } else{ lam0s <- lam0/difftu } #extended to all event times lam0s <- rep(lam0s,rutd) #compute Nie, only for those with unknown hazard Nie[cause==2] <- as.vector(lam0s*eb/(a+lam0s*eb))[cause==2] } if(maxit0!=maxiter & i==maxit0) i <- maxiter #likelihood calculation - manjka ti se likelihood za nicelni model!!! #the cumulative hazard Lam0 <- cumsum(lam0) #extended to all event times Lam0 <- rep(Lam0,rutd) if(data$stat[1]==0) Lam0 <- c(0,Lam0) #extended to all exit times Lam0 <- rep(Lam0,rtd) # save original object: Lam00 <- Lam0 #for time dependent covariates and left-truncated individuals: replace by the difference if(any(start!=0)){ # Calculate hazards at non-event times: timehaz <- data.frame(time=sort(data$Y), Lam0_2=Lam0) timehaz_tmp <- data.frame(time=unique(data$start), Lam0_2=NA) timehaz <- rbind(timehaz, timehaz_tmp) timehaz <- timehaz[order(timehaz$time),] timehaz$Lam0_2 <- mstateNAfix(timehaz$Lam0_2, 0) timehaz <- timehaz[!duplicated(timehaz$time),] # Prepare object so that you can calculate Lam0_event_time - Lam0_entry_time data_lt <- cbind(data, Lam0, id_0=1:nrow(data)) data_lt <- merge(data_lt, timehaz, by.x='start', by.y='time', all.x = TRUE) data_lt <- data_lt[order(data_lt$id_0),] # Check: # if(any(data_lt$Lam0_2[start!=0] != Lam0[wstart[start!=0]])){ # browser() # } # Edit Lam0: Lam0[start!=0] <- data_lt$Lam0[start!=0] - data_lt$Lam0_2[start!=0] # Old calculation: # Lam0[start!=0] <- Lam0[start!=0] - Lam0[wstart[start!=0]] } lam0 <- rep(lam0,rutd) likely0 <- sum(log(a0 + lam0*eb)) - sum(data$ds + Lam0*ebx) likely <- likely0 tempind <- Nie<=0|Nie>=1 if(any(tempind)){ if(any(Nie<=0))Nie[Nie<=0] <- tol if(any(Nie>=1))Nie[Nie>=1] <- 1-tol } if(p>0)databig$wei <- c(Nie[cause==2],1-Nie[cause==2],rep(1,nrow(datacens))) if(maxiter>=1&p!=0){ for(i in 1:maxiter){ if(p>0){ b00<-b if(i==1)fit <- coxph(Surv(start,Y,cens)~modmat,data=databig,weights=databig$wei,init=b00,x=TRUE,iter.max=maxiter) else fit <- coxph(Surv(start,Y,cens)~modmat,data=databig,weights=databig$wei,x=TRUE,iter.max=maxiter) if(any(is.na(fit$coeff))) stop("X matrix deemed to be singular, variable ",which(is.na(fit$coeff))) b <- fit$coeff ebx <- as.vector(exp(xmat%*%b)) } else ebx <- rep(1,n) eb <- ebx[data$stat==1] # s0 je sum_{at risk set} ebx s0 <- cumsum((ebx)[n:1])[n:1] ebx.st <- ebx[order(data$start)] s0.st <- ((cumsum(ebx.st[n:1]))[n:1])[index] s0.st <- rep(c(s0.st,0),val1) s0 <- s0 - s0.st #Nie is of length ntd, should be nutd, with the values at times being the sum nietemp <- rep(1:nutd,rutd) Nies <- as.vector(by(Nie,nietemp,sum)) #shorter Nie - only at times utd #s0 only at times utd s0 <- s0[udtimes] lam0u <- lam0 <- Nies/s0 #the cumulative hazard Lam0 <- cumsum(lam0) #extended to all event times Lam0 <- rep(Lam0,rutd) if(data$stat[1]==0) Lam0 <- c(0,Lam0) #extended to all exit times Lam0 <- rep(Lam0,rtd) # save original object: Lam00 <- Lam0 # for time dependent covariates and left-truncated individuals: replace by the difference if(any(start!=0)){ timehaz <- data.frame(time=sort(data$Y), Lam0_2=Lam0) timehaz_tmp <- data.frame(time=unique(data$start), Lam0_2=NA) timehaz <- rbind(timehaz, timehaz_tmp) timehaz <- timehaz[order(timehaz$time),] timehaz$Lam0_2 <- mstateNAfix(timehaz$Lam0_2, 0) timehaz <- timehaz[!duplicated(timehaz$time),] # Prepare object so that you can calculate Lam0_event_time - Lam0_entry_time data_lt <- cbind(data, Lam0, id_0=1:nrow(data)) data_lt <- merge(data_lt, timehaz, by.x='start', by.y='time', all.x = TRUE) data_lt <- data_lt[order(data_lt$id_0),] # Edit Lam0: Lam0[start!=0] <- data_lt$Lam0[start!=0] - data_lt$Lam0_2[start!=0] # Lam0[start!=0] <- Lam0[start!=0] - Lam0[wstart[start!=0]] } #the smooting of lam0 if(bwin[1]!=0){ lam0s <- krn%*%lam0 } else{ lam0s <- lam0/difftu } #extended to all event times lam0s <- rep(lam0s,rutd) #compute Nie, only for those with unknown hazard Nie[cause==2] <- as.vector(lam0s*eb/(a+lam0s*eb))[cause==2] #likelihood calculation - manjka ti se likelihood za nicelni model!!! lam0 <- rep(lam0,rutd) likely <- sum(log(a0 + lam0*eb)) - sum(data$ds + Lam0*ebx) if(p>0){ tempind <- Nie<=0|Nie>=1 if(any(tempind)){ if(any(Nie<=0))Nie[Nie<=0] <- tol if(any(Nie>=1))Nie[Nie>=1] <- 1-tol #if(which(tempind)!=nev)warning("Weights smaller than 0") #if(any(is.na( match(which(tempind),c(1,nev)) )))browser() } if(nded==0) break() databig$wei[1:nded] <- c(Nie[cause==2],1-Nie[cause==2]) bd <- abs(b-b00) if(max(bd)< tol) break() } #early stopping time for no covariates??? } } iter <- i #if (maxiter > 1& iter>=maxiter) # warning("Ran out of iterations and did not converge") if(p>0){ if(nded!=0){ resi <- resid(fit,type="schoenfeld") if(!is.null(dim(resi)))resi <- resi[1:(nded/2),] else resi <- resi[1:(nded/2)] swei <- fit$weights[1:(nded/2)] if(is.null(dim(resi))) fishem <- sum((resi^2*swei*(1-swei))) else { fishem <- apply(resi,1,function(x)outer(x,x)) fishem <- t(t(fishem)*swei*(1-swei)) fishem <- matrix(apply(fishem,1,sum),ncol=m) } } else fishem <- 0 fishcox <- solve(fit$var) fisher <- fishcox - fishem fit$var <- solve(fisher) names(fit$coefficients)<-varnames fit$lambda0 <- lam0s } else fit <- list(lambda0 = lam0s) # lam0.ns -> lam0u: editan (smoothing) # lambda0 -> lam0s: editan (smoothing) # Lambda0 -> Lam0: cumsum(lam0) - lam0 je enako lam0u fit$lambda0 <- fit$lambda0[utimes] fit$Lambda0 <- Lam00[udtimes] fit$times <- utd fit$Nie <- Nie fit$bwin <- bwin fit$iter <- i class(fit) <- c("rsadd",class(fit)) fit$loglik <- c(likely0,likely) fit$lam0.ns <- lam0u fit } em <- function (rform, init, control, bwin) { data <- rform$data n <- nrow(data) p <- rform$m ord_id <- order(data$Y) rform$cause <- rform$cause[ord_id] data <- data[ord_id, ] fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) nev <- length(data$Y[data$stat == 1]) data$a <- rep(NA, n) xx <- exp_prep(data[, 4:(nfk + 3),drop=FALSE], data$Y - data$start, rform$ratetable) # The cumulative population hazard of dying at time Y: data$ds <- -log(xx) data1 <- data data1[, 4:(nfk + 3)] <- data[, 4:(nfk + 3)] + data$Y %*% t(fk) xx <- exp_prep(data1[data1$stat == 1, 4:(nfk + 3),drop=FALSE], 1, rform$ratetable) # The population hazard of dying in the following day (for individuals that had an event): data$a[data$stat == 1] <- -log(xx) if (p > 0) { if (!missing(init) && !is.null(init)) { if (length(init) != p) stop("Wrong length for inital values") } else init <- rep(0, p) beta <- matrix(init, p, 1) } pr.time<-proc.time()[3] Nie <- rep(.5,sum(data$stat==1)) Nie[rform$cause[data$stat==1]<2] <- rform$cause[data$stat==1][rform$cause[data$stat==1]<2] #NEW IN 2.05 varstart <- 3+nfk+1 #first column of covariates varstop <- 3+nfk+p #last column of covariates if(missing(bwin))bwin <- -1 if(bwin<0){ if(p>0)data1 <- data[,-c(varstart:varstop)] #NEW IN 2.05 else data1 <- data nfk <- length(attributes(rform$ratetable)$dimid) names(data)[4:(3+nfk)] <- attributes(rform$ratetable)$dimid expe <- rs.surv(Surv(Y,stat)~1,data,ratetable=rform$ratetable,method="ederer2") esurv <- -log(expe$surv[expe$n.event!=0]) if(esurv[length(esurv)]==Inf)esurv[length(esurv)] <- esurv[length(esurv)-1] x <- seq(.1,3,length=5) dif <- rep(NA,5) options(warn=-1) diter <- max(round(max(data$Y)/356.24),3) for(it in 1:5){ fit <- rsfitterem(data1,NULL,diter,rform$ratetable,control$epsilon,x[it],0,rform$cause,Nie) dif[it] <- sum((esurv-fit$Lambda0)^2) } wh <- which.min(dif) if(wh==1)x <- seq(x[wh],x[wh+1]-.1,length=5) else if(wh==5)x <- c(x, max(data$Y)/ max(diff(data$Y))) if(wh!=1) x <- seq(x[wh-1]+.1,x[wh+1]-.1,length=5) dif <- rep(NA,5) for(it in 1:5){ fit <- rsfitterem(data1,NULL,diter,rform$ratetable,control$epsilon,x[it],0,rform$cause,Nie) dif[it] <- sum((esurv-fit$Lambda0)^2) } options(warn=0) Nie <- fit$Nie bwin <- x[which.min(dif)] } # if(any(data$start != 0)) browser() fit <- rsfitterem(data, beta, control$maxit, rform$ratetable, control$epsilon, bwin, p, rform$cause,Nie) Nie <- rep(0,nrow(data)) Nie[data$stat==1] <- fit$Nie fit$Nie <- Nie[order(ord_id)] fit$bwin <- list(bwin=fit$bwin,bwinfac=bwin) fit } #' Fit an Additive model for Relative Survival #' #' The function fits an additive model to the data. The methods implemented are #' the maximum likelihood method, the semiparametric method, a glm model with a #' \code{binomial} error and a glm model with a \code{poisson} error. #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' The maximum likelihood method and both glm methods assume a fully parametric #' model with a piecewise constant baseline excess hazard function. The #' intervals on which the baseline is assumed constant should be passed via #' argument \code{int}. The EM method is semiparametric, i.e. no assumptions #' are made for the baseline hazard and therefore no intervals need to be #' specified. #' #' The methods using glm are methods for grouped data. The groups are formed #' according to the covariate values. This should be taken into account when #' fitting a model. The glm method returns life tables for groups specified by #' the covariates in \code{groups}. #' #' The EM method output includes the smoothed baseline excess hazard #' \code{lambda0}, the cumulative baseline excess hazard \code{Lambda0} and #' \code{times} at which they are estimated. The individual probabilites of #' dying due to the excess risk are returned as \code{Nie}. The EM method #' fitting procedure requires some local smoothing of the baseline excess #' hazard. The default \code{bwin=-1} value lets the function find an #' appropriate value for the smoothing band width. While this ensures an #' unbiased estimate, the procedure time is much longer. As the value found by #' the function is independent of the covariates in the model, the value can be #' read from the output (\code{bwinfac}) and used for refitting different #' models to the same data to save time. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. \code{Surv(start,stop,event)} outcomes #' are also possible for time-dependent covariates and left-truncation for #' \code{method='EM'}. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param int either a single value denoting the number of follow-up years or a #' vector specifying the intervals (in years) in which the hazard is constant #' (the times that are bigger than \code{max(int)} are censored. If missing, #' only one interval (from time 0 to maximum observation time) is assumed. The #' EM method does not need the intervals, only the maximum time can be #' specified (all times are censored after this time point). #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param method \code{glm.bin} or \code{glm.poi} for a glm model, \code{EM} #' for the EM algorithm and \code{max.lik} for the maximum likelihood model #' (default). #' @param init vector of initial values of the iteration. Default initial #' value is zero for all variables. #' @param bwin controls the bandwidth used for smoothing in the EM algorithm. #' The follow-up time is divided into quartiles and \code{bwin} specifies a #' factor by which the maximum between events time length on each interval is #' multiplied. The default \code{bwin=-1} lets the function find an appropriate #' value. If \code{bwin=0}, no smoothing is applied. #' @param centered if \code{TRUE}, all the variables are centered before #' fitting and the baseline excess hazard is calculated accordingly. Default is #' \code{FALSE}. #' @param cause A vector of the same length as the number of cases. \code{0} #' for population deaths, \code{1} for disease specific deaths, \code{2} #' (default) for unknown. Can only be used with the \code{EM} method. #' @param control a list of parameters for controlling the fitting process. #' See the documentation for \code{glm.control} for details. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param ... other arguments will be passed to \code{glm.control}. #' @return An object of class \code{rsadd}. In the case of #' \code{method="glm.bin"} and \code{method="glm.poi"} the class also inherits #' from \code{glm} which inherits from the class \code{lm}. Objects of this #' class have methods for the functions \code{print} and \code{summary}. An #' object of class \code{rsadd} is a list containing at least the following #' components: \item{data}{the data as used in the model, along with the #' variables defined in the rate table} \item{ratetable}{the ratetable used.} #' \item{int}{the maximum time (in years) used. All the events at and after #' this value are censored.} \item{method}{the fitting method that was used.} #' \item{linear.predictors}{the vector of linear predictors, one per subject.} #' @seealso \code{\link{rstrans}}, \code{\link{rsmul}} #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' #' EM algorithm: Pohar Perme M., Henderson R., Stare, J. (2009) "An approach to #' estimation in relative survival regression." Biostatistics, \bold{10}: #' 136--146. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit an additive model #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- rsadd(Surv(time,cens)~sex+as.factor(agegr)+ratetable(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' #' #check the goodness of fit #' rs.br(fit) #' #' #use the EM method and plot the smoothed baseline excess hazard #' fit <- rsadd(Surv(time,cens)~sex+age,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5,method="EM") #' sm <- epa(fit) #' plot(sm$times,sm$lambda,type="l") #' rsadd <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, method = "max.lik", init, bwin, centered = FALSE, cause, control, rmap, ...) # rmap.subs=TRUE, { call <- match.call() if (missing(control)) control <- glm.control(...) if (!missing(rmap)) { rmap_tmp <- substitute(rmap) if(inherits(rmap_tmp, "call")){ rmap <- rmap_tmp } } if(!missing(cause)){ #NEW: ce cause ne manjka, ga preverim in dodam kot spremenljivko if (length(cause) != nrow(data)) stop("Length of cause does not match data dimensions") data$cause <- cause rform <- rformulate(formula, data, ratetable, na.action, rmap, int, centered, cause) } else{ #no cause rform <- rformulate(formula,data, ratetable, na.action, rmap, int, centered) } if (method == "EM") { if (!missing(int)) { if (length(int) > 1 | any(int <= 0)) stop("Invalid value of 'int'") } } else { if (missing(int)) int <- c(0,ceiling(max(rform$Y/365.241))) if (length(int) == 1) { if (int <= 0) stop("The value of 'int' must be positive ") int <- 0:int } else if (int[1] != 0) stop("The first interval in 'int' must start with 0") } method <- match.arg(method,c("glm.bin","glm.poi","max.lik","EM")) if (method == "glm.bin" | method == "glm.poi") fit <- glmxp(rform = rform, interval = int, method = method, control = control) else if (method == "max.lik") fit <- maxlik(rform = rform, interval = int, init = init, control = control) else if (method == "EM") fit <- em(rform, init, control, bwin) fit$call <- call fit$formula <- formula fit$data <- rform$data fit$ratetable <- rform$ratetable fit$n <- nrow(rform$data) if (length(rform$na.action)) fit$na.action <- rform$na.action fit$y <- rform$Y.surv fit$method <- method if (method == "EM") { if (!missing(int)) fit$int <- int else fit$int <- ceiling(max(rform$Y[rform$status == 1])/365.241) fit$terms <- rform$Terms if(centered)fit$mvalue <- rform$mvalue } if (method == "max.lik") { fit$terms <- rform$Terms } if (rform$m > 0) fit$linear.predictors <- as.matrix(rform$X) %*% fit$coef[1:ncol(rform$X)] if (!missing(rmap)) { fit$rmap <- rmap } fit } maxlik <- function (rform, interval, subset, init, control) { data <- rform$data max.time <- max(data$Y)/365.241 if (max.time < max(interval)) interval <- interval[1:(sum(max.time > interval) + 1)] fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) data <- cbind(data, offset = rform$offset) data <- survsplit(data, cut = interval[-1] * 365.241, end = "Y", event = "stat", start = "start", episode = "epi", interval = interval) del <- which(data$start==data$Y) if(length(del)) data <- data[-del,] offset <- data$offset data$offset <- NULL d.int <- diff(interval) data[, 4:(nfk + 3)] <- data[, 4:(nfk + 3)] + data$start %*% t(fk) data$lambda <- rep(0, nrow(data)) nsk <- nrow(data[data$stat == 1, ]) xx <- exp_prep(data[data$stat == 1, 4:(nfk + 3),drop=FALSE] + (data[data$stat == 1, ]$Y - data[data$stat == 1, ]$start) %*% t(fk), 1, rform$ratetable) data$lambda[data$stat == 1] <- -log(xx) * 365.241 xx <- exp_prep(data[, 4:(nfk + 3),drop=FALSE], data$Y - data$start, rform$ratetable) data$epi <- NULL data$ds <- -log(xx) data$Y <- data$Y/365.241 data$start <- data$start/365.241 data <- data[, -(4:(3 + nfk))] intn <- length(interval[-1]) m <- rform$m p <- m + intn if (!missing(init) && !is.null(init)) { if (length(init) != p) stop("Wrong length for inital values") } else init <- rep(0, p) if(m>0){ init0 <- init[-(1:m)] data1 <- data[,-(4:(3+m))] } else{ init0 <- init data1 <- data } fit0 <- lik.fit(data1, 0, intn, init0, control, offset) if(m>0){ init[-(1:m)] <- fit0$coef fit <- lik.fit(data, m, intn, init, control, offset) } else fit <- fit0 fit$int <- interval class(fit) <- "rsadd" fit$times <- fit$int*365.241 #dodano za potrebe rs.surv.rsadd fit$Lambda0 <- cumsum(c(0, exp(fit$coef[(m+1):p])*diff(fit$int) )) fit } lik.fit <- function (data, m, intn, init, control, offset) { n <- dim(data)[1] varpos <- 4:(3 + m + intn) x <- data[, varpos] varnames <- names(data)[varpos] lbs <- names(x) x <- as.matrix(x) p <- length(varpos) d <- data$stat ds <- data$ds h <- data$lambda y <- data$Y - data$start maxiter <- control$maxit if (!missing(init) && !is.null(init)) { if (length(init) != p) stop("Wrong length for inital values") } else init <- rep(0, p) b <- matrix(init, p, 1) b0 <- b fit <- mlfit(b, p, x, offset, d, h, ds, y, maxiter, control$epsilon) if (maxiter > 1 & fit$nit >= maxiter) { values <- apply(data[data$stat==1,varpos,drop=FALSE],2,sum) #NEW: deluje tudi, ce je ratetable eno-dimenzionalen problem <- which.min(values) outmes <- "Ran out of iterations and did not converge" if(values[problem]==0)tzero <- "" else tzero <- "only " if(values[problem]<5){ if(!is.na(strsplit(names(values)[problem],"fu")[[1]][2]))outmes <- paste(outmes, "\n This may be due to the fact that there are ",tzero, values[problem], " events on interval",strsplit(names(values)[problem],"fu")[[1]][2],"\n You can use the 'int' argument to change the follow-up intervals in which the baseline excess hazard is assumed constant",sep="") else outmes <- paste(outmes, "\n This may be due to the fact that there are ",tzero, values[problem], " events for covariate value ",names(values)[problem],sep="") } warning(outmes) } b <- as.vector(fit$b) names(b) <- varnames fit <- list(coefficients = b, var = -solve(fit$sd), iter = fit$nit, loglik = fit$loglik) fit } #' Split a Survival Data Set at Specified Times #' #' Given a survival data set and a set of specified cut times, the function #' splits each record into multiple records at each cut time. The new data set #' is be in \code{counting process} format, with a start time, stop time, and #' event status for each record. More general than \code{survSplit} as it also #' works with the data already in the \code{counting process} format. #' #' #' @param data data frame. #' @param cut vector of timepoints to cut at. #' @param end character string with name of event time variable. #' @param event character string with name of censoring indicator. #' @param start character string with name of start variable (will be created #' if it does not exist). #' @param id character string with name of new id variable to create #' (optional). #' @param zero If \code{start} doesn't already exist, this is the time that the #' original records start. May be a vector or single value. #' @param episode character string with name of new episode variable #' (optional). #' @param interval this argument is used by \code{max.lik} function #' @return New, longer, data frame. #' @seealso \code{\link[survival:survSplit]{survival::survSplit}}. #' @keywords survival survsplit <- function (data, cut, end, event, start, id = NULL, zero = 0, episode = NULL, interval = NULL) { ntimes <- length(cut) n <- nrow(data) p <- ncol(data) if (length(interval) > 0) { ntimes <- ntimes - 1 sttime <- c(rep(0, n), rep(cut[-length(cut)], each = n)) endtime <- rep(cut, each = n) } else { endtime <- rep(c(cut, Inf), each = n) sttime <- c(rep(0, n), rep(cut, each = n)) } newdata <- lapply(data, rep, ntimes + 1) eventtime <- newdata[[end]] if (start %in% names(data)) starttime <- newdata[[start]] else starttime <- rep(zero, length = (ntimes + 1) * n) starttime <- pmax(sttime, starttime) epi <- rep(0:ntimes, each = n) if (length(interval) > 0) status <- ifelse(eventtime <= endtime & eventtime >= starttime, newdata[[event]], 0) else status <- ifelse(eventtime <= endtime & eventtime > starttime, newdata[[event]], 0) endtime <- pmin(endtime, eventtime) if (length(interval) > 0) drop <- (starttime > endtime) | (starttime == endtime & status == 0) else drop <- starttime >= endtime newdata <- do.call("data.frame", newdata) newdata <- newdata[!drop, ] newdata[, start] <- starttime[!drop] newdata[, end] <- endtime[!drop] newdata[, event] <- status[!drop] if (!is.null(id)) newdata[, id] <- rep(rownames(data), ntimes + 1)[!drop] fu <- NULL if (length(interval) > 2) { for (it in 1:length(interval[-1])) { drop1 <- sum(!drop[1:(it * n - n)]) drop2 <- sum(!drop[(it * n - n + 1):(it * n)]) drop3 <- sum(!drop[(it * n + 1):(length(interval[-1]) * n)]) if (it == 1) fu <- cbind(fu, c(rep(1, drop2), rep(0, drop3))) else if (it == length(interval[-1])) fu <- cbind(fu, c(rep(0, drop1), rep(1, drop2))) else fu <- cbind(fu, c(rep(0, drop1), rep(1, drop2), rep(0, drop3))) } fu <- as.data.frame(fu) names(fu) <- c(paste("fu [", interval[-length(interval)], ",", interval[-1], ")", sep = "")) newdata <- cbind(newdata, fu) } else if (length(interval) == 2) { fu <- rep(1, sum(!drop)) newdata <- cbind(newdata, fu) names(newdata)[ncol(newdata)] <- paste("fu [", interval[1], ",", interval[2], "]", sep = "") } if (!is.null(episode)) newdata[, episode] <- epi[!drop] newdata } glmxp <- function (rform, data, interval, method, control) { if (rform$m == 1) g <- as.integer(as.factor(rform$X[[1]])) else if (rform$m > 1) { gvar <- NULL for (i in 1:rform$m) { gvar <- append(gvar, rform$X[i]) } tabgr <- as.data.frame(table(gvar)) tabgr <- tabgr[, 1:rform$m] n.groups <- dim(tabgr)[1] mat <- do.call("data.frame", gvar) names(mat) <- names(tabgr) tabgr <- cbind(tabgr, g = as.numeric(row.names(tabgr))) mat <- cbind(mat, id = 1:rform$n) c <- merge(tabgr, mat) g <- c[order(c$id), rform$m + 1] } else g <- rep(1, rform$n) vg <- function(X) { n <- dim(X)[1] w <- sum((X$event == 0) & (X$fin == 1) & (X$y != 1)) nd <- sum((X$event == 1) & (X$fin == 1)) ps <- exp_prep(X[, 4:(nfk + 3),drop=FALSE], t.int, rform$ratetable) ld <- n - w/2 lny <- log(sum(X$y)) k <- t.int/365.241 dstar <- sum(-log(ps)/k * X$y) ps <- mean(ps) if (rform$m == 0) data.rest <- X[1, 7 + nfk + rform$m, drop = FALSE] else data.rest <- X[1, c((3 + nfk + 1):(3 + nfk + rform$m), 7 + nfk + rform$m)] cbind(nd = nd, ld = ld, ps = ps, lny = lny, dstar = dstar, k = k, data.rest) } nint <- length(interval) if (nint < 2) stop("Illegal interval value") meje <- interval my.fun <- function(x) { if (x > 1) { x.t <- rep(1, floor(x)) if (x - floor(x) > 0) x.t <- c(x.t, x - floor(x)) x.t } else x } int <- apply(matrix(diff(interval), ncol = 1), 1, my.fun) if (is.list(int)) int <- c(0, cumsum(do.call("c", int))) else int <- c(0, cumsum(int)) int <- int * 365.241 nint <- length(int) X <- cbind(rform$data, grupa = g) fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) Z <- X[X$start >= int[2], ] nz <- dim(Z)[1] Z$fin <- rep(0, nz) Z$event <- rep(0, nz) Z$fu <- rep(0, nz) Z$y <- rep(0, nz) Z$origstart <- Z$start Z$xind <- rep(0, nz) if (nrow(Z) > 0) Z[, 4:(nfk + 3)] <- Z[, 4:(nfk + 3)] + matrix(Z$start, ncol = nfk, byrow = FALSE, nrow = nrow(Z)) * matrix(fk, ncol = nfk, byrow = TRUE, nrow = nrow(Z)) X <- X[X$start < int[2], ] X$fin <- (X$Y <= int[2]) X$event <- X$fin * X$stat ford <- eval(substitute(paste("[", a, ",", b, "]", sep = ""), list(a = meje[1], b = meje[2]))) X$fu <- rep(ford, rform$n - nz) t.int <- int[2] - int[1] X$y <- (pmin(X$Y, int[2]) - X$start)/365.241 X$origstart <- X$start X$xind <- rep(1, nrow(X)) gr1 <- by(X, X$grupa, vg) grm1 <- do.call("rbind", gr1) X <- X[X$fin == 0, ] X$start <- rep(int[2], dim(X)[1]) X <- rbind(X, Z[Z$start < int[3], ]) Z <- Z[Z$start >= int[3], ] temp <- 0 if (nint > 2) { for (i in 3:nint) { ni <- dim(X)[1] if (ni == 0) { temp <- 1 break } X$fin <- X$Y <= int[i] X$event <- X$fin * X$stat l <- sum(int[i - 1] >= meje * 365.241) if(l==1) ftemp <- eval(substitute(paste("[", a, ",", b, "]", sep = ""), list(a = meje[l], b = meje[l + 1]))) else ftemp <- eval(substitute(paste("(", a, ",", b, "]", sep = ""), list(a = meje[l], b = meje[l + 1]))) ford <- c(ford, ftemp) X$fu <- rep(ford[i - 1], ni) t.int <- int[i] - int[i - 1] index <- X$origstart < int[i - 1] index1 <- as.logical(X$xind) if (sum(index) > 0) X[index, 4:(nfk + 3)] <- X[index, 4:(nfk + 3)] + matrix(fk * t.int, ncol = nfk, byrow = TRUE, nrow = sum(index)) X$xind <- rep(1, nrow(X)) X$y <- (pmin(X$Y, int[i]) - X$start)/365.241 gr1 <- by(X, X$grupa, vg) grm1 <- rbind(grm1, do.call("rbind", gr1)) X <- X[X$fin == 0, ] X$start <- rep(int[i], dim(X)[1]) if (i == nint) break X <- rbind(X, Z[Z$start < int[i + 1], ]) X <- X[X$start != X$Y, ] Z <- Z[Z$start >= int[i + 1], ] } l <- sum(int[i - temp] > meje * 365.241) interval <- meje[1:(l + 1)] } else interval <- meje[1:2] grm1$fu <- factor(grm1$fu, levels = unique(ford)) if (method == "glm.bin") { ht <- binomial(link = cloglog) ht$link <- "Hakulinen-Tenkanen relative survival model" ht$linkfun <- function(mu) log(-log((1 - mu)/ps)) ht$linkinv <- function(eta) 1 - exp(-exp(eta)) * ps ht$mu.eta <- function(eta) exp(eta) * exp(-exp(eta)) * ps .ps <- ps <- grm1$ps #assign(".ps", grm1$ps, envir = .GlobalEnv) # ht$initialize <- expression({ # n <- y[, 1] + y[, 2] # y <- ifelse(n == 0, 0, y[, 1]/n) # weights <- weights * n # mustart <- (n * y + 0.01)/(n + 0.02) # mustart[(1 - mustart)/data$ps >= 1] <- data$ps[(1 - mustart)/data$ps >= # 1] * 0.9 # }) if (any(grm1$ld - grm1$nd > grm1$ps * grm1$ld)) { n <- sum(grm1$ld - grm1$nd > grm1$ps * grm1$ld) g <- dim(grm1)[1] warnme <- paste("Observed number of deaths is smaller than the expected in ", n, "/", g, " groups of patients", sep = "") } else warnme <- "" if (length(interval) == 2 & rform$m == 0) stop("No groups can be formed") if (length(interval) == 1 | length(table(grm1$fu)) == 1) grm1$fu <- as.integer(grm1$fu) y <- ifelse(grm1$ld == 0, 0, grm1$nd/grm1$ld) #weights <- weights * grm1$ld mustart <- (grm1$ld * y + 0.01)/(grm1$ld + 0.02) mustart[(1 - mustart)/grm1$ps >= 1] <- grm1$ps[(1 - mustart)/grm1$ps >= 1] * 0.9 if (!length(rform$X)) local.ht <- glm(cbind(nd, ld - nd) ~ -1 + fu + offset(log(k)), data = grm1, family = ht,mustart=mustart) else { xmat <- as.matrix(grm1[, 7:(ncol(grm1) - 1)]) local.ht <- glm(cbind(nd, ld - nd) ~ -1 + xmat + fu + offset(log(k)), data = grm1, family = ht,mustart=mustart) } names(local.ht[[1]]) <- c(names(rform$X), paste("fu", levels(grm1$fu))) } else if (method == "glm.poi") { pot <- poisson() pot$link <- "glm relative survival model with Poisson error" pot$linkfun <- function(mu) log(mu - dstar) pot$linkinv <- function(eta) dstar + exp(eta) #assign(".dstar", grm1$dstar, envir = .GlobalEnv) if (any(grm1$nd - grm1$dstar < 0)) { pot$initialize <- expression({ if (any(y < 0)) stop(paste("Negative values not allowed for", "the Poisson family")) n <- rep.int(1, nobs) #mustart <- pmax(y, .dstar) + 0.1 }) } if (any(grm1$nd - grm1$dstar < 0)) { n <- sum(grm1$nd - grm1$dstar < 0) g <- dim(grm1)[1] warnme <- paste("Observed number of deaths is smaller than the expected in ", n, "/", g, " groups of patients", sep = "") } else warnme <- "" dstar <- grm1$dstar if (length(interval) == 2 & rform$m == 0) stop("No groups can be formed") if (length(interval) == 1 | length(table(grm1$fu)) == 1) grm1$fu <- as.integer(grm1$fu) mustart <- pmax(grm1$nd, grm1$dstar) + 0.1 if (!length(rform$X)) local.ht <- glm(nd ~ -1 + fu, data = grm1, family = pot, offset = grm1$lny,mustart=mustart) else { xmat <- as.matrix(grm1[, 7:(ncol(grm1) - 1)]) local.ht <- glm(nd ~ -1 + xmat + fu, data = grm1, family = pot, offset = grm1$lny,mustart=mustart) } names(local.ht[[1]]) <- c(names(rform$X), paste("fu", levels(grm1$fu))) } else stop(paste("Method '", method, "' not a valid method", sep = "")) class(local.ht) <- c("rsadd", class(local.ht)) local.ht$warnme <- warnme local.ht$int <- interval local.ht$groups <- local.ht$data return(local.ht) } #' Calculate Residuals for a "rsadd" Fit #' #' Calculates partial residuals for an additive relative survival model. #' #' #' @param object an object inheriting from class \code{rsadd}, representing a #' fitted additive relative survival model. Typically this is the output from #' the \code{rsadd} function. #' @param type character string indicating the type of residual desired. #' Currently only Schoenfeld residuals are implemented. #' @param ... other arguments. #' @return A list of the following values is returned: \item{res}{a matrix #' containing the residuals for each variable.} \item{varr}{the variance for #' each residual} \item{varr1}{the sum of \code{varr}.} \item{kvarr}{the #' derivative of each residual, to be used in \code{rs.zph} function.} #' \item{kvarr1}{the sum of \code{kvarr}.} #' @seealso \code{\link{rsadd}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' #' Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of #' fit of relative survival models." Statistics in Medicine, \bold{24}: #' 3911--3925. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' sresid <- residuals.rsadd(fit) #' residuals.rsadd <- function (object, type = "schoenfeld", ...) { data <- object$data[order(object$data$Y), ] ratetable <- object$ratetable beta <- object$coef start <- data[, 1] stop <- data[, 2] event <- data[, 3] fk <- (attributes(ratetable)$factor != 1) nfk <- length(fk) n <- nrow(data) scale <- 1 if (object$method == "EM") scale <- 365.241 m <- ncol(data) rem <- m - nfk - 3 interval <- object$int int <- ceiling(max(interval)) R <- data[, 4:(nfk + 3)] lp <- matrix(-log(exp_prep(as.matrix(R), 365.241, object$ratetable))/scale, ncol = 1) fu <- NULL if (object$method == "EM") { death.time <- stop[event == 1] for (it in 1:int) { fu <- as.data.frame(cbind(fu, as.numeric(death.time/365.241 < it & (death.time/365.241) >= (it - 1)))) } if(length(death.time)!=length(unique(death.time))){ utimes <- which(c(1,diff(death.time))!=0) razteg <- function(x){ # x is a 0/1 vector, the output is a vector of length sum(x), with the corresponding rep numbers n <- length(x) repu <- rep(1,n) repu[x==1] <- 0 repu <- rev(cumsum(rev(repu))) repu <- repu[x==1] repu <- -diff(c(repu,0))+1 if(sum(repu)!=n)repu <- c(n-sum(repu),repu) #ce je prvi cas censoring, bo treba se kej narest?? repu } rutd <- rep(0,length(death.time)) rutd[utimes] <- 1 rutd <- razteg(rutd) #from unique event times to event times } else rutd <- rep(1,length(death.time)) lambda0 <- rep(object$lambda0,rutd) } else { pon <- NULL for (i in 1:(length(interval) - 1)) { width <- ceiling(interval[i + 1]) - floor(interval[i]) lo <- interval[i] hi <- min(interval[i + 1], floor(interval[i]) + 1) for (j in 1:width) { fu <- as.data.frame(cbind(fu, as.numeric(stop/365.241 < hi & stop/365.241 >= lo))) names(fu)[ncol(fu)] <- paste("fu", lo, "-", hi, sep = "") if (j == width) { pon <- c(pon, sum(fu[event == 1, (ncol(fu) - width + 1):ncol(fu)])) break() } else { lo <- hi hi <- min(interval[i + 1], floor(interval[i]) + 1 + j) } } } m <- ncol(data) data <- cbind(data, fu) rem <- m - nfk - 3 lambda0 <- rep(exp(beta[rem + 1:(length(interval) - 1)]), pon) fu <- fu[event == 1, , drop = FALSE] beta <- beta[1:rem] } if (int >= 2) { for (j in 2:int) { R <- R + matrix(fk * 365.241, ncol = ncol(R), byrow = TRUE, nrow = n) xx <- exp_prep(R, 365.241, object$ratetable) lp <- cbind(lp, -log(xx)/scale) } } z <- as.matrix(data[, (4 + nfk):m]) out <- resid.com(start, stop, event, z, beta, lp, lambda0, fu, n, rem, int, type) out } resid.com <- function (start, stop, event, z, beta, lp, lambda0, fup, n, rem, int, type) { le <- exp(z %*% beta) olp <- if (int > 1) apply(lp[n:1, ], 2, cumsum)[n:1, ] else matrix(cumsum(lp[n:1])[n:1], ncol = 1) ole <- cumsum(le[n:1])[n:1] lp.st <- lp[order(start), , drop = FALSE] le.st <- le[order(start), , drop = FALSE] starter <- sort(start) starter1 <- c(starter[1], starter[-length(starter)]) index <- c(TRUE, (starter != starter1)[-1]) starter <- starter[index] val1 <- apply(matrix(starter, ncol = 1), 1, function(x, Y) sum(x >= Y), stop) val1 <- c(val1[1], diff(val1), length(stop) - val1[length(val1)]) olp.st <- (apply(lp.st[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE])[index, , drop = FALSE] olp.st <- apply(olp.st, 2, function(x) rep(c(x, 0), val1)) olp <- olp - olp.st olp <- olp[event == 1, ] olp <- apply(fup * olp, 1, sum) ole.st <- cumsum(le.st[n:1])[n:1][index] ole.st <- rep(c(ole.st, 0), val1) ole <- ole - ole.st ole <- ole[event == 1] * lambda0 s0 <- ole + olp sc <- NULL zb <- NULL kzb <- NULL f1 <- function(x) rep(mean(x), length(x)) f2 <- function(x) apply(x, 2, f1) f3 <- function(x) apply(x, 1:2, f1) ties <- length(unique(stop[event == 1])) != length(stop[event == 1]) for (k in 1:rem) { zlp <- apply((z[, k] * lp)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE] zlp.st <- (apply((z[, k] * lp.st)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE])[index, , drop = FALSE] zlp.st <- apply(zlp.st, 2, function(x) rep(c(x, 0), val1)) zlp <- zlp - zlp.st zlp <- zlp[event == 1, , drop = FALSE] zlp <- apply(fup * zlp, 1, sum) zle <- cumsum((z[, k] * le)[n:1])[n:1] zle.st <- cumsum((z[, k] * le.st)[n:1])[n:1][index] zle.st <- rep(c(zle.st, 0), val1) zle <- zle - zle.st zle <- zle[event == 1] zle <- zle * lambda0 s1 <- zle + zlp zb <- cbind(zb, s1/s0) kzb <- cbind(kzb, zle/s0) } s1ties <- cbind(zb, kzb) if (ties) { s1ties <- by(s1ties, stop[event == 1], f2) s1ties <- do.call("rbind", s1ties) } zb <- s1ties[, 1:rem, drop = FALSE] kzb <- s1ties[, -(1:rem), drop = FALSE] sc <- z[event == 1, , drop = FALSE] - zb row.names(sc) <- stop[event == 1] out.temp <- function(x) outer(x, x, FUN = "*") krez <- rez <- array(matrix(NA, ncol = rem, nrow = rem), dim = c(rem, rem, sum(event == 1))) for (a in 1:rem) { for (b in a:rem) { zzlp <- apply((z[, a] * z[, b] * lp)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE] zzlp.st <- (apply((z[, a] * z[, b] * lp.st)[n:1, , drop = FALSE], 2, cumsum)[n:1, , drop = FALSE])[index, , drop = FALSE] zzlp.st <- apply(zzlp.st, 2, function(x) rep(c(x, 0), val1)) zzlp <- zzlp - zzlp.st zzlp <- zzlp[event == 1, , drop = FALSE] zzlp <- apply(fup * zzlp, 1, sum) zzle <- cumsum((z[, a] * z[, b] * le)[n:1])[n:1] zzle.st <- cumsum((z[, a] * z[, b] * le.st)[n:1])[n:1][index] zzle.st <- rep(c(zzle.st, 0), val1) zzle <- zzle - zzle.st zzle <- zzle[event == 1] zzle <- zzle * lambda0 s2 <- zzlp + zzle s20 <- s2/s0 ks20 <- zzle/s0 s2ties <- cbind(s20, ks20) if (ties) { s2ties <- by(s2ties, stop[event == 1], f2) s2ties <- do.call("rbind", s2ties) } rez[a, b, ] <- rez[b, a, ] <- s2ties[, 1] krez[a, b, ] <- krez[b, a, ] <- s2ties[, 2] } } juhu <- apply(zb, 1, out.temp) if (is.null(dim(juhu))) juhu1 <- array(data = matrix(juhu, ncol = a), dim = c(a, a, length(zb[, 1]))) else juhu1 <- array(data = apply(juhu, 2, matrix, ncol = a), dim = c(a, a, length(zb[, 1]))) varr <- rez - juhu1 kjuhu <- apply(cbind(zb, kzb), 1, function(x) outer(x[1:rem], x[-(1:rem)], FUN = "*")) if (is.null(dim(kjuhu))) kjuhu1 <- array(data = matrix(kjuhu, ncol = rem), dim = c(rem, rem, length(zb[, 1]))) else kjuhu1 <- array(data = apply(kjuhu, 2, matrix, ncol = rem), dim = c(rem, rem, length(zb[, 1]))) kvarr <- krez - kjuhu1 for (i in 1:dim(varr)[1]) varr[i, i, which(varr[i, i, ] < 0)] <- 0 for (i in 1:dim(kvarr)[1]) kvarr[i, i, which(kvarr[i, i, ] < 0)] <- 0 varr1 <- apply(varr, 1:2, sum) kvarr1 <- apply(kvarr, 1:2, sum) if (type == "schoenfeld") out <- list(res = sc, varr1 = varr1, varr = varr, kvarr = kvarr, kvarr1 = kvarr1) out } #' Test the Proportional Hazards Assumption for Relative Survival Regression #' Models #' #' Test the proportional hazards assumption for relative survival models #' (\code{rsadd}, \code{rsmul} or \code{rstrans}) by forming a Brownian Bridge. #' #' #' @aliases rs.br plot.rs.br print.rs.br #' @param fit the result of fitting a relative survival model, using the #' \code{rsadd}, \code{rsmul} or \code{rstrans} function. #' @param sc partial residuals calculated by the \code{resid} function. This is #' used to save time if several tests are to be calculated on these residuals #' and can otherwise be omitted. #' @param rho a number controlling the weigths of residuals. The weights are #' the number of individuals at risk at each event time to the power #' \code{rho}. The default is \code{rho=0}, which sets all weigths to 1. #' @param test a character string specifying the test to be performed on #' Brownian bridge. Possible values are \code{"max"} (default), which tests the #' maximum absolute value of the bridge, and \code{cvm}, which calculates the #' Cramer Von Mises statistic. #' @param global should a global Brownian bridge test be performed, in addition #' to the per-variable tests #' @return an object of class \code{rs.br}. This function would usually be #' followed by both a print and a plot of the result. The plot gives a Brownian #' bridge for each of the variables. The horizontal lines are the 95% and 99% #' confidence intervals for the maximum absolute value of the Brownian bridge #' @seealso \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, #' \code{\link{resid}}. #' @references Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) #' "Goodness of fit of relative survival models." Statistics in Medicine, #' \bold{24}: 3911--3925. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' rsbr <- rs.br(fit) #' rsbr #' plot(rsbr) #' rs.br <- function (fit, sc, rho = 0, test = "max", global = TRUE) { test <- match.arg(test,c("max","cvm")) if (inherits(fit, "rsadd")) { if (missing(sc)) sc <- resid(fit, "schoenfeld") sresid <- sc$res varr <- sc$varr sresid <- as.matrix(sresid) } else { coef <- fit$coef options(warn = -1) sc <- coxph.detail(fit) options(warn = 0) sresid <- sc$score varr <- sc$imat if (is.null(dim(varr))) varr <- array(varr, dim = c(1, 1, length(varr))) sresid <- as.matrix(sresid) } if (inherits(fit, "coxph")) { if(is.null(fit$data)){ temp <- fit$y class(temp) <- "matrix" if(ncol(fit$y)==2)temp <- data.frame(rep(0,nrow(fit$y)),temp) if(is.null(fit$x))stop("The coxph model should be called with x=TRUE argument") fit$data <- data.frame(temp,fit$x) names(fit$data)[1:3] <- c("start","Y","stat") } } data <- fit$data[order(fit$data$Y), ] time <- data$Y[data$stat == 1] ties <- (length(unique(time)) != length(time)) keep <- 1:(ncol(sresid)) options(warn = -1) scaled <- NULL varnova <- NULL if (ncol(sresid) == 1) { varr <- varr[1, 1, ] scaled <- sresid/sqrt(varr) } else { for (i in 1:ncol(sresid)) varnova <- cbind(varnova,varr[i,i,]) scaled <- sresid/sqrt(varnova) } options(warn = 0) nvar <- ncol(sresid) survfit <- getFromNamespace("survfit", "survival") temp <- survfit(fit$y~1, type = "kaplan-meier") n.risk <- temp$n.risk n.time <- temp$time if (temp$type == "right") { cji <- matrix(fit$y, ncol = 2) n.risk <- n.risk[match(cji[cji[, 2] == 1, 1], n.time)] } else { cji <- matrix(fit$y, ncol = 3) n.risk <- n.risk[match(cji[cji[, 3] == 1, 2], n.time)] } n.risk <- sort(n.risk, decreasing = TRUE) varnames <- names(fit$coef)[keep] u2 <- function(bb) { n <- length(bb) 1/n * (sum(bb^2) - sum(bb)^2/n) } wc <- function(x, k = 1000) { a <- 1 for (i in 1:k) a <- a + 2 * (-1)^i * exp(-2 * i^2 * pi^2 * x) a } brp <- function(x, n = 1000) { a <- 1 for (i in 1:n) a <- a - 2 * (-1)^(i - 1) * exp(-2 * i^2 * x^2) a } global <- as.numeric(global & ncol(sresid) > 1) table <- NULL bbt <- as.list(1:(nvar + global)) for (i in 1:nvar) { if (nvar != 1) usable <- which(varr[i, i, ] > 1e-12) else usable <- which(varr > 1e-12) w <- (n.risk[usable])^rho w <- w/sum(w) if (nvar != 1) { sci <- scaled[usable, i] } else sci <- scaled[usable] if (ties) { if (inherits(fit, "rsadd")) { sci <- as.vector(by(sci, time[usable], function(x) sum(x)/sqrt(length(x)))) w <- as.vector(by(w, time[usable], sum)) } else { w <- w * as.vector(table(time))[usable] w <- w/sum(w) } } sci <- sci * sqrt(w) timescale <- cumsum(w) bm <- cumsum(sci) bb <- bm - timescale * bm[length(bm)] if (test == "max") table <- rbind(table, c(max(abs(bb)), 1 - brp(max(abs(bb))))) else if (test == "cvm") table <- rbind(table, c(u2(bb), 1 - wc(u2(bb)))) bbt[[i]] <- cbind(timescale, bb) } if (inherits(fit, "rsadd")) { beta <- fit$coef[1:(length(fit$coef) - length(fit$int) + 1)] } else beta <- fit$coef if (global) { qform <- function(matrix, vector) t(vector) %*% matrix %*% vector diagonal <- apply(varr, 3, diag) sumdiag <- apply(diagonal, 2, sum) usable <- which(sumdiag > 1e-12) score <- t(beta) %*% t(sresid[usable, ]) varr <- varr[, , usable] qf <- apply(varr, 3, qform, vector = beta) w <- (n.risk[usable])^rho w <- w/sum(w) sci <- score/(qf)^0.5 if (ties) { if (inherits(fit, "rsadd")) { sci <- as.vector(by(t(sci), time[usable], function(x) sum(x)/sqrt(length(x)))) w <- as.vector(by(w, time[usable], sum)) } else { w <- w * as.vector(table(time)) w <- w/sum(w) } } sci <- sci * sqrt(w) timescale <- cumsum(w) bm <- cumsum(sci) bb <- bm - timescale * bm[length(bm)] if (test == "max") table <- rbind(table, c(max(abs(bb)), 1 - brp(max(abs(bb))))) else if (test == "cvm") table <- rbind(table, c(u2(bb), 1 - wc(u2(bb)))) bbt[[nvar + 1]] <- cbind(timescale, bb) varnames <- c(varnames, "GLOBAL") } dimnames(table) <- list(varnames, c(test, "p")) out <- list(table = table, bbt = bbt, rho = rho) class(out) <- "rs.br" out } #' Behaviour of Covariates in Time for Relative Survival Regression Models #' #' Calculates the scaled partial residuals of a relative survival model #' (\code{rsadd}, \code{rsmul} or \code{rstrans}) #' #' #' @param fit the result of fitting an additive relative survival model, using #' the \code{rsadd}, \code{rsmul} or \code{rstrans} function. #' #' In the case of multiplicative and transformation models the output is #' identical to \code{cox.zph} function, except no test is performed. #' @param sc partial residuals calculated by the \code{resid} function. This is #' used to save time if several tests are to be calculated on these residuals #' and can otherwise be omitted. #' @param transform a character string specifying how the survival times should #' be transformed. Possible values are \code{"km"}, \code{"rank"}, #' \code{"identity"} and \code{log}. The default is \code{"identity"}. #' @param var.type a character string specifying the variance used to scale the #' residuals. Possible values are \code{"each"}, which estimates the variance #' for each residual separately, and \code{sum}(default), which assumes the #' same variance for all the residuals. #' @return an object of class \code{rs.zph}. This function would usually be #' followed by a plot of the result. The plot gives an estimate of the #' time-dependent coefficient \code{beta(t)}. If the proportional hazards #' assumption is true, \code{beta(t)} will be a horizontal line. #' @seealso \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, #' \code{\link{resid}}, \code{\link[survival:cox.zph]{survival::cox.zph}}. #' @references Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) #' "Goodness of fit of relative survival models." Statistics in Medicine, #' \bold{24}: 3911--3925. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' rszph <- rs.zph(fit) #' plot(rszph) #' rs.zph <- function (fit, sc, transform = "identity", var.type = "sum") { if (inherits(fit, "rsadd")) { if (missing(sc)) sc <- resid(fit, "schoenfeld") sresid <- sc$res varr <- sc$kvarr fvar <- solve(sc$kvarr1) sresid <- as.matrix(sresid) } else { coef <- fit$coef options(warn = -1) sc <- coxph.detail(fit) options(warn = 0) sresid <- as.matrix(resid(fit, "schoenfeld")) varr <- sc$imat fvar <- fit$var } data <- fit$data[order(fit$data$Y), ] time <- data$Y stat <- data$stat if (!inherits(fit, "rsadd")) { ties <- as.vector(table(time[stat==1])) if(is.null(dim(varr))) varr <- rep(varr/ties,ties) else{ varr <- apply(varr,1:2,function(x)rep(x/ties,ties)) varr <- aperm(varr,c(2,3,1)) } } keep <- 1:(length(fit$coef) - length(fit$int) + 1) varnames <- names(fit$coef)[keep] nvar <- length(varnames) ndead <- length(sresid)/nvar if (inherits(fit, "rsadd")) times <- time[stat == 1] else times <- sc$time if (is.character(transform)) { tname <- transform ttimes <- switch(transform, identity = times, rank = rank(times), log = log(times), km = { fity <- Surv(time, stat) temp <- survfit(fity~1) t1 <- temp$surv[temp$n.event > 0] t2 <- temp$n.event[temp$n.event > 0] km <- rep(c(1, t1), c(t2, 0)) if (is.null(attr(sresid, "strata"))) 1 - km else (1 - km[sort.list(sort.list(times))]) }, stop("Unrecognized transform")) } else { tname <- deparse(substitute(transform)) ttimes <- transform(times) } if (var.type == "each") { invV <- apply(varr, 3, function(x) try(solve(x), silent = TRUE)) if (length(invV) == length(varr)){ if(!is.numeric(invV)){ usable <- rep(FALSE, dim(varr)[3]) options(warn=-1) invV <- as.numeric(invV) usable[1:(min(which(is.na(invV)))-1)] <- TRUE invV <- invV[usable] sresid <- sresid[usable,,drop=FALSE] options(warn=0) } else usable <- rep(TRUE, dim(varr)[3]) } else { usable <- unlist(lapply(invV, is.matrix)) if (!any(usable)) stop("All the matrices are singular") invV <- invV[usable] sresid <- sresid[usable, , drop = FALSE] } di1 <- dim(varr)[1] di3 <- sum(usable) u <- array(data = matrix(unlist(invV), ncol = di1), dim = c(di1, di1, di3)) uv <- cbind(matrix(u, ncol = di1, byrow = TRUE), as.vector(t(sresid))) uv <- array(as.vector(t(uv)), dim = c(di1 + 1, di1, di3)) r2 <- t(apply(uv, 3, function(x) x[1:di1, ] %*% x[di1 + 1, ])) r2 <- matrix(r2, ncol = di1) whr2 <- apply(r2<100,1,function(x)!any(x==FALSE)) usable <- as.logical(usable*whr2) r2 <- r2[usable,,drop=FALSE] u <- u[,,usable] dimnames(r2) <- list(times[usable], varnames) temp <- list(x = ttimes[usable], y = r2 + outer(rep(1, sum(usable)), fit$coef[keep]), var = u, call = call, transform = tname) } else if (var.type == "sum") { xx <- ttimes - mean(ttimes) r2 <- t(fvar %*% t(sresid) * ndead) r2 <- as.matrix(r2) dimnames(r2) <- list(times, varnames) temp <- list(x = ttimes, y = r2 + outer(rep(1, ndead), fit$coef[keep]), var = fvar, transform = tname) } else stop("Unknown 'var.type'") class(temp) <- "rs.zph" temp } #' Graphical Inspection of Proportional Hazards Assumption in Relative Survival #' Models #' #' Displays a graph of the scaled partial residuals, along with a smooth curve. #' #' #' @param x result of the \code{rs.zph} function. #' @param resid a logical value, if \code{TRUE} the residuals are included on #' the plot, as well as the smooth fit. #' @param df the degrees of freedom for the fitted natural spline, \code{df=2} #' leads to a linear fit. #' @param nsmo number of points used to plot the fitted spline. #' @param var the set of variables for which plots are desired. By default, #' plots are produced in turn for each variable of a model. Selection of a #' single variable allows other features to be added to the plot, e.g., a #' horizontal line at zero or a main title. #' @param cex a numerical value giving the amount by which plotting text and #' symbols should be scaled relative to the default. #' @param add logical, if \code{TRUE} the plot is added to an existing plot #' @param col a specification for the default plotting color. #' @param lty the line type. #' @param xlab x axis label. #' @param ylab y axis label. #' @param xscale units for x axis, default is 1, i.e. days. #' @param ... Additional arguments passed to the \code{plot} function. #' @seealso \code{\link{rs.zph}}, \code{\link[survival:plot.cox.zph]{survival::plot.cox.zph}} #' @references Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) #' "Goodness of fit of relative survival models." Statistics in Medicine, #' \bold{24}: 3911-3925. #' #' Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741-1749, 2007. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' fit <- rsadd(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5) #' rszph <- rs.zph(fit) #' plot(rszph) #' plot.rs.zph <- function (x,resid = TRUE, df = 4, nsmo = 40, var, cex = 1, add = FALSE, col = 1, lty = 1, xlab, ylab, xscale = 1, ...) { #require(splines) xx <- x$x if(x$transform=="identity")xx <- xx/xscale yy <- x$y d <- nrow(yy) df <- max(df) nvar <- ncol(yy) pred.x <- seq(from = min(xx), to = max(xx), length = nsmo) temp <- c(pred.x, xx) lmat <- splines::ns(temp, df = df, intercept = TRUE) pmat <- lmat[1:nsmo, ] xmat <- lmat[-(1:nsmo), ] qmat <- qr(xmat) if (missing(ylab)) ylab <- paste("Beta(t) for", dimnames(yy)[[2]]) if (missing(xlab)) xlab <- "Time" if (missing(var)) var <- 1:nvar else { if (is.character(var)) var <- match(var, dimnames(yy)[[2]]) if (any(is.na(var)) || max(var) > nvar || min(var) < 1) stop("Invalid variable requested") } if (x$transform == "log") { xx <- exp(xx) pred.x <- exp(pred.x) } else if (x$transform != "identity") { xtime <- as.numeric(dimnames(yy)[[1]])/xscale apr1 <- approx(xx, xtime, seq(min(xx), max(xx), length = 17)[2 * (1:8)]) temp <- signif(apr1$y, 2) apr2 <- approx(xtime, xx, temp) xaxisval <- apr2$y xaxislab <- rep("", 8) for (i in 1:8) xaxislab[i] <- format(temp[i]) } for (i in var) { y <- yy[, i] yhat <- pmat %*% qr.coef(qmat, y) yr <- range(yhat, y) if (!add) { if (x$transform == "identity") plot(range(xx), yr, type = "n", xlab = xlab, ylab = ylab[i],...) else if (x$transform == "log") plot(range(xx), yr, type = "n", xlab = xlab, ylab = ylab[i],log = "x", ...) else { plot(range(xx), yr, type = "n", xlab = xlab, ylab = ylab[i],axes = FALSE, ...) axis(1, xaxisval, xaxislab) axis(2) box() } } if (resid) points(xx, y, cex = cex, col = col) lines(pred.x, yhat, col = col, lty = lty) } } plot.rs.br <- function (x, var, ylim = c(-2, 2), xlab, ylab, ...) { bbt <- x$bbt par(ask = TRUE) if (missing(var)) var <- 1:nrow(x$table) ychange <- FALSE if (missing(ylab)) ylab <- paste("Brownian bridge for", row.names(x$table)) else { if (length(ylab) == 1 & nrow(x$table) > 1) ylab <- rep(ylab, nrow(x$table)) } if (missing(xlab)) xlab <- "Time" for (i in var) { timescale <- bbt[[i]][, 1] bb <- bbt[[i]][, 2] plot(c(0, timescale), c(0, bb), type = "l", ylim = ylim, xlab = xlab, ylab = ylab[i], ...) abline(h = 1.36, col = 2) abline(h = 1.63, col = 2) abline(h = -1.36, col = 2) abline(h = -1.63, col = 2) } par(ask = FALSE) } Kernmatch <- function (t, tv, b, tD, nt4) { kmat <- NULL for (it in 1:(length(nt4) - 1)) { kmat1 <- (outer(t[(nt4[it] + 1):nt4[it + 1]], tv, "-")/b[it]) kmat1 <- kmat1^(kmat1 >= 0) kmat <- rbind(kmat, pmax(1 - kmat1^2, 0) * (1.5/b[it])) } kmat } kernerleftch <- function (td, b, nt4) { n <- length(td) ttemp <- td[td >= b[1]] ntemp <- length(ttemp) if (ntemp == n) nt4 <- c(0, nt4[-1]) else { nfirst <- n - ntemp nt4 <- c(0, 1:nfirst, nt4[-1]) b <- c(td[1:nfirst], b) } krn <- Kernmatch(td, td, b, max(td), nt4) krn } #' Inverse transforming of time in Relative Survival #' #' This function can be used when predicting in Relative Survival using the #' transformed time regression model (using \code{rstrans} function). It #' inverses the time from Y to T in relative survival using the given #' ratetable. The times Y can be produced with the \code{rstrans} function, in #' which case, this is the reverse function. This function does the #' transformation for one person at a time. #' #' Works only with ratetables that are split by age, sex and year. Transforming #' can be computationally intensive, use lower and/or upper to guess the #' interval of the result and thus speed up the function. #' #' @param y time in Y. #' @param age age of the individual. Must be in days. #' @param sex sex of the individual. Must be coded in the same way as in the #' \code{ratetable}. #' @param year date of diagnosis. Must be in a Date or POSIXt format. #' @param scale numeric value to scale the results. If \code{ratetable} is in #' units/day, \code{scale = 365.241} causes the output to be reported in years. #' @param ratetable a table of event rates, such as \code{survexp.us}. #' @param lower the lower bound of interval where the result is expected. This #' argument is optional, but, if given, can shorten the time the function needs #' to calculate the result. #' @param upper the upper bound of interval where the result is expected. See #' \code{lower}. #' @return A list of values \item{T}{the original time} \item{Y}{the #' transformed time}. #' @seealso \code{\link{rstrans}} #' @references Package: Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741-1749. #' @keywords survival #' @examples #' #' data(slopop) #' invtime(y = 0.1, age = 23011, sex = 1, year = as.Date('1986-01-01'), ratetable = slopop) #' invtime <- function (y = 0.1, age = 23011, sex = "male", year = as.Date('1986-01-01'), scale = 1, ratetable = relsurv::slopop, lower, upper) { if (!is.numeric(age)) stop("\"age\" must be numeric", call. = FALSE) if (!is.numeric(y)) stop("\"y\" must be numeric", call. = FALSE) if (!is.numeric(scale)) stop("\"scale\" must be numeric", call. = FALSE) temp <- data.frame(age = age, sex = I(sex), year = year) if (missing(lower)) { if (!missing(upper)) stop("Argument \"lower\" is missing, with no default", call. = FALSE) nyears <- round((110 - age/365.241)) tab <- data.frame(age = rep(age, nyears), sex = I(rep(sex, nyears)), year = rep(year, nyears)) vred <- 1 - survexp(c(0, 1:(nyears - 1)) * 365.241 ~ ratetable(age = age, sex = sex, year = year), ratetable = ratetable, data = tab, cohort = FALSE) place <- sum(vred <= y) if (place == 0) lower <- 0 else lower <- floor((place - 1) * 365.241 - place) upper <- ceiling(place * 365.241 + place) } else { if (missing(upper)) stop("Argument \"upper\" is missing, with no default", call. = FALSE) if (!is.integer(lower)) lower <- floor(lower) if (!is.integer(upper)) upper <- ceiling(upper) if (upper <= lower) stop("'upper' must be higher than 'lower'", call. = FALSE) } lower <- max(0, lower) tab <- data.frame(age = rep(age, upper - lower + 1), sex = I(rep(sex, upper - lower + 1)), year = rep(year, upper - lower + 1)) vred <- 1 - survexp((lower:upper) ~ ratetable(age = age, sex = sex, year = year), ratetable = ratetable, data = tab, cohort = FALSE) place <- sum(vred <= y) if (place == 0) warning(paste("The event happened on or before day", lower), call. = FALSE) if (place == length(vred)) warning(paste("The event happened on or after day", upper), call. = FALSE) t <- (place + lower - 1)/scale age <- round(age/365.241, 0.01) return(list(age, sex, year, Y = y, T = t)) } #' Fit Andersen et al Multiplicative Regression Model for Relative Survival #' #' Fits the Andersen et al multiplicative regression model in relative #' survival. An extension of the coxph function using relative survival. #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, such as \code{slopop}. #' @param int the number of follow-up years used for calculating survival(the #' data are censored after this time-point). If missing, it is set the the #' maximum observed follow-up time. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param init vector of initial values of the iteration. Default initial #' value is zero for all variables. #' @param method the default method \code{mul} assumes hazard to be constant on #' yearly intervals. Method \code{mul1} uses the ratetable to determine the #' time points when hazard changes. The \code{mul1} method is therefore more #' accurate, but at the same time can be more computationally intensive. #' @param control a list of parameters for controlling the fitting process. #' See the documentation for \code{coxph.control} for details. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param ... Other arguments will be passed to \code{coxph.control}. #' @return an object of class \code{coxph} with an additional item: #' \item{basehaz}{Cumulative baseline hazard (population values are seen as #' offset) at centered values of covariates.} #' @seealso \code{\link{rsadd}}, \code{\link{rstrans}}. #' @references Method: Andersen, P.K., Borch-Johnsen, K., Deckert, T., Green, #' A., Hougaard, P., Keiding, N. and Kreiner, S. (1985) "A Cox regression model #' for relative mortality and its application to diabetes mellitus survival #' data.", Biometrics, \bold{41}: 921--932. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit a multiplicative model #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- rsmul(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata) #' #' #' #check the goodness of fit #' rs.br(fit) #' #' rsmul <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, init, method = "mul", control,rmap, ...) { #require(survival) if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula,data, ratetable, na.action,rmap,int) U <- rform$data if (missing(int)) int <- ceiling(max(rform$Y/365.241)) if(length(int)!=1)int <- max(int) fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) if (method == "mul") { U <- survsplit(U, cut = (1:int) * 365.241, end = "Y", event = "stat", start = "start", episode = "epi") fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) U[, 4:(nfk + 3)] <- U[, 4:(nfk + 3)] + 365.241 * (U$epi) %*% t(fk) nsk <- dim(U)[1] xx <- exp_prep(U[, 4:(nfk + 3),drop=FALSE], 365.241, rform$ratetable) lambda <- -log(xx)/365.241 } else if (method == "mul1") { U$id <- 1:dim(U)[1] my.fun <- function(x, attcut, nfk, fk) { intr <- NULL for (i in 1:nfk) { if (fk[i]) { n1 <- max(findInterval(as.numeric(x[3 + i]) + as.numeric(x[1]), attcut[[i]]) + 1, 2) n2 <- findInterval(as.numeric(x[3 + i]) + as.numeric(x[2]), attcut[[i]]) if (n2 > n1 & length(attcut[[i]] > 1)) { if (n2 > length(attcut[[i]])) n2 <- length(attcut[[i]]) intr <- c(intr, as.numeric(attcut[[i]][n1:n2]) - as.numeric(x[3 + i])) } } } intr <- sort(unique(c(intr, as.numeric(x[2])))) intr } attcut <- attributes(rform$ratetable)$cutpoints intr <- apply(U[, 1:(3 + nfk)], 1, my.fun, attcut, nfk, fk) dolg <- unlist(lapply(intr, length)) newdata <- lapply(U, rep, dolg) stoptime <- unlist(intr) starttime <- c(-1, stoptime[-length(stoptime)]) first <- newdata$id != c(-1, newdata$id[-length(newdata$id)]) starttime[first] <- newdata$start[first] last <- newdata$id != c(newdata$id[-1], -1) event <- rep(0, length(newdata$id)) event[last] <- newdata$stat[last] U <- do.call("data.frame", newdata) U$start <- starttime U$Y <- stoptime U$stat <- event U[, 4:(nfk + 3)] <- U[, 4:(nfk + 3)] + (U$start) %*% t(fk) nsk <- dim(U)[1] xx <- exp_prep(U[, 4:(nfk + 3),drop=FALSE], 1, rform$ratetable) lambda <- -log(xx)/1 } else stop("'method' must be one of 'mul' or 'mul1'") U$lambda <- log(lambda) if (rform$m == 0) fit <- coxph(Surv(start, Y, stat) ~ 1 + offset(lambda), data = U, init = init, control = control, x = TRUE, ...) else { xmat <- as.matrix(U[, (3 + nfk + 1):(ncol(U) - 2)]) fit <- coxph(Surv(start, Y, stat) ~ xmat + offset(lambda), data = U, init = init, control = control, x = TRUE, ...) names(fit[[1]]) <- names(U)[(3 + nfk + 1):(ncol(U) - 2)] } class(fit) <- c("rsmul",class(fit)) fit$basehaz <- basehaz(fit) #NEW 2.05 fit$data <- rform$data fit$call <- match.call() fit$int <- int if (length(rform$na.action)) fit$na.action <- rform$na.action fit } #' Fit Cox Proportional Hazards Model in Transformed Time #' #' The function transforms each person's time to his/her probability of dying #' at that time according to the ratetable. It then fits the Cox proportional #' hazards model with the transformed times as a response. It can also be used #' for calculatin the transformed times (no covariates are needed in the #' formula for that purpose). #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. A side product of this #' function are the transformed times - stored in teh \code{y} object of the #' output. To get these times, covariates are of course irrelevant. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, such as \code{slopop}. #' @param int the number of follow-up years used for calculating survival(the #' rest is censored). If missing, it is set the the maximum observed follow-up #' time. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param init vector of initial values of the iteration. Default initial #' value is zero for all variables. #' @param control a list of parameters for controlling the fitting process. #' See the documentation for \code{coxph.control} for details. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param ... other arguments will be passed to \code{coxph.control}. #' @return an object of class \code{coxph}. See \code{coxph.object} and #' \code{coxph.detail} for details. \item{y}{ an object of class \code{Surv} #' containing the transformed times (these times do not depend on covariates). #' } #' @seealso \code{\link{rsmul}}, \code{\link{invtime}}, \code{\link{rsadd}}, #' \code{\link[survival:survexp]{survival::survexp}}. #' @references Method: Stare J., Henderson R., Pohar M. (2005) "An individual #' measure for relative survival." Journal of the Royal Statistical Society: #' Series C, \bold{54} 115--126. #' #' Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." #' Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #' #fit a Cox model using the transformed times #' #note that the variable year is given in days since 01.01.1960 and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' fit <- rstrans(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241, #' sex=sex,year=year),ratetable=slopop,data=rdata) #' #' #' #check the goodness of fit #' rs.br(fit) #' rstrans <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, init, control,rmap, ...) { if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action, rmap, int) if (missing(int)) int <- ceiling(max(rform$Y/365.241)) fk <- (attributes(rform$ratetable)$factor != 1) nfk <- length(fk) if (rform$type == "counting") { start <- 1 - exp_prep(rform$R, rform$start, rform$ratetable) } else start <- rep(0, rform$n) stop <- 1 - exp_prep(rform$R, rform$Y, rform$ratetable) if(any(stop==0&rform$Y!=0))stop[stop==0&rform$Y!=0] <- .Machine$double.eps if(length(int)!=1)int <- max(int) data <- rform$data stat <- rform$status if (rform$m == 0) { if (rform$type == "counting") fit <- coxph(Surv(start, stop, stat) ~ 1, init = init, control = control, x = TRUE, ...) else fit <- coxph(Surv(stop, stat) ~ 1, init = init, control = control, x = TRUE, ...) } else { xmat <- as.matrix(data[, (4 + nfk):ncol(data)]) fit <- coxph(Surv(start, stop, stat) ~ xmat, init = init, control = control, x = TRUE, ...) names(fit[[1]]) <- names(rform$X) } fit$call <- match.call() if (length(rform$na.action)) fit$na.action <- rform$na.action data$start <- start data$Y <- stop fit$data <- data fit$int <- int return(fit) } #' Reorganize Data into a Ratetable Object #' #' The function assists in reorganizing certain types of data into a ratetable #' object. #' #' This function only applies for ratetables that are organized by age, sex and #' year. #' #' @param men a matrix containing the yearly (conditional) probabilities of one #' year survival for men. Rows represent age (increasing 1 year per #' line,starting with 0), the columns represent cohort years (the limits are in #' \code{yearlim}, the increase is in \code{int.length}. #' @param women a matrix containing the yearly (conditional) probabilities of #' one year survival for women. #' @param yearlim the first and last cohort year given in the tables. #' @param int.length the length of intervals in which cohort years are given. #' @return An object of class \code{ratetable}. #' @seealso \code{\link[survival:ratetable]{survival::ratetable}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' men <- cbind(exp(-365.241*exp(-14.5+.08*(0:100))),exp(-365*exp(-14.7+.085*(0:100)))) #' women <- cbind(exp(-365.241*exp(-15.5+.085*(0:100))),exp(-365*exp(-15.7+.09*(0:100)))) #' table <- transrate(men,women,yearlim=c(1980,1990),int.length=10) #' transrate <- function (men, women, yearlim, int.length = 1) { if (any(dim(men) != dim(women))) stop("The men and women matrices must be of the same size. \n In case of missing values at the end carry the last value forward") if ((yearlim[2] - yearlim[1])/int.length + 1 != dim(men)[2]) stop("'yearlim' cannot be divided into intervals of equal length") if (!is.matrix(men) | !is.matrix(women)) stop("input tables must be of class matrix") dimi <- dim(men) temp <- array(c(men, women), dim = c(dimi, 2)) temp <- -log(temp)/365.241 temp <- aperm(temp, c(1, 3, 2)) cp <- as.Date(apply(matrix(yearlim[1] + int.length * (0:(dimi[2] - 1)), ncol = 1), 1, function(x) { paste(x, "-01-01", sep = "") })) attributes(temp) <- list(dim = c(dimi[1], 2, dimi[2]), dimnames = list(age=as.character(0:(dimi[1] - 1)), sex=c("male", "female"), year=as.character(yearlim[1] + int.length * (0:(dimi[2] - 1)))), dimid = c("age", "sex", "year"), factor = c(0, 1, 0),type=c(2,1,3), cutpoints = list((0:(dimi[1] - 1)) * (365.241), NULL, cp), class = "ratetable") attributes(temp)$summary <- function (R) { x <- c(format(round(min(R[, 1])/365.241, 1)), format(round(max(R[, 1])/365.241, 1)), sum(R[, 2] == 1), sum(R[, 2] == 2)) x2 <- as.character(as.Date(c(min(R[, 3]), max(R[, 3])), origin=as.Date('1970-01-01'))) paste(" age ranges from", x[1], "to", x[2], "years\n", " male:", x[3], " female:", x[4], "\n", " date of entry from", x2[1], "to", x2[2], "\n") } temp } #' Reorganize Data obtained from Human Life-Table Database into a Ratetable #' Object #' #' The function assists in reorganizing the .txt files obtained from Human #' Life-Table Database (http://www.lifetable.de -> Data by Country) into a #' ratetable object. #' #' This function works with any table organised in the format provided by the #' Human Life-Table Database, but currently only works with TypeLT 1 (i.e. age #' intervals of length 1). The age must always start with value 0, but can end #' at different values (when that happens, the last value is carried forward). #' The rates between the cutpoints are taken to be constant. #' #' @param file a vector of file names which the data are to be read from. Must #' be in .tex format and in the same format as the files in Human Life-Table #' Database. #' @param cut.year a vector of cutpoints for years. Must be specified when the #' year spans in the files are not consecutive. #' @param race a vector of race names for the input files. #' @return An object of class \code{ratetable}. #' @seealso \code{\link[survival:ratetable]{survival::ratetable}}, \code{\link{transrate.hmd}}, #' \code{\link{joinrate}}, \code{\link{transrate}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' \dontrun{ #' finpop <- transrate.hld(c("FIN_1981-85.txt","FIN_1986-90.txt","FIN_1991-95.txt")) #' } #' \dontrun{ #' nzpop <- transrate.hld(c("NZL_1980-82_Non-maori.txt","NZL_1985-87_Non-maori.txt", #' "NZL_1980-82_Maori.txt","NZL_1985-87_Maori.txt"), #' cut.year=c(1980,1985),race=rep(c("nonmaori","maori"),each=2)) #' } #' transrate.hld <- function(file, cut.year,race){ nfiles <- length(file) data <- NULL for(it in 1:nfiles){ tdata <- read.table(file[it],sep=",",header=TRUE) if(!any(tdata$TypeLT==1)) stop("Currently only TypeLT 1 is implemented") names(tdata) <- gsub(".","",names(tdata),fixed=TRUE) tdata <- tdata[,c("Country","Year1","Year2","TypeLT","Sex","Age","AgeInt","qx")] tdata <- tdata[tdata$TypeLT==1,] #NEW - prej sem gledala tudi AgeInt, izkaze se, da ni treba. pri q(x) bi bilo vseeno tudi, ce bi gledala TypeLT=3. tdata <- tdata[!is.na(tdata$AgeInt),] #NEW - vrzem ven zadnji interval, ki gre v neskoncnost in vsi umrejo (inf hazard) if(!missing(race))tdata$race <- rep(race[it],nrow(tdata)) data <- rbind(data,tdata) } if(length(unique(data$Country))>1)warning("The data belongs to different countries") data <- data[order(data$Year1,data$Age),] data$qx <- as.character(data$qx) options(warn = -1) data$qx[data$qx=="."] <- NA data$qx <- as.numeric(data$qx) options(warn = 0) if(missing(cut.year)){ y1 <- unique(data$Year1) y2 <- unique(data$Year2) if(any(apply(cbind(y1[-1],y2[-length(y2)]),1,diff)!=-1))warning("Data is not given for all the cut.year between the minimum and the maximum, use argument 'cut.year'") } else y1 <- cut.year if(length(y1)!=length(unique(data$Year1)))stop("Length 'cut.year' must match the number of unique values of Year1") cp <- as.Date(apply(matrix(y1,ncol=1),1,function(x){paste(x,"-01-01",sep="")})) dn2 <- as.character(y1) amax <- max(data$Age) a.fun <- function(data,amax){ mdata <- data[data$Sex==1,] wdata <- data[data$Sex==2,] men <-NULL women <- NULL k <- sum(mdata$Age==0) mind <- c(which(mdata$Age[-nrow(mdata)] != mdata$Age[-1]-1),nrow(mdata)) wind <- c(which(wdata$Age[-nrow(wdata)] != wdata$Age[-1]-1),nrow(wdata)) mst <- wst <- 1 for(it in 1:k){ qx <- mdata[mst:mind[it],]$qx lqx <- length(qx) if(lqx!=amax+1){ nmiss <- amax + 1 - lqx qx <- c(qx,rep(qx[lqx],nmiss)) } naqx <- max(which(!is.na(qx))) if(naqx!=amax+1) qx[(naqx+1):(amax+1)] <- qx[naqx] men <- cbind(men,qx) mst <- mind[it]+1 qx <- wdata[wst:wind[it],]$qx lqx <- length(qx) if(lqx!=amax+1){ nmiss <- amax + 1 - lqx qx <- c(qx,rep(qx[lqx],nmiss)) } naqx <- max(which(!is.na(qx))) if(naqx!=amax+1) qx[(naqx+1):(amax+1)] <- qx[naqx] women <- cbind(women,qx) wst <- wind[it]+1 } men<- -log(1-men)/365.241 women<- -log(1-women)/365.241 dims <- c(dim(men),2) array(c(men,women),dim=dims) } if(missing(race)){ out <- a.fun(data,amax) dims <- dim(out) attributes(out)<-list( dim=dims, dimnames=list(as.character(0:amax),as.character(y1),c("male","female")), dimid=c("age","year","sex"), factor=c(0,0,1),type=c(2,3,1), cutpoints=list((0:amax)*(365.241),cp,NULL), class="ratetable" ) } else{ race.val <- unique(race) if(length(race)!=length(file))stop("Length of 'race' must match the number of files") for(it in 1:length(race.val)){ if(it==1){ out <- a.fun(data[data$race==race.val[it],],amax) dims <- dim(out) out <- array(out,dim=c(dims,1)) } else{ out1 <- array(a.fun(data[data$race==race.val[it],],amax),dim=c(dims,1)) out <- array(c(out,out1),dim=c(dims,it)) } } attributes(out)<-list( dim=c(dims,it), dimnames=list(age=as.character(0:amax),year=as.character(y1),sex=c("male","female"),race=race.val), dimid=c("age","year","sex","race"), factor=c(0,0,1,1),type=c(2,3,1,1), cutpoints=list((0:amax)*(365.241),cp,NULL,NULL), class="ratetable" ) } attributes(out)$summary <- function (R) { x <- c(format(round(min(R[, 1])/365.241, 1)), format(round(max(R[, 1])/365.241, 1)), sum(R[, 3] == 1), sum(R[, 3] == 2)) x2 <- as.character(as.Date(c(min(R[, 2]), max(R[, 2])), origin=as.Date('1970-01-01'))) paste(" age ranges from", x[1], "to", x[2], "years\n", " male:", x[3], " female:", x[4], "\n", " date of entry from", x2[1], "to", x2[2], "\n") } out } #' Reorganize Data obtained from Human Mortality Database into a Ratetable #' Object #' #' The function assists in reorganizing the .txt files obtained from Human #' Mortality Database (http://www.mortality.org) into a ratetable object. #' #' This function works automatically with tables organised in the format #' provided by the Human Mortality Database. Download Life Tables for Males and #' Females separately from the column named 1x1 (period life tables, organized #' by date of death, yearly cutpoints for age as well as calendar year). #' #' If you wish to provide the data in the required format by yourself, note #' that the only two columns needed are calendar year (Year) and probability of #' death (qx). Death probabilities must be calculated up to age 110 (in yearly #' intervals). #' #' @param male a .txt file, containing the data on males. #' @param female a .txt file, containing the data on females. #' @return An object of class \code{ratetable}. #' @seealso \code{\link[survival:ratetable]{survival::ratetable}}, \code{\link{transrate.hld}}, #' \code{\link{joinrate}}, \code{\link{transrate}}. #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' @keywords survival #' @examples #' #' \dontrun{ #' auspop <- transrate.hmd("mltper_1x1.txt","fltper_1x1.txt") #' } #' transrate.hmd <- function(male,female){ nfiles <- 2 men <- try(read.table(male,sep="",header=TRUE),silent=TRUE) if(inherits(men, "try-error")){ men <- read.table(male,sep="",header=TRUE,skip=1)} men <- men[,c("Year","Age","qx")] y1 <- sort(unique(men$Year)) ndata <- nrow(men)/111 if(round(ndata)!=ndata)stop("Each year must contain ages from 0 to 110") men <- matrix(men$qx, ncol=ndata) men <- matrix(as.numeric(men),ncol=ndata) women <- try(read.table(female,sep="",header=TRUE),silent=TRUE) if(inherits(women, "try-error")) {women <- read.table(female,sep="",header=TRUE,skip=1)} women <- women[,"qx"] if(length(women)!=length(men))stop("Number of rows in the table must be equal for both sexes") women <- matrix(women, ncol=ndata) women <- matrix(as.numeric(women),ncol=ndata) cp <- as.Date(apply(matrix(y1, ncol = 1), 1, function(x) { paste(x, '-01-01', sep = "") })) dn2 <- as.character(y1) tfun <- function(vec){ ind <- which(vec == 1 | is.na(vec)) if(length(ind)>0)vec[min(ind):length(vec)] <- 0.999 vec } men <- apply(men,2,tfun) women <- apply(women,2,tfun) men<- -log(1-men)/365.241 women<- -log(1-women)/365.241 nr <- nrow(men)-1 dims <- c(dim(men),2) out <- array(c(men,women),dim=dims) attributes(out)<-list( dim=dims, dimnames=list(age=as.character(0:nr),year=as.character(y1),sex=c("male","female")), dimid=c("age","year","sex"), factor=c(0,0,1),type=c(2,3,1), cutpoints=list((0:nr)*(365.241),cp,NULL), class="ratetable" ) attributes(out)$summary <- function (R) { x <- c(format(round(min(R[, 1])/365.241, 1)), format(round(max(R[, 1])/365.241, 1)), sum(R[, 3] == 1), sum(R[, 3] == 2)) x2 <- as.character(as.Date(c(min(R[, 2]), max(R[, 2])), origin=as.Date('1970-01-01'))) paste(" age ranges from", x[1], "to", x[2], "years\n", " male:", x[3], " female:", x[4], "\n", " date of entry from", x2[1], "to", x2[2], "\n") } out } #' Join ratetables #' #' The function joins two or more objects organized as \code{ratetable} by #' adding a new dimension. #' #' This function joins two or more \code{ratetable} objects by adding a new #' dimension. The cutpoints of all the rate tables are compared; if merge=FALSE #' (default) only the common intervals are kept, otherwise if merge=TRUE all #' intervals are added (and hazards are extrapolated). #' If the intervals defined by the cutpoints are not of #' the same length, a warning message is displayed. Each rate table must have #' the same dimensions. #' #' @param tables a list of ratetables. If names are given, they are included as #' \code{dimnames}. #' @param dim.name the name of the added dimension. #' @param merge if FALSE (default) only the intersect of all years/ages is taken. #' If TRUE all possible years/ages are included (NOTE: in this case hazards are extrapolated #' from earlier or later years/ages). This option only works for ratetables with dimensions # in the following order: age, year, sex. #' @return An object of class \code{ratetable}. #' @seealso \code{\link[survival:ratetable]{survival::ratetable}}, \code{\link{transrate.hld}}, #' \code{\link{transrate.hmd}}, \code{\link{transrate}}. #' @references Package: Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741-1749. #' @keywords survival #' @examples #' #' #newpop <- joinrate(list(Arizona=survexp.az,Florida=survexp.fl, #' # Minnesota=survexp.mn),dim.name="state") #' joinrate <- function(tables,dim.name="country", merge=FALSE){ nfiles <- length(tables) if(is.null(names(tables))) names(tables) <- paste("D",1:nfiles,sep="") if(any(!unlist(lapply(tables,is.ratetable))))stop("Tables must be in ratetable format") if(length(attributes(tables[[1]])$dim)<3)stop("Currently implemented for ratetables with 3 or more dimensions") if(is.null(attr(tables[[1]],"dimid")))attr(tables[[1]],"dimid") <- names((attr(tables[[1]],"dimnames"))) if(merge){ # Find all possible years and ages: add.years <- sort(unique(unlist(lapply(1:length(tables), function(x) attributes(tables[[x]])$dimnames$year)))) add.ages <- as.character(sort(as.integer(unique(unlist(lapply(1:length(tables), function(x) attributes(tables[[x]])$dimnames$age)))))) # Add the extra years/ages: for(tb in 1:length(tables)){ tables[[tb]] <- ratetable_add_vals(tables[[tb]], add.years, add.ages) } } mc_length <- length(attributes(tables[[1]])$dimid) for(it in 2:nfiles){ if(is.null(attr(tables[[it]],"dimid")))attr(tables[[it]],"dimid") <- names((attr(tables[[it]],"dimnames"))) if(length(attributes(tables[[it]])$dimid)!=mc_length)stop("Each ratetable must have the same number of dimensions") mc <- match(attributes(tables[[it]])$dimid,attributes(tables[[1]])$dimid,nomatch=0) if(any(mc)==0) stop("Each ratetable must have the same number of dimensions") if(any(mc!=1:mc_length)){ atts <- attributes(tables[[it]]) tables[[it]] <- aperm(tables[[it]],mc) atts$dimid <- atts$dimid[mc] atts$dimnames <- atts$dimnames[mc] atts$cutpoints <- atts$cutpoints[mc] atts$factor <- atts$factor[mc] atts$type <- atts$type[mc] atts$dim <- atts$dim[mc] attributes(tables[[it]]) <- atts } } # Check if lists are equal: list.eq <- function(l1,l2){ n <- length(l1) rez <- rep(TRUE,n) for(it in 1:n){ if(length(l1[[it]])!=length(l2[[it]]))rez[it] <- FALSE else if(any(l1[[it]]!=l2[[it]]))rez[it] <- FALSE } rez } equal <- rep(TRUE,mc_length) for(it in 2:nfiles){ equal <- equal*list.eq(attributes(tables[[1]])$cutpoints,attributes(tables[[it]])$cutpoints) } kir <- which(!equal) newat <- attributes(tables[[1]]) # imena <- list(d1=NULL,d2=NULL,d3=NULL,d4=NULL) imena <- eval(parse(text=paste0('list(', paste0('d', 1:mc_length, '=NULL', collapse = ', '), ')'))) for(jt in kir){ listy <- NULL for(it in 1:nfiles){ listy <- c(listy,attributes(tables[[it]])$cutpoints[[jt]]) } imena[[jt]] <- names(table(listy)[table(listy) == nfiles]) # if(inherits(attributes(tables[[it]])$cutpoints[[jt]], 'date')){ # imena[[jt]] <- as.date(as.integer(imena[[jt]])) # } if(!length(imena[[jt]]))stop(paste("There are no common cutpoints for dimension", attributes(tables[[1]])$dimid[jt])) } # Merging: for(it in 1:nfiles){ keep <- lapply(dim(tables[[it]]),function(x)1:x) for(jt in kir){ meci <- which(match(attributes(tables[[it]])$cutpoints[[jt]],imena[[jt]],nomatch=0)!=0) if(it==1){ newat$dimnames[[jt]] <- attributes(tables[[it]])$dimnames[[jt]][meci] newat$dim[[jt]] <- length(imena[[jt]]) newat$cutpoints[[jt]] <- attributes(tables[[it]])$cutpoints[[jt]][meci] } if(length(meci)>1){if(max(diff(meci)!=1))warning(paste("The cutpoints for ",attributes(tables[[1]])$dimid[jt] ," are not equally spaced",sep=""))} keep[[jt]] <- meci } if(mc_length==3){ tables[[it]] <- tables[[it]][keep[[1]],keep[[2]],keep[[3]]] } else if(mc_length==4){ tables[[it]] <- tables[[it]][keep[[1]],keep[[2]],keep[[3]],keep[[4]]] } else if(mc_length==5){ tables[[it]] <- tables[[it]][keep[[1]],keep[[2]],keep[[3]],keep[[4]],keep[[5]]] } else if(mc_length==6){ tables[[it]] <- tables[[it]][keep[[1]],keep[[2]],keep[[3]],keep[[4]],keep[[5]],keep[[6]]] } } # Finish final object: dims <- newat$dim out <- array(tables[[1]],dim=c(dims,1)) for(it in 2:nfiles){ out1 <- array(tables[[it]],dim=c(dims,1)) out <- array(c(out,out1),dim=c(dims,it)) } mc <- 1:(mc_length+1) if(any(newat$factor>1)){ wh <- which(newat$factor>1) mc <- c(mc[-wh],wh) out <- aperm(out,mc) } newat$dim <- c(dims,nfiles)[mc] newat$dimid <- c(newat$dimid,dim.name)[mc] if(mc_length==3){ newat$cutpoints <- list(newat$cutpoints[[1]],newat$cutpoints[[2]],newat$cutpoints[[3]],NULL)[mc] } else if(mc_length==4){ newat$cutpoints <- list(newat$cutpoints[[1]],newat$cutpoints[[2]],newat$cutpoints[[3]],newat$cutpoints[[4]],NULL)[mc] } else if(mc_length==5){ newat$cutpoints <- list(newat$cutpoints[[1]],newat$cutpoints[[2]],newat$cutpoints[[3]],newat$cutpoints[[4]],newat$cutpoints[[5]],NULL)[mc] } else if(mc_length==6){ newat$cutpoints <- list(newat$cutpoints[[1]],newat$cutpoints[[2]],newat$cutpoints[[3]],newat$cutpoints[[4]],newat$cutpoints[[5]],newat$cutpoints[[6]],NULL)[mc] } newat$factor <- c(newat$factor,1)[mc] newat$type <- c(newat$type,1)[mc] if(mc_length==3){ newat$dimnames <- list(newat$dimnames[[1]],newat$dimnames[[2]],newat$dimnames[[3]],names(tables))[mc] } else if(mc_length==4){ newat$dimnames <- list(newat$dimnames[[1]],newat$dimnames[[2]],newat$dimnames[[3]],newat$dimnames[[4]],names(tables))[mc] } else if(mc_length==5){ newat$dimnames <- list(newat$dimnames[[1]],newat$dimnames[[2]],newat$dimnames[[3]],newat$dimnames[[4]],newat$dimnames[[5]],names(tables))[mc] } else if(mc_length==6){ newat$dimnames <- list(newat$dimnames[[1]],newat$dimnames[[2]],newat$dimnames[[3]],newat$dimnames[[4]],newat$dimnames[[5]],newat$dimnames[[6]],names(tables))[mc] } names(newat$dimnames) <- newat$dimid attributes(out) <- newat out } # joinrate <- function(tables,dim.name="country", merge=FALSE){ # nfiles <- length(tables) # if(is.null(names(tables))) names(tables) <- paste("D",1:nfiles,sep="") # if(any(!unlist(lapply(tables,is.ratetable))))stop("Tables must be in ratetable format") # if(length(attributes(tables[[1]])$dim)!=3)stop("Currently implemented only for ratetables with 3 dimensions") # # if(is.null(attr(tables[[1]],"dimid")))attr(tables[[1]],"dimid") <- names((attr(tables[[1]],"dimnames"))) # # if(merge){ # # Find all possible years and ages: # add.years <- sort(unique(unlist(lapply(1:length(tables), # function(x) attributes(tables[[x]])$dimnames$year)))) # add.ages <- as.character(sort(as.integer(unique(unlist(lapply(1:length(tables), # function(x) attributes(tables[[x]])$dimnames$age)))))) # # # Add the extra years/ages: # for(tb in 1:length(tables)){ # tables[[tb]] <- ratetable_add_vals(tables[[tb]], add.years, add.ages) # } # } # # for(it in 2:nfiles){ # if(is.null(attr(tables[[it]],"dimid")))attr(tables[[it]],"dimid") <- names((attr(tables[[it]],"dimnames"))) # if(length(attributes(tables[[it]])$dimid)!=3)stop("Each ratetable must have 3 dimensions: age, year and sex") # mc <- match(attributes(tables[[it]])$dimid,attributes(tables[[1]])$dimid,nomatch=0) # if(any(mc)==0) stop("Each ratetable must have 3 dimensions: age, year and sex") # if(any(mc!=1:3)){ # atts <- attributes(tables[[it]]) # tables[[it]] <- aperm(tables[[it]],mc) # atts$dimid <- atts$dimid[mc] # atts$dimnames <- atts$dimnames[mc] # atts$cutpoints <- atts$cutpoints[mc] # atts$factor <- atts$factor[mc] # atts$type <- atts$type[mc] # atts$dim <- atts$dim[mc] # attributes(tables[[it]]) <- atts # } # } # # # Check if lists are equal: # list.eq <- function(l1,l2){ # n <- length(l1) # rez <- rep(TRUE,n) # for(it in 1:n){ # if(length(l1[[it]])!=length(l2[[it]]))rez[it] <- FALSE # else if(any(l1[[it]]!=l2[[it]]))rez[it] <- FALSE # } # rez # } # # # equal <- rep(TRUE,3) # for(it in 2:nfiles){ # equal <- equal*list.eq(attributes(tables[[1]])$cutpoints,attributes(tables[[it]])$cutpoints) # } # # # kir <- which(!equal) # # newat <- attributes(tables[[1]]) # imena <- list(d1=NULL,d2=NULL,d3=NULL) # # for(jt in kir){ # listy <- NULL # for(it in 1:nfiles){ # listy <- c(listy,attributes(tables[[it]])$cutpoints[[jt]]) # } # # imena[[jt]] <- names(table(listy)[table(listy) == nfiles]) # # if(inherits(attributes(tables[[it]])$cutpoints[[jt]], 'date')){ # imena[[jt]] <- as.date(as.integer(imena[[jt]])) # } # # if(!length(imena[[jt]]))stop(paste("There are no common cutpoints for dimension", attributes(tables[[1]])$dimid[jt])) # } # # # Merging: # for(it in 1:nfiles){ # keep <- lapply(dim(tables[[it]]),function(x)1:x) # for(jt in kir){ # meci <- which(match(attributes(tables[[it]])$cutpoints[[jt]],imena[[jt]],nomatch=0)!=0) # # if(it==1){ # newat$dimnames[[jt]] <- attributes(tables[[it]])$dimnames[[jt]][meci] # newat$dim[[jt]] <- length(imena[[jt]]) # newat$cutpoints[[jt]] <- attributes(tables[[it]])$cutpoints[[jt]][meci] # } # if(length(meci)>1){if(max(diff(meci)!=1))warning(paste("The cutpoints for ",attributes(tables[[1]])$dimid[jt] ," are not equally spaced",sep=""))} # keep[[jt]] <- meci # } # tables[[it]] <- tables[[it]][keep[[1]],keep[[2]],keep[[3]]] # } # # # Finish final object: # dims <- newat$dim # out <- array(tables[[1]],dim=c(dims,1)) # for(it in 2:nfiles){ # out1 <- array(tables[[it]],dim=c(dims,1)) # out <- array(c(out,out1),dim=c(dims,it)) # } # mc <- 1:4 # if(any(newat$factor>1)){ # wh <- which(newat$factor>1) # mc <- c(mc[-wh],wh) # out <- aperm(out,mc) # } # newat$dim <- c(dims,nfiles)[mc] # newat$dimid <- c(newat$dimid,dim.name)[mc] # newat$cutpoints <- list(newat$cutpoints[[1]],newat$cutpoints[[2]],newat$cutpoints[[3]],NULL)[mc] # newat$factor <- c(newat$factor,1)[mc] # newat$type <- c(newat$type,1)[mc] # newat$dimnames <- list(newat$dimnames[[1]],newat$dimnames[[2]],newat$dimnames[[3]],names(tables))[mc] # names(newat$dimnames) <- newat$dimid # attributes(out) <- newat # out # } mlfit <- function (b, p, x, offset, d, h, ds, y, maxiter, tol) { for (nit in 1:maxiter) { b0 <- b fd <- matrix(0, p, 1) sd <- matrix(0, p, p) if (nit == 1) { ebx <- exp(x %*% b) * exp(offset) l0 <- sum(d * log(h + ebx) - ds - y * ebx) } for (it in 1:p) { fd[it, 1] <- sum((d/(h + ebx) - y) * x[, it] * ebx) for (jt in 1:p) sd[it, jt] = sum((d/(h + ebx) - d * ebx/(h + ebx)^2 - y) * x[, it] * x[, jt] * ebx) } b <- b - solve(sd) %*% fd ebx <- exp(x %*% b) * exp(offset) l <- sum(d * log(h + ebx) - ds - y * ebx) bd <- abs(b - b0) if (max(bd) < tol) break() } out <- list(b = b, sd = sd, nit = nit, loglik = c(l0, l)) out } print.rs.br <- function (x, digits = max(options()$digits - 4, 3), ...) { invisible(print(x$table, digits = digits)) if (x$rho != 0) invisible(cat("Weighted Brownian bridge with rho=", x$rho, "\n")) } print.rsadd <- function (x, digits = max(3, getOption("digits") - 3), ...) { cat("\nCall: ", paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "", "\n") if (length(coef(x))) { cat("Coefficients") cat(":\n") print.default(format(x$coefficients, digits = digits), print.gap = 2, quote = FALSE) } else cat("No coefficients\n\n") if(x$method=="EM") cat("\n", "Expected number of disease specific deaths: ",format(round(sum(x$Nie),2))," = ",format(round(100*sum(x$Nie)/sum(x$data$stat),1)),"% \n" ,sep="") if(x$method=="EM"|x$method=="max.lik"){ chi <- 2*max((x$loglik[2]-x$loglik[1]),0) if(x$method=="EM")df <- length(x$coef) else df <- length(x$coef)-length(x$int)+1 if(df>0){ p.val <- 1- pchisq(chi,df) if(x$method=="max.lik")cat("\n") cat("Likelihood ratio test=",format(round(chi,2)),", on ",df," df, p=",format(p.val),"\n",sep="") } else cat("\n") } cat("n=",nrow(x$data),sep="") if(length(x$na.action))cat(" (",length(x$na.action)," observations deleted due to missing)",sep="") cat("\n") if (length(x$warnme)) cat("\n", x$warnme, "\n\n") else cat("\n") invisible(x) } summary.rsadd <- function (object, correlation = FALSE, symbolic.cor = FALSE, ...) { if (inherits(object, "glm")) { p <- object$rank if (p > 0) { p1 <- 1:p Qr <- object$qr aliased <- is.na(coef(object)) coef.p <- object$coefficients[Qr$pivot[p1]] covmat <- chol2inv(Qr$qr[p1, p1, drop = FALSE]) dimnames(covmat) <- list(names(coef.p), names(coef.p)) var.cf <- diag(covmat) s.err <- sqrt(var.cf) tvalue <- coef.p/s.err dn <- c("Estimate", "Std. Error") pvalue <- 2 * pnorm(-abs(tvalue)) coef.table <- cbind(coef.p, s.err, tvalue, pvalue) dimnames(coef.table) <- list(names(coef.p), c(dn, "z value", "Pr(>|z|)")) df.f <- NCOL(Qr$qr) } else { coef.table <- matrix(, 0, 4) dimnames(coef.table) <- list(NULL, c("Estimate", "Std. Error", "t value", "Pr(>|t|)")) covmat.unscaled <- covmat <- matrix(, 0, 0) aliased <- is.na(coef(object)) df.f <- length(aliased) } ans <- c(object[c("call", "terms", "family", "iter", "warnme")], list(coefficients = coef.table, var = covmat, aliased = aliased)) if (correlation && p > 0) { dd <- s.err ans$correlation <- covmat/outer(dd, dd) ans$symbolic.cor <- symbolic.cor } class(ans) <- "summary.rsadd" } else if (inherits(object, "rsadd")) { aliased <- is.na(coef(object)) coef.p <- object$coef var.cf <- diag(object$var) s.err <- sqrt(var.cf) tvalue <- coef.p/s.err dn <- c("Estimate", "Std. Error") pvalue <- 2 * pnorm(-abs(tvalue)) coef.table <- cbind(coef.p, s.err, tvalue, pvalue) dimnames(coef.table) <- list(names(coef.p), c(dn, "z value", "Pr(>|z|)")) ans <- c(object[c("call", "terms", "iter", "var")], list(coefficients = coef.table, aliased = aliased)) if (correlation && sum(aliased) != length(aliased)) { dd <- s.err ans$correlation <- object$var/outer(dd, dd) ans$symbolic.cor <- symbolic.cor } class(ans) <- "summary.rsadd" } else ans <- object return(ans) } print.summary.rsadd <- function (x, digits = max(3, getOption("digits") - 3), symbolic.cor = x$symbolic.cor, signif.stars = getOption("show.signif.stars"), ...) { cat("\nCall:\n") cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n\n", sep = "") if (length(x$aliased) == 0) { cat("\nNo Coefficients\n") } else { cat("\nCoefficients:\n") coefs <- x$coefficients if (!is.null(aliased <- x$aliased) && any(aliased)) { cn <- names(aliased) coefs <- matrix(NA, length(aliased), 4, dimnames = list(cn, colnames(coefs))) coefs[!aliased, ] <- x$coefficients } printCoefmat(coefs, digits = digits, signif.stars = signif.stars, na.print = "NA", ...) } if (length(x$warnme)) cat("\n", x$warnme, "\n") correl <- x$correlation if (!is.null(correl)) { p <- NCOL(correl) if (p > 1) { cat("\nCorrelation of Coefficients:\n") if (is.logical(symbolic.cor) && symbolic.cor) { print(symnum(correl, abbr.colnames = NULL)) } else { correl <- format(round(correl, 2), nsmall = 2, digits = digits) correl[!lower.tri(correl)] <- "" print(correl[-1, -p, drop = FALSE], quote = FALSE) } } } cat("\n") invisible(x) } #' Excess hazard function smoothing #' #' An Epanechnikov kernel function based smoother for smoothing the baseline #' excess hazard calculated by the \code{rsadd} function with the \code{EM} #' method. #' #' The function performs Epanechnikov kernel smoothing. The follow up time is #' divided (according to percentiles of event times) into several intervals #' (number of intervals defined by \code{n.bwin}) in which the width is #' calculated as a factor of the maximum span between event times. Boundary #' effects are also taken into account on both sides. #' #' @param fit Fit from the additive relative survival model using the \code{EM} #' method. #' @param bwin The relative width of the smoothing window (default is 1). #' @param times The times at which the smoother is to be evaluated. If missing, #' it is evaluated at all event times. #' @param n.bwin Number of times that the window width may change. #' @param left If \code{FALSE} (default) smoothing is performed symmetrically, #' if \code{TRUE} only leftside neighbours are considered. #' @return A list with two components: \item{lambda}{the smoothed excess #' baseline hazard function} \item{times}{the times at which the smoothed #' excess baseline hazard is evaluated.} #' @seealso \code{\link{rsadd}}, #' @references Package. Pohar M., Stare J. (2006) "Relative survival analysis #' in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 #' #' Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival #' analysis relatively easy." Computers in biology and medicine, \bold{37}: #' 1741--1749. #' #' EM algorithm: Pohar Perme M., Henderson R., Stare, J. (2009) "An approach to #' estimation in relative survival regression." Biostatistics, \bold{10}: #' 136--146. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #fit an additive model with the EM method #' fit <- rsadd(Surv(time,cens)~sex+age,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,int=5,method="EM") #' sm <- epa(fit) #' plot(sm$times,sm$lambda) #' epa <- function(fit,bwin,times,n.bwin=16,left=FALSE){ #bwin ... width of the window, relative to the default (1) #fit ... EM fit #times... times at which the smoothed plot is calculated #n.bwin ... number of different windows #left ... only predictable smoothing utd <- fit$times if(missing(times))times <- seq(1,max(utd),length=100) if(max(times)>max(utd)){ warning("Cannot extrapolate beyond max event time") times <- pmax(times,max(utd)) } nutd <- length(utd) nt4 <- c(1,ceiling(nutd*(1:n.bwin)/n.bwin)) if(missing(bwin))bwin <- rep(length(fit$times)/100,n.bwin) else bwin <- rep(bwin*length(fit$times)/100,n.bwin) for(it in 1:n.bwin){ bwin[it] <- bwin[it]*max(diff(utd[nt4[it]:nt4[it+1]])) } while(utd[nt4[2]]tvs[nt4[it]] & t<=tvs[nt4[it + 1]]] if(length(cajti)){ q <- min( cajti/b[it],1,(Rb-cajti)/b[it]) if(q<1 & length(cajti)>1){ jc <- 1 while(jc <=length(cajti)){ qd <- pmin( cajti[jc:length(cajti)]/b[it],1,(Rb-cajti[jc:length(cajti)])/b[it]) q <- qd[1] if(q==1){ casi <- cajti[jc:length(cajti)][qd==1] q <- 1 jc <- sum(qd==1)+jc } else{ casi <- cajti[jc] jc <- jc+1 } kmat1 <- outer(casi, tv, "-")/b[it] #z - to je ok if(q<1){ if(casi>b[it]) kmt1 <- -kmat1 vr <- kt(q,kmat1)*(kmat1>=-1 & kmat1 <= q) } else vr <- pmax((1 - kmat1^2) * .75,0) kmat <- rbind(kmat, vr/b[it]) totcajti <- c(totcajti,casi) } } else{ kmat1 <- outer(cajti, tv, "-")/b[it] #z - to je ok q <- min( cajti/b[it],1) if(q<1)vr <- kt(q,kmat1)*(kmat1>=-1 & kmat1 <= q) else vr <- pmax((1 - kmat1^2) * .75,0) kmat <- rbind(kmat, vr/b[it]) totcajti <- c(totcajti,cajti) }#else }#if }#for kmat } kern <- function (times,td, b, nt4) { n <- length(td) ttemp <- td[td >= b[1]] ntemp <- length(ttemp) if (ntemp == n) nt4 <- c(0, nt4[-1]) td <- c(0,td) nt4 <- c(1,nt4+1) b <- c(b[1],b) krn <- Kern(times, td, b, max(td), nt4) krn } exp_prep <- function (x, y,ratetable,status,times,fast=FALSE,ys,prec,cmp=F,netweiDM=FALSE) { #function that prepares the data for C function call #x= matrix of demographic covariates - each individual has one line #y= follow-up time for each individual (same length as nrow(x)!) #ratetable= rate table used for calculation #status= status for each individual (same length as nrow(x)!), not needed if we only need Spi, status needed for rs.surv #times= times at which we wish to evaluate the quantities, not needed if we only need Spi, times needed for rs.surv #fast=for mpp method only #netweiDM=should new netwei script be used x <- as.matrix(x) if (ncol(x) != length(dim(ratetable))) stop("x matrix does not match the rate table") atts <- attributes(ratetable) cuts <- atts$cutpoints if (is.null(atts$type)) { rfac <- atts$factor us.special <- (rfac > 1) } else { rfac <- 1 * (atts$type == 1) us.special <- (atts$type == 4) } if (length(rfac) != ncol(x)) stop("Wrong length for rfac") if (any(us.special)) { if (sum(us.special) > 1) stop("Two columns marked for special handling as a US rate table") cols <- match(c("age", "year"), atts$dimid) if (any(is.na(cols))) stop("Ratetable does not have expected shape") if (exists("as.Date")) { bdate <- as.Date("1960/1/1") + (x[, cols[2]] - x[, cols[1]]) byear <- format(bdate, "%Y") offset <- as.numeric(bdate - as.Date(paste(byear, "01/01", sep = "/"))) } else stop("Can't find an appropriate date class\n") # Prej je bilo tole: # else if (exists("date.mdy")) { # bdate <- as.date(x[, cols[2]] - x[, cols[1]]) # byear <- date.mdy(bdate)$year # offset <- bdate - mdy.date(1, 1, byear) # } x[, cols[2]] <- x[, cols[2]] - offset if (any(rfac > 1)) { temp <- which(us.special) nyear <- length(cuts[[temp]]) nint <- rfac[temp] cuts[[temp]] <- round(approx(nint * (1:nyear), cuts[[temp]], nint:(nint * nyear))$y - 1e-04) } } if(!missing(status)){ #the function was called from rs.surv if(length(status)!=nrow(x)) stop("Wrong length for status") if(missing(times)) times <- sort(unique(y)) if (any(times < 0)) stop("Negative time point requested") ntime <- length(times) if(missing(ys)) ys <- rep(0,length(y)) # times2 <- times # times2[1] <- preci # It may be an integer...check and make it numeric. Otherwise problems in C functions: if(is.integer(x[1,1])){ x <- apply(x, 2, as.numeric) } if(cmp) temp <- .Call("cmpfast", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(fast&!missing(prec)) temp <- .Call("netfastpinter2", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,prec,PACKAGE="relsurv") else if(fast&missing(prec)) temp <- .Call("netfastpinter", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(netweiDM==TRUE) temp <- .Call("netweiDM", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else temp <- .Call("netwei", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, as.integer(status), times,PACKAGE="relsurv") } else{ #only expected survival at time y is needed for each individual if(length(y)==1)y <- rep(y,nrow(x)) if(length(y)!=nrow(x)) stop("Wrong length for status") temp <- .Call("expc", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y,PACKAGE="relsurv") temp <- temp$surv } temp } #' Compute a Relative Survival Curve #' #' Computes an estimate of the relative survival curve using the Ederer I, #' Ederer II method, Pohar-Perme method or the Hakulinen method #' #' NOTE: The follow-up time must be specified in days. The \code{ratetable} #' being used may have different variable names and formats than the user's #' data set, this is dealt with by the \code{rmap} argument. For example, if #' age is in years in the data set but in days in the \code{ratetable} object, #' age=age*365.241 should be used. The calendar year can be in any date format #' (Date and POSIXt are allowed), the date formats in the #' \code{ratetable} and in the data may differ. #' #' The potential censoring times needed for the calculation of the expected #' survival by the Hakulinen method are calculated automatically. The times of #' censoring are left as they are, the times of events are replaced with #' \code{fin.date - year}. #' #' The calculation of the Pohar-Perme estimate is more time consuming since #' more data are needed from the population tables. The old version of the #' function, now named \code{rs.survo} can be used as a faster version for the #' Hakulinen and Ederer II estimate. #' #' Numerical integration is required for Pohar-Perme estimate. The integration #' precision is set with argument \code{precision}, which defaults to daily #' intervals, a default that should give enough precision for any practical #' purpose. #' #' Note that even though the estimate is always calculated using numerical #' integration, only the values at event and censoring times are reported. #' Hence, the function \code{plot} draws a step function in between and the #' function \code{summary} reports the value at the last event or censoring #' time before the specified time. If the output of the estimated values at #' other points is required, this should be specified with argument #' \code{add.times}. #' #' Standardized net survival can be also calculated: #' #' \eqn{SNS (t) = \sum_{j} w_j {NS}_j (t)} #' #' where \eqn{NS_j} is the net survival in the j-th group, \eqn{w_j} #' is the weight for the j-th group and \eqn{SNS} is the standardized net survival. #' \eqn{SNS} can be calculated by using the \code{weight.table} and \code{weight.names} arguments. The function #' also returns the corresponding standard error and confidence interval. #' #' @param formula a formula object, with the response as a \code{Surv} object #' on the left of a \code{~} operator, and, if desired, terms separated by the #' \code{+} operator on the right. If no strata are used, \code{~1} should be #' specified. #' #' NOTE: The follow-up time must be in days. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param na.action a missing-data filter function, applied to the model.frame, #' after any subset argument has been used. Default is #' \code{options()$na.action}. #' @param fin.date the date of the study ending, used for calculating the #' potential follow-up times in the Hakulinen method. If missing, it is #' calculated as \code{max(year+time)}. #' @param method the method for calculating the relative survival. The options #' are \code{pohar-perme}(default), \code{ederer1}, \code{ederer2} and #' \code{hakulinen}. #' @param conf.type one of \code{plain}, \code{log} (the default), or #' \code{log-log}. The first option causes the standard intervals curve +- k #' *se(curve), where k is determined from conf.int. The log option calculates #' intervals based on the cumulative hazard or log(survival). The last option #' bases intervals on the log hazard or log(-log(survival)). #' @param conf.int the level for a two-sided confidence interval on the #' survival curve(s). Default is 0.95. #' @param type defines how survival estimates are to be calculated given the #' hazards. The default (\code{kaplan-meier}) calculates the product integral, #' whereas the option \code{fleming-harrington} exponentiates the negative #' cumulative hazard. Analogous to the usage in \code{survfit}. #' @param add.times specific times at which the curve should be evaluated. #' @param precision Precision for numerical integration. Default is 1, which #' means that daily intervals are taken, the value may be decreased to get a #' higher precision or increased to achieve a faster calculation. The #' calculation intervals always include at least all times of event and #' censoring as border points. #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details #' below. #' @param weight.table Default is NULL. If defined it is used for calculating #' standardized net survival. Supply a data.frame #' that contains the weights and group names for calculating the standardized net survival. #' The group column also has to be included in the data argument. #' For the theory see the details below. #' @param weight.names Default is NULL. If defined it is used for calculating #' standardized net survival. Supply a character vector of length two with the #' names of the group and weight columns in \code{weight.table}. #' @return a \code{survfit} object; see the help on \code{survfit.object} for #' details. The \code{survfit} methods are used for \code{print}, #' \code{summary}, \code{plot}, \code{lines}, and \code{points}. #' @seealso \code{survfit}, \code{survexp} #' @references Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric #' Relative Survival Analysis with the R Package relsurv". Journal of #' Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" Theory: #' Pohar Perme, M., Esteve, J., Rachet, B. (2016) "Analysing Population-Based #' Cancer Survival - Settling the Controversies." BMC Cancer, 16 (933), 1-8. #' doi:10.1186/s12885-016-2967-9. Theory: Pohar Perme, M., Stare, J., Esteve, #' J. (2012) "On Estimation in Relative Survival", Biometrics, 68(1), 113-120. #' doi:10.1111/j.1541-0420.2011.01640.x. #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' #calculate the relative survival curve #' #note that the variable year must be given in a date format and that #' #age must be multiplied by 365.241 in order to be expressed in days. #' rs.surv(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata) #' #' # SNS: #' wei <- data.frame(agegr=c('<54', '54-61', '62-70', '71-95'), #' weight=c(0.2, 0.2, 0.3, 0.3)) #' rs.surv(Surv(time,cens)~1, rmap=list(age=age*365.241), ratetable=slopop, data=rdata, #' weight.table=wei, weight.names = c('agegr', 'weight')) #' rs.surv <- function(formula = formula(data), data = parent.frame(),ratetable = relsurv::slopop, na.action, fin.date, method = "pohar-perme", conf.type = "log", conf.int = 0.95,type="kaplan-meier",add.times,precision=1,rmap, weight.table=NULL, weight.names=NULL){ # SNS part: if(!is.null(weight.table) & (!is.numeric(weight.table))){ call <- match.call() # MAKE ALL CHECKS: if(!(inherits(weight.table, 'data.frame') # & all(colnames(weight.table) %in% c('weight', 'group')) # & ncol(weight.table) == 2 )){ stop("In the argument weight.table you should supply a data.frame.") } if(!(inherits(weight.names, 'character'))){ stop("In the argument weight.names you should supply a character vector of length 2 containing the names of the group and weight columns in weight.table.") } if(!all(weight.names %in% colnames(weight.table))){ stop('The table in weight.table does not contain the columns given in weight.names.') } if(!(weight.names[1] %in% colnames(data))){ stop('The data does not contain the grouping column (first value) given in weight.names.') } group_val <- weight.table[,weight.names[1]] weight_val <- weight.table[,weight.names[2]] if(!all(group_val %in% unique(data[,weight.names[1]]))){ stop("Not all weight categories from weight.table are present in the data.") } if(!all(unique(data[,weight.names[1]]) %in% group_val)){ stop("Not all weight categories from the data are present in weight.table.") } if(abs(sum(weight_val) - 1) > 1e-16){ # weight.table$weight <- weight.table$weight/sum(weight.table$weight) stop('The sum of the weights in the weight.table argument is not equal to 1.') } # Find groups for SNS: groups_u <- unique(group_val) groups_l <- length(groups_u) # Fix rmap: if (!missing(rmap)) { rmap <- substitute(rmap) } # Get full model: mod0 <- rs.surv(formula, data, ratetable, na.action, fin.date, method, conf.type, conf.int, type, add.times, precision=1, rmap, weight.table=-999) # add weights arg so that it is detected later for rmap # Prepare object for output: out <- mod0 # Save separate models: mod_l <- list() # Save maximum follow-up times among groups: if('strata' %in% names(mod0)){ max.times <- data.frame(matrix(NA, nrow=length(groups_u), ncol=length(mod0$strata))) } else{ max.times <- data.frame(X1=rep(NA, length(groups_u))) } # Find max times: for(group in 1:length(groups_u)){ data_tmp <- data[data[,weight.names[1]]==groups_u[group],] mod_tmp <- rs.surv(formula, data_tmp, ratetable, na.action, fin.date, method, conf.type, conf.int, type, add.times, precision=1, rmap, weight.table=-999) # add weights arg so that it is detected later for rmap mod_tmp <- summary(mod_tmp, times=sort(unique(mod0$time))) mod_l[[group]] <- mod_tmp if('strata' %in% names(mod0)){ tajms_groupby <- aggregate(time~strata, data=data.frame(time=mod_tmp$time, strata=mod_tmp$strata), FUN = \(x) max(x)) max.times[group,] <- tajms_groupby$time } else{ max.times[group,] <- mod_tmp$time[length(mod_tmp$time)] } } # Find minimum among maximum follow-up times: find.max.time <- sapply(max.times, min) # Define data.frame: if('strata' %in% names(mod0)){ find.max.time.df <- data.frame(final.time=find.max.time, strata=names(mod0$strata)) } else{ find.max.time.df <- data.frame(final.time=find.max.time) } # Find true length: if('strata' %in% names(mod0)){ df.length <- data.frame(time=mod0$time, strata=rep(names(mod0$strata), mod0$strata)) df.length <- merge(x=df.length, y=find.max.time.df, by='strata', all.x = TRUE) } else{ df.length <- data.frame(time=mod0$time) df.length$final.time <- find.max.time.df$final.time } df.length <- df.length[df.length$time <= df.length$final.time,] # subset(df.length, time<=final.time) # Merge data sets: for(group in 1:length(groups_u)){ mod_tmp <- mod_l[[group]] # Prepare data set for this group: if('strata' %in% names(mod0)){ df_g <- data.frame(time=mod_tmp$time, surv=mod_tmp$surv, std.err=mod_tmp$std.err, strata=mod_tmp$strata) df_g <- merge(x=df_g, y=find.max.time.df, by='strata', all.x = TRUE) } else{ df_g <- data.frame(time=mod_tmp$time, surv=mod_tmp$surv, std.err=mod_tmp$std.err) df_g$final.time <- find.max.time.df$final.time } df_g <- df_g[df_g$time <= df_g$final.time,] # subset(df_g, time<=final.time) # Take only relevant values: if('strata' %in% names(mod0)){ df_g$st <- paste0(df_g$strata, df_g$time) df.length$st <- paste0(df.length$strata, df.length$time) df_g <- df_g[df_g$st %in% df.length$st,] } else{ df_g <- df_g[df_g$time %in% df.length$time,] } if(group == 1){ # Define objects: srvs <- matrix(NA, nrow=nrow(df.length), ncol=length(groups_u)) std.errs <- matrix(NA, nrow=nrow(df.length), ncol=length(groups_u)) # Save values: srvs[,group] <- df_g$surv*weight_val[group_val == groups_u[group]] std.errs[,group] <- df_g$std.err^2*weight_val[group_val == groups_u[group]]^2 # mod_tmp$surv[whi]^2* } else{ # Save values: srvs[,group] <- df_g$surv*weight_val[group_val == groups_u[group]] std.errs[,group] <- df_g$std.err^2*weight_val[group_val == groups_u[group]]^2 # mod_tmp$surv[whi]^2* } } # Calculate the survival and std.err (this is sd(log(SNS))): out$surv <- rowSums(srvs) out$std.err <- sqrt(rowSums(std.errs)) / out$surv # Find which will stay in n.risk, n.event, n.censor: wh.stay <- which(out$time %in% df.length$time) # Take the correct times: out$time <- df.length$time # Calculate CI: se.fac <- sqrt(qchisq(conf.int, 1)) #factor needed for confidence interval if (conf.type == "plain") { out$lower <- as.vector(out$surv - out$std.err * se.fac * #surv + fac*se out$surv) out$upper <- as.vector(out$surv + out$std.err * se.fac * out$surv) } else if (conf.type == "log") { #on log scale and back out$lower <- exp(as.vector(log(out$surv) - out$std.err * se.fac)) out$upper <- exp(as.vector(log(out$surv) + out$std.err * se.fac)) } else if (conf.type == "log-log") { #on log-log scale and back out$lower <- exp(-exp(as.vector(log(-log(out$surv)) - out$std.err * se.fac/log(out$surv)))) out$upper <- exp(-exp(as.vector(log(-log(out$surv)) + out$std.err * se.fac/log(out$surv)))) } out$call <- call if('strata' %in% names(mod0)){ out$strata <- table(df.length$strata) } # Remove unneeded objects: out$n.risk <- out$n.risk[wh.stay] out$n.event <- out$n.event[wh.stay] out$n.censor <- out$n.censor[wh.stay] return(out) # Regular part: } else{ call <- match.call() if (!missing(rmap)) { if(is.null(weight.table)){ rmap <- substitute(rmap) } else{ if(weight.table != -999){ rmap <- substitute(rmap) } } } rform <- rformulate(formula,data, ratetable, na.action,rmap) data <- rform$data #the data set type <- match.arg(type, c("kaplan-meier", "fleming-harrington")) #method of hazard -> survival scale transformation type <- match(type, c("kaplan-meier", "fleming-harrington")) method <- match.arg(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) #method of relative surv. curve estimation method <- match(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) conf.type <- match.arg(conf.type,c("plain","log","log-log")) #conf. interval type if (method == 3) { #need potential follow-up time for Hak. method R <- rform$R coll <- match("year", attributes(ratetable)$dimid) year <- R[, coll] #calendar year in the data if (missing(fin.date)) fin.date <- max(rform$Y + year) #final date for everybody set to the last day observed Y2 <- rform$Y #change into potential follow-up time if (length(fin.date) == 1) #if final date equal for everyone Y2[rform$status == 1] <- fin.date - year[rform$status == 1]#set pot.time for those that died (equal to censoring time for others) else if (length(fin.date) == nrow(rform$R)) Y2[rform$status == 1] <- fin.date[rform$status == 1] - year[rform$status == 1] else stop("fin.date must be either one value or a vector of the same length as the data") status2 <- rep(0, nrow(rform$X)) #stat2=0 for everyone } p <- rform$m #number of covariates # strata - use same approach as in survival::survfit.formula: indx <- match(c("formula", "data"), names(call), nomatch = 0) temp2 <- call[c(1, indx)] temp2[[1L]] <- quote(stats::model.frame) mf <- eval.parent(temp2) n <- nrow(mf) Terms2 <- terms(formula, c("strata", "cluster")) ll <- attr(Terms2, "term.labels") # Check if ratetable in linear predictor, if yes remove it: if(any(grepl(pattern = 'ratetable', x = ll))){ ll <- ll[!grepl(pattern = 'ratetable', x = ll)] } if (length(ll) == 0) data$Xs <- factor(rep(1, n)) else data$Xs <- strata(mf[ll]) # OLD # if (p > 0) #if covariates # data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make strata according to covariates # else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 se.fac <- sqrt(qchisq(conf.int, 1)) #factor needed for confidence interval out <- NULL out$n <- table(data$Xs) #table of strata out$time <- out$n.risk <- out$n.event <- out$n.censor <- out$surv <- out$std.err <- out$strata <- NULL #out$index <- out$strata0 <- NULL # out$index = indices of the original times from the data among the times used for calculations # out$strata0 = the same as out$strata but only on the original times from the data for (kt in 1:length(out$n)) { #for each stratum inx <- which(data$Xs == names(out$n)[kt]) #individuals within this stratum tis <- sort(unique(rform$Y[inx])) #unique times #if (method == 1 & all.times == TRUE) tis <- sort(union(rform$Y[inx],as.numeric(1:max(floor(rform$Y[inx]))))) #1-day long intervals used - to take into the account the continuity of the pop. part if (method == 1 & !missing(add.times)){ #tis <- sort(union(rform$Y[inx],as.numeric(1:max(floor(rform$Y[inx]))))) #1-day long intervals used - to take into the account the continuity of the pop. part add.times <- pmin(as.numeric(add.times),max(rform$Y[inx])) tis <- sort(union(rform$Y[inx],as.numeric(add.times))) #1-day long intervals used - to take into the account the continuity of the pop. part } if(method==3)tis <- sort(unique(pmin(max(tis),c(tis,Y2[inx])))) #add potential times in case of Hakulinen #out$index <- c(out$index, which(tis %in% rform$Y[inx])+length(out$time)) temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=(method<3),prec=precision) #calculate the values for each interval of time out$time <- c(out$time, tis) #add times out$n.risk <- c(out$n.risk, temp$yi) #add number at risk for each time out$n.event <- c(out$n.event, temp$dni) #add number of events for each time out$n.censor <- c(out$n.censor, c(-diff(temp$yi),temp$yi[length(temp$yi)]) - temp$dni) #add number of censored for each time if(method==1){ #pohar perme method #approximate1 <- (temp$yidlisi/temp$yisi +temp$yidlisitt/temp$yisitt)/2 #approximate <- (temp$yidlisiw/temp$yisi +temp$yidlisiw/temp$yisitt)/2 #approximation for integration approximate <- temp$yidlisiw #haz <- temp$dnisi/temp$yisi - temp$yidlisi/temp$yisi #cumulative hazard increment on each interval haz <- temp$dnisi/temp$yisi - approximate #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dnisisq/(temp$yisi)^2))) #standard error on each interval } else if(method==2){ #ederer2 method haz <- temp$dni/temp$yi - temp$yidli/temp$yi #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==3){ #Hakulinen method temp2 <- exp_prep(rform$R[inx,,drop=FALSE],Y2[inx],ratetable,status2[inx],times=tis) #calculate the values for each interval of time popsur <- exp(-cumsum(temp2$yisidli/temp2$yisis)) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==4){ #Ederer I popsur <- temp$sis/length(inx) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } if(type==2)survtemp <- exp(-cumsum(haz)) else survtemp <- cumprod(1-haz) if(method>2){ survtemp <- survtemp/popsur } out$surv <- c(out$surv,survtemp) out$strata <- c(out$strata, length(tis)) #number of times in this strata #out$strata0 <- c(out$strata0, length(unique(rform$Y[inx]))) } if (conf.type == "plain") { out$lower <- as.vector(out$surv - out$std.err * se.fac * #surv + fac*se out$surv) out$upper <- as.vector(out$surv + out$std.err * se.fac * out$surv) } else if (conf.type == "log") { #on log scale and back out$lower <- exp(as.vector(log(out$surv) - out$std.err * se.fac)) out$upper <- exp(as.vector(log(out$surv) + out$std.err * se.fac)) } else if (conf.type == "log-log") { #on log-log scale and back out$lower <- exp(-exp(as.vector(log(-log(out$surv)) - out$std.err * se.fac/log(out$surv)))) out$upper <- exp(-exp(as.vector(log(-log(out$surv)) + out$std.err * se.fac/log(out$surv)))) } names(out$strata) <- names(out$n) out$n <- as.vector(out$n) #names(out$strata0) <- names(out$n) if (p == 0){ out$strata <- NULL #if no covariates } #if (method != 1) out$index <- out$strata0 <- NULL # if method != pohar-perme out$conf.type <- conf.type out$conf.int <- conf.int out$method <- method out$call <- call out$type <- "right" class(out) <- c("survfit", "rs.surv") out } } #' Net Expected Sample Size Is Estimated #' #' Calculates how the sample size decreases in time due to population mortality #' #' The function calculates the sample size we can expect at a certain time #' point if the patients die only due to population causes (population survival #' * initial sample size in a certain category), i.e. the number of individuals #' that remains at risk at given timepoints after the individuals who die due #' to population causes are removed. The result should be used as a guideline #' for the sensible length of follow-up interval when calculating the net #' survival. #' #' The first column of the output reports the number of individuals at time 0. #' The last column of the output reports the conditional expected (population) #' survival time for each subgroup. #' #' @param formula a formula object, same as in \code{rs.surv}. The right-hand #' side of the formula object includes the variable that defines the subgroups #' (a variable of type \code{factor}) by which the expected sample size is to #' be calculated. #' @param data a data.frame in which to interpret the variables named in the #' \code{formula}. #' @param ratetable a table of event rates, organized as a \code{ratetable} #' object, such as \code{slopop}. #' @param times Times at which the calculation should be evaluated - in years! #' @param rmap an optional list to be used if the variables are not organized #' and named in the same way as in the \code{ratetable} object. See details of #' the \code{rs.surv} function. #' @return A list of values. #' @seealso \code{rs.surv} #' @references Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative #' Survival Analysis with the R Package relsurv". Journal of Statistical #' Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" #' @keywords survival #' @examples #' #' data(slopop) #' data(rdata) #' rdata$agegr <-cut(rdata$age,seq(40,95,by=5)) #' nessie(Surv(time,cens)~agegr,rmap=list(age=age*365.241), #' ratetable=slopop,data=rdata,times=c(1,3,5,10,15)) #' nessie <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop,times,rmap) #formula: for example Surv(time,cens)~sex #data: the observed data set #ratetable: the population mortality tables #times: the times at which to report NESS, if no default, then all unique times { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } na.action <- NA #set the object just to be able to execute the rformulate call rform <- rformulate(formula, data, ratetable,na.action, rmap) #get the data ready templab <- attr(rform$Terms,"term.labels") if(!is.null(attr(rform$Terms,"specials")$ratetable))templab <- templab[-length(templab)] #delete the last term in the formula if the ratetable argument is there nameslist <- vector("list",length(templab)) for(it in 1:length(nameslist)){ valuetab <- table(data[,match(templab[it],names(data))]) nameslist[[it]] <- paste(templab[it],names(valuetab),sep="") } names(nameslist) <- templab data <- rform$data #the data set p <- rform$m #number of covariates if (p > 0) { #if covariates data$Xs <- my.strata(rform$X[,,drop=F],nameslist=nameslist) #make strata according to covariates #data$Xs <- factor(data$Xs,levels=nameslist) #order them in the same way as namelist } else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 if(!missing(times)) tis <- times else tis <- unique(sort(floor(rform$Y/365.241))) #unique years of follow-up tis <- unique(c(0,tis)) tisd <- tis*365.241 out <- NULL out$n <- table(data$Xs) #table of strata out$sp <- out$strata <- NULL # for (kt in 1:length(out$n)) { #for each stratum for (kt in order(names(table(data$Xs)))) { #for each stratum inx <- which(data$Xs == names(out$n)[kt]) #individuals within this stratum temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tisd,fast=FALSE) #calculate the values for each interval of time out$time <- c(out$time, tisd) #add times out$sp <- c(out$sp, temp$sis) #add expected number of individuals alive out$strata <- c(out$strata, length(tis)) #number of times in this strata temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=(seq(0,100,by=.5)*365.241)[-1],fast=FALSE) #calculate the values for each interval of time out$povp <- c(out$povp,mean(temp$sit/365.241)) } names(out$strata) <- names(out$n)[order(names(table(data$Xs)))] if (p == 0) out$strata <- NULL #if no covariates mata <- matrix(out$sp,ncol=length(tis),byrow=TRUE) mata <- data.frame(mata) mata <- cbind(mata,out$povp) row.names(mata) <- names(out$n)[order(names(table(data$Xs)))] names(mata) <- c(tis,"c.exp.surv") cat("\n") print(round(mata,1)) cat("\n") out$mata <- mata out$n <- as.vector(out$n) class(out) <- "nessie" invisible(out) } rs.period <- function (formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action, fin.date, method = "pohar-perme", conf.type = "log", conf.int = 0.95,type="kaplan-meier",winst,winfin,diag.date,rmap) #formula: for example Surv(time,cens)~sex #data: the observed data set #ratetable: the population mortality tables #conf.type: confidence interval calculation (plain, log or log-log) #conf.int: confidence interval #winst: start of the period window (inclusive) #winfin: end of the period window (inclusive) { call <- match.call() if (!missing(rmap)) { rmap <- substitute(rmap) } rform <- rformulate(formula, data, ratetable, na.action,rmap) #get the data ready data <- rform$data #the data set type <- match.arg(type, c("kaplan-meier", "fleming-harrington")) #method of hazard -> survival scale transformation type <- match(type, c("kaplan-meier", "fleming-harrington")) method <- match.arg(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) #method of relative surv. curve estimation method <- match(method,c("pohar-perme", "ederer2", "hakulinen","ederer1")) conf.type <- match.arg(conf.type,c("plain","log","log-log")) #conf. interval type #machinations needed for period survival: R <- rform$R coll <- match("year", attributes(ratetable)$dimid) year <- R[, coll] #calendar year in the data ys <- as.numeric(winst - year) yf <- as.numeric(winfin - year) relv <- which(ys <= rform$Y & yf>0) #relevant individuals -> live up to the period window and were diagnosed before window end centhem <- which(yf < rform$Y) #censor these - their event happens outside of the period window rform$status[centhem] <- 0 rform$Y[centhem] <- yf[centhem] rform$Y <- rform$Y[relv] rform$X <- rform$X[relv,,drop=F] rform$R <- rform$R[relv,,drop=F] rform$status <- rform$status[relv] data <- data[relv,,drop=F] ys <- ys[relv] yf <- yf[relv] year <- year[relv] if (method == 3) { #need potential follow-up time for Hak. method if (missing(fin.date)) fin.date <- max(rform$Y + year) #final date for everybody set to the last day observed Y2 <- rform$Y #change into potential follow-up time if (length(fin.date) == 1) #if final date equal for everyone Y2[rform$status == 1] <- fin.date - year[rform$status == 1]#set pot.time for those that died (equal to censoring time for others) else if (length(fin.date[relv]) == nrow(rform$R)) { fin.date <- fin.date[relv] Y2[rform$status == 1] <- fin.date[rform$status == 1] - year[rform$status == 1] } else stop("fin.date must be either one value of a vector of the same length as the data") status2 <- rep(0, nrow(rform$X)) #stat2=0 for everyone } p <- rform$m #number of covariates if (p > 0) #if covariates data$Xs <- strata(rform$X[, ,drop=FALSE ]) #make strata according to covariates else data$Xs <- rep(1, nrow(data)) #if no covariates, just put 1 se.fac <- sqrt(qchisq(conf.int, 1)) #factor needed for confidence interval out <- NULL out$n <- table(data$Xs) #table of strata out$time <- out$n.risk <- out$n.event <- out$n.censor <- out$surv <- out$std.err <- out$strata <- NULL for (kt in 1:length(out$n)) { #for each stratum inx <- which(data$Xs == names(out$n)[kt]) #individuals within this stratum tis <- sort(unique(rform$Y[inx])) #unique times if(method==3)tis <- sort(unique(pmin(max(tis),c(tis,Y2[inx])))) #add potential times in case of Hakulinen ys <- pmax(ys,0) #tis <- sort(unique(c(tis,ys[ys>0]-1,ys[ys>0]))) tis <- sort(unique(c(tis,ys[ys>0]))) tis <- sort(unique(c(tis,tis-1,tis+1))) #the day after exiting, the day before entering tis <- tis[-length(tis)] #exclude the largest since it is beyond observation time (1 day later) temp <- exp_prep(rform$R[inx,,drop=FALSE],rform$Y[inx],rform$ratetable,rform$status[inx],times=tis,fast=(method<3),ys=ys) #calculate the values for each interval of time out$time <- c(out$time, tis) #add times out$n.risk <- c(out$n.risk, temp$yi) #add number at risk for each time out$n.event <- c(out$n.event, temp$dni) #add number of events for each time out$n.censor <- c(out$n.censor, c(-diff(temp$yi),temp$yi[length(temp$yi)]) - temp$dni) #add number of censored for each time if(method==1){ #pohar perme method haz <- temp$dnisi/temp$yisi - temp$yidlisi/temp$yisi #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dnisisq/(temp$yisi)^2))) #standard error on each interval } else if(method==2){ #ederer2 method haz <- temp$dni/temp$yi - temp$yidli/temp$yi #cumulative hazard increment on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==3){ #Hakulinen method temp2 <- exp_prep(rform$R[inx,,drop=FALSE],Y2[inx],rform$ratetable,status2[inx],times=tis,ys=ys) #calculate the values for each interval of time popsur <- exp(-cumsum(temp2$yisidli/temp2$yisis)) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } else if(method==4){ #Ederer I popsur <- temp$sis/length(inx) #population survival haz <- temp$dni/temp$yi #observed hazard on each interval out$std.err <- c(out$std.err, sqrt(cumsum(temp$dni/(temp$yi)^2))) #standard error on each interval } if(type==2)survtemp <- exp(-cumsum(haz)) else survtemp <- cumprod(1-haz) if(method>2){ survtemp <- survtemp/popsur } out$surv <- c(out$surv,survtemp) out$strata <- c(out$strata, length(tis)) #number of times in this strata } if (conf.type == "plain") { out$lower <- as.vector(out$surv - out$std.err * se.fac * #surv + fac*se out$surv) out$upper <- as.vector(out$surv + out$std.err * se.fac * out$surv) } else if (conf.type == "log") { #on log scale and back out$lower <- exp(as.vector(log(out$surv) - out$std.err * se.fac)) out$upper <- exp(as.vector(log(out$surv) + out$std.err * se.fac)) } else if (conf.type == "log-log") { #on log-log scale and back out$lower <- exp(-exp(as.vector(log(-log(out$surv)) - out$std.err * se.fac/log(out$surv)))) out$upper <- exp(-exp(as.vector(log(-log(out$surv)) + out$std.err * se.fac/log(out$surv)))) } names(out$strata) <- names(out$n) if (p == 0) out$strata <- NULL #if no covariates out$n <- as.vector(out$n) out$conf.type <- conf.type out$conf.int <- conf.int out$method <- method out$call <- call out$type <- "right" class(out) <- c("survfit", "rs.surv") out } #' expprep2 function #' #' Helper calculation function using C code. Saved also as exp_prep (unexported #' function). #' #' Helper function used in rs.surv and other relsurv functions. #' #' @param x matrix of demographic covariates - each individual has one line #' @param y follow-up time for each individual (same length as nrow(x)) #' @param ratetable rate table used for calculation #' @param status status for each individual (same length as nrow(x)!), not #' needed if we only need Spi, status needed for rs.surv #' @param times times at which we wish to evaluate the quantities, not needed #' if we only need Spi, times needed for rs.surv #' @param fast for mpp method only #' @param ys entry times (if empty, individuals are followed from time 0) #' @param prec deprecated #' @param cmp should cmpfast.C be used #' @param netweiDM should new netwei script be used #' @return List containing the calculated hazards and probabilities using the #' population mortality tables. #' @seealso rs.surv #' @keywords survival #' @export expprep2 expprep2 <- function (x, y,ratetable,status,times,fast=FALSE,ys,prec,cmp=F,netweiDM=FALSE) { #function that prepares the data for C function call #x= matrix of demographic covariates - each individual has one line #y= follow-up time for each individual (same length as nrow(x)!) #ratetable= rate table used for calculation #status= status for each individual (same length as nrow(x)!), not needed if we only need Spi, status needed for rs.surv #times= times at which we wish to evaluate the quantities, not needed if we only need Spi, times needed for rs.surv #fast=for mpp method only #netweiDM=should new netwei script be used x <- as.matrix(x) if (ncol(x) != length(dim(ratetable))) stop("x matrix does not match the rate table") atts <- attributes(ratetable) cuts <- atts$cutpoints if (is.null(atts$type)) { rfac <- atts$factor us.special <- (rfac > 1) } else { rfac <- 1 * (atts$type == 1) us.special <- (atts$type == 4) } if (length(rfac) != ncol(x)) stop("Wrong length for rfac") if (any(us.special)) { if (sum(us.special) > 1) stop("Two columns marked for special handling as a US rate table") cols <- match(c("age", "year"), atts$dimid) if (any(is.na(cols))) stop("Ratetable does not have expected shape") if (exists("as.Date")) { bdate <- as.Date("1960/1/1") + (x[, cols[2]] - x[, cols[1]]) byear <- format(bdate, "%Y") offset <- as.numeric(bdate - as.Date(paste(byear, "01/01", sep = "/"))) } else stop("Can't find an appropriate date class\n") # Tole je bilo prej: # else if (exists("date.mdy")) { # bdate <- as.date(x[, cols[2]] - x[, cols[1]]) # byear <- date.mdy(bdate)$year # offset <- bdate - mdy.date(1, 1, byear) # } x[, cols[2]] <- x[, cols[2]] - offset if (any(rfac > 1)) { temp <- which(us.special) nyear <- length(cuts[[temp]]) nint <- rfac[temp] cuts[[temp]] <- round(approx(nint * (1:nyear), cuts[[temp]], nint:(nint * nyear))$y - 1e-04) } } if(!missing(status)){ #the function was called from rs.surv if(length(status)!=nrow(x)) stop("Wrong length for status") if(missing(times)) times <- sort(unique(y)) if (any(times < 0)) stop("Negative time point requested") ntime <- length(times) if(missing(ys)) ys <- rep(0,length(y)) # times2 <- times # times2[1] <- preci # It may be an integer...check and make it numeric. Otherwise problems in C functions: if(is.integer(x[1,1])){ x <- apply(x, 2, as.numeric) } if(cmp) temp <- .Call("cmpfast", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(fast&!missing(prec)) temp <- .Call("netfastpinter2", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,prec,PACKAGE="relsurv") else if(fast&missing(prec)) temp <- .Call("netfastpinter", as.integer(rfac), #fast=pohar-perme or ederer2 - data from pop. tables only while under follow-up as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else if(netweiDM==TRUE) temp <- .Call("netweiDM", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, ys,as.integer(status), times,PACKAGE="relsurv") else temp <- .Call("netwei", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y, as.integer(status), times,PACKAGE="relsurv") } else{ #only expected survival at time y is needed for each individual if(length(y)==1)y <- rep(y,nrow(x)) if(length(y)!=nrow(x)) stop("Wrong length for status") temp <- .Call("expc", as.integer(rfac), as.integer(atts$dim), as.double(unlist(cuts)), ratetable, x, y,PACKAGE="relsurv") temp <- temp$surv } temp } relsurv/data/0000755000176200001440000000000014742177663012706 5ustar liggesusersrelsurv/data/rdata.rda0000644000176200001440000001517314741433304014462 0ustar liggesusersBZh91AY&SYÄúv[FÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿàßíÀ:ø=À € ñ‘!"D‰7€ø dÂ4L˜LIL4™41151yRÅstK®0ØëiœÚS:ÜU)S:µLܶU­¹ØªRâµÅl×Tene·ìÝfÙØlunrá2¶Ø:fÝlÚá5©­Òë›n²åÈÚºÅqªY®äBC ’C–‰Å¶^UÎ-nµ™¶™Ø­mÆØl¥·e-ºÝ£6TK®»ja ‘´¨ÒŦ5(¥¹è»‚œ +L™¦in¶c%¥+a­·Y]²Y¨«uDmÕêsè„‘€ryçªÝjæÛ\Õ¶ è—- ¥ÔÒÜ6Ýi›K[S5*á­*l]5ªdpË[©]†WZa²›%–‰›kmSVºÒ›]Q5Ö]sFfÍKvÔ¦¦Ml«µ·£Ÿ8Hul¨m Á%‡?€/ô:[ç˜G¾ðq|XpãÇAyC¡wþ8›9ö[\8Ì­îbÄÉqþ›ÒÄrÒ\]òyÜ˳©â‡nŸT—ÕÕŸ®òÞ¦ce]°eµ¸ÓžéÉ&–Ç—+èm¼—i¢ð¤ÎRµ/( s!5åX ØÈm¨úq²Ì=5ÈS2ƒ¤Ûƒq¦Ìe˜Æ¹3Ùe`q4ä†PDôoLªÐ‚Áå¬î ÂÐO$r?šb3+„T1 18€Û‘ÌÒ¨<¦úU‹>ÉËM?Œ¬•’lú@õki¦tRˆÕmtTx€ªô'`Ãi7ª.–öjԪഠUŽYœ™Âr„&,5S{6­0(êYλ ¤©Ij·;Õçã^Î2€(ÐÑTpâ_μ"g”„ùs¦E`µÎdæQh²Î!Ð`®NÕ#¦k39À:Ìbâ€>€Ó ë¶‚­Ÿ ‚•°©ƒƒª{Ø |ÂÐâBë1-HÄ#(p \Çb‡AzÅ8¹(g6£ÈÙ8Œ+Y¹=ÃkBÙ¥]Çd[_8$UMÌGµ‡¤tÀª¥©Bhñ½+Ê ½šúH· NH)hI· åpBƒ©à¼]pVv³î&nJé £NÂGÖ ¬8l~ꀡ‚ ¶`›`õ é¿ Cqw[QÈ䳄êê‘ ÇZÌG^yöý ÖUÅÌ+j¶°ÝÊÞ:F_l°é2•ÜšežJ“p¬Tû×! ÓFË™v¤OSNcÚª¥O@ÉDh05~ám§žo‚ U6ÏNœú[&–Z,aœ%hɳtõ :'QÀQ‚\‚sçõ"³“+#‘¸ƒñ‰sêHú1ðWt-!QK‘5ä\±{b6ôU™´ªëThïâC&RíXFyÆIYfòÔÌ P²X²˜drÚ0˜ëôÐ…Tß´ÝO‰¥Ñl¿äÕ0­ÕJ_Hf!r‚¾¶ƒ%qƒÁz9¨`²€ƒ=*QÌ„=Lu^ˆ5æHÓ´ ^]¤˜­tÁZç>& ´“Øô^p’Çuæ±B3-ئN"%ŠbØ¡®ëPv[¹ †ÙhFÚ†êí¿ «Éð“#|/.J˜¢înKr²¹R¤0¢¢÷dM;^ÎÔ–÷2FÜ0^0@›G)îÔ¾ØTIÞ©ª,Å«]øP½Ö¹ÅnÊóôí)‰œñI°Ñw¦Îw^6¬cljuC‹Ÿ½PC&ÊïTI°³ýæYV/'H Ûe‚ @ÀM˜Òæg2¶_¿L5:¤€-€Á€7·g† ÷¼áŸUüOPÁ—äò½Ül#[Û›ûõˆ\z^Ág¡_Èî`ÿÞ¿ñ>çû÷Ì>}@žS»ùTz_à¿/Ü>÷û×f›³{I®rY}–åîFCOÚ  ‚©ètòÐt¤L ±Ã 2†f?Ãoü­éÂþÙ0¨Ï°wäí¨^È›¶§·—Q4kM¢)ÞTŒNäe†8ꪧ?¼1¶ÝÅ1š< )ñ.ÁÔßJLb8ňæÒÇ# KKiz/»Š¹QóGñ?Ï®ôù¶‹E Ç¥°\´¦*Ô„ub†ˆ`oò?£X†ÆDûKKŽü•É‹…‚Ù#¼‡kaŒòlKΕÏúºŸ&ê ÒØ5:P\oƹ9H†d Œ'#ºfn™âç•Ó—³‚ߌHÁòáÌÑÑ_KŠQ@+O6=¯‹½•ß„×^°z"K R¢z)©85z‚;ìÔ>¸ÝGý«½‡\%S7ôèâïF¼÷€ÑãWãn =ÈM(NéÒA&Ú~ºRÄ;i—Åÿ.4´ìž?zbÙ×̜VñgWÔÿ‚~ø ÌäÌ„¤óþ¨ßï ™ ÂÒÙg£µ'°éߜئ*¿f—ø·÷N"õ¥1±ÊyÜ‚³o/ľ®™„™Î\üi³àï8ÚpLR”Þ&ª; D·Î§2r™©õ›KþOJøûl+>RªÞývŽôc HÅk(ŒÕZN½§"«Bϵ{·Üp‡ð•öR©Óså%:ñÛYDVÚžJèué%b†wZøï’™Üœoãra=Ë[§MȦ–»4d°\]}½2æ.}˜æòù7Ÿm¥gecU1ýš[œ¬ÿ›¤ú†^¯ùøPIð‡2ò\y^f4G>ŽA±‡t·C“Ï2-¢… öL…fs*6ù\ÿïðš/AJEzêƒiT3))gJNËãº\b”-¶ç ¼èþ‡E õKÎîÃ!eËú-Í5«°ãf%²L8¾Ô¼ 4ê¸IY¯ú­ÖºX3U!­S‡ÞgUvYiæªhrÌm¤oé-Ø“^‹J딢x«u·^iê#÷øw¨Iæü7Žÿ.òQˆÏ´úþ—IéïÃû33ÚG°°Ž]gmù°,²'K«óªK’® ³®¹†kàìäÂLÄ3ï«Ú!úzFÊ^gÁÐêëômÐÙ´™|Ÿñ´Sî 8âÖå±ËŸ cç3Ö#¶}¾šf æhòóñt&±vrä+ª(è©*­Ó/$ûw’6„4[—Þ©˜( ¤{%‹»ø%ñ¸®¾<÷}úBêþÛˆ¥"åÈÝ2lÿëB»Y·{ÊŽK”æì¾æ4_?ÊúÈOÏû4`»PCEú(O<ó¬1MuS v(qŽ€eñ[¬TÙîá«a¼vuøéEÊV­=‹XœB¶òÒv?±Ù?âa²ÖÖ£ŽºBœâmÄbsÆÜŽ ›9¿ñ]Fuí-+aøï þ<$ ì¡k tAæ)“{ü‹õÿ½ §¡Üû[Å9¹ÿ_Ô]»2ùqÑéß,JÀJjs€±»E"òC*t¯5îÏÆÐG€š…4΋´=°§~!»àÄ™t°M%özÙ löý^Ž ï]Çž=‰[P›§NÆÈ©*ìkŸ Á÷;Za¸ŸÖ±¥§eqU¹Ã ÙâÄ^ˆËêD_s>ôK‘LÒâÍ«^]Ïvx; ÕS޶îs¦O_÷'ØÞ"”zµéâk%¦8Çú»æ&ï\ä÷OFÕ#TJÜàË©õ<ØÞzE²øµT®ß%ÓwœÃ›ûrÄ仳ߩÚASB¤{Q´ˆ¹ø ûóƒí ä8~i5Šû þ:íÊš–MÒgž×qv_qmÄhô^ƒEfîC2àî뱋–(UHÙlì=gþ sˆöŸŽôßòe ØVcä‘ï÷Xǯ Æ•OúEr±?+I³~|8äÜÈófÄ¥çûq(Û,Ù·Æ?w¾Žêt®]µØ<Á K=¤cQÒøÓÚiâ.ëBÃ/Wýɭ2Ž¥x.Ú)]…°lõÑ&­ãŸPéî̈£¶Ü0äcþ8 KòiÃcéâÔ Ú—Iqì¾!P¦ùQÍüᜥ‰nü“£´dzæ ¨SœJ΃Zm50à>iߘ~xB>8Lî½|tHT”Åèq¼ü÷Àå#ŒÕõ*NgŒE'0 rƒ)Gì³ÔøT¨ vìöHñrIa°üÆÅÏŽáÿ1¹'ØãÓ*ål°UâÞ¢¡ö°ms$:4(ð…Ê?á+G¶v¯>”íÊY„~®´‘Ý•mRñi77…£´$ƒ@¥íìR’èÉÛ¸Ó…– šqÍZ]W!¸e»9ðv §+ñø|Ý%`ô„Â*ýd£Å¤I÷%ÿÑEßá¡é pÙ"wµRº½ŠëÕ ó¯ ¥ ë×WBF †ÑY_QÉ_£æÎ)—‰ï“mÈú=*U”9V¶(g_ LÅI±Ò6•7Ý:ºÈOVã¨K쑇oY÷lOIþ¤R±Ø µÏfê;Øa7ží¬Y:µ$ç9äR ¤ÛEd F Æ‡…ZŸ¬m2*œÞe-H³M§¯rk:×$ÿxVÑØÇá{´‘…ÀÒ§Ký'Ã^n6ë`ŸÖ§&ó¯|‹¶ÕúŒ}o3Sããéâ¿FÛ3.²!ñÈÙßÕÿÊ©¨ñ‘úváƒaaôªh@ €aÿ£Æ0Œc EïGÓäƸözN|<_£üžyçžyçžp#Æ1ŒcÎgດi^ʤYµÄDDf@àH{Ì·ýþ«²^\‚Š/ v¼+½—UœZ«œ­9 ûŽÎWÂ*á¼7‹smmæÔŽ&¼ùíÇ#ç,PæÙo§¥´à`¢Å9&m§B15á!«C5 ‰¶Ý.–áàm–´X±#*4劙)2.aÜËZŒ¼mšÖª –É ÷/ÛÈȽ² @TƒˆD½¸‚ˆ€ƒÿ}Ó¬ôä’û_ð=o¤ï½3³tÈBuL$ƒ{æv–5Ò$@•=†Æ=¶Žv†a@ Ej^¥•Pˆ€^\dò".ç¶ÆYlÀ¹kˆSmuP«\Eƒ®àíÄFDâvI- DB¸ÕëH<¸œâujûÂÏØVàØˆœâ""Ñ "]Ñ@Šn»•+RlJB1€"C¡ày± Bt¾1Œj#C(@ ´Þ ´˜Ž' dtÃqa Z…³µ¦”©Å°ùŽÖ2F¡S1(ËG¿ Ýœé½h)+_“5ËHâV3RƒÞñ0†FüÞÑÑsz àd1ÍÊ#YâÔuXVD³À ]ÑUl`çÑÓD¡ÎpNQÀÄy¼ˆŽÃYä9‡'ÈÄÒTÅg꾤HÅ*§ ”/£Bꛫ0­_^BÕí5âW.\¹s,ìÓL/B1€ÀŒ`F0 ÄQÆx¬b¬¦ši¦ši¦Æ1Н$fr’¬¥+q ƒœ9Àƒœ9Î!JR”¥/^½y•UUeEUUYQUUVTUUU•UUeEUUYQUUVTUUU•.•S5™È¬¾f²1°`Áƒ ×X/¬»»Å Ü ¨ªª«**ªªÊŠªª²¢ªª¬¨ªª«**ªªÊŠªª²¢ªª¬¨ªª«*aª„+†CjêÖQEQEZÖµ­kZÖµ¾ü\\UUoÊŠªª²¢ªª¬¨ªª«**ªªÊŠªª²¢ªª¬¨ªª«**ªªÊŠªª²¦R¥IšÉfÙœøùnºë®ºë®ºÖµ­kZÖ°ŽBî»ËËÉ^ÊR•0Œ$        ¥ûªT˜3Ìžc<Ëäaºë®ºë®ø8@dÓM)H 2    oYíéRõëׯ^½zõâTTTTTƪªÃ{5ð±2¹,3/‡“[²Ë,²Ë,²Ø ZÖµ°bbb4¨ë**ª®TUURTTTTTTTǨB·e¼’ÕwXþÝUUUUUUVÀ­kZÖµ­kZÖµ­‡1ñ¥EUUÇeEUU%@%@%@%@%@%@%@ JR”¥ÂÜ#Ã#¿Äßàá[²ªªªªªª«4ÓJR”¥\# JR”¥)¨¨¨¨¨¨¨¨©‚I&{–ø¹L‹³—ïß¿~ýû÷ðZÖµ­kX+ši¥)JR®„¤J€J€J€J™UUUe@%@%@%@%L¶5T“#ÄÅËgxõð$ªËâäòyS ƒ¹1b‹ÇÙqܱ¨"·P¹R"@ˆÛyRcB™-ÚÌf ôñG |0\Äà…·s‘M€¬NXX” "ˆÛ™9¤(€‰);QJŠƒå…îÎ=˜±b!lbËBegÁTD0fÿˆ‚XMá¶`l=j¼¿EN$£´¤Ò§¦´Îš âuw©lµo ”jr”tÁ&ÜP,ùNT25ËZØLÅpYÕU®sÙÐØ¥:žƒô]y+çþ 1¹CxЂÚaX@»MÖ)¨¶sd‘ôoÉÞ‹Fns³<iµä…¶ÁG&»0ø¯ ñ€ áöI  »!Ò3Ž*M*»&R3 L¸æˆÀ@0˜b¯¦3mD¡ T ¦ìéBŠ)"1Άq,§Žz.¹IÙÔ@Tüu¦„ÚXn¬°µǺ£8 4ÂLc‰ >øF‹àntQ)¤8€‚$ŽMÀ UY#¡á>;\µ5Âm>.Ex×5‘s 0à!)!Öí‡%5[ðjÇ^^ÜmW&ª¹c'Bø>@JÖ‚PGH ™–ÍÓXÖ/4¼‰úÛiîåxS+ÀX¦ÊÉQ¿›6 R›õœ}TÈ}(ÅY¨j ÉçCû(?ãÌjúŒxŽ…ö)!ïzቇt8F]NÃÌ¢Ãl°KÒÑÇ‘¬Ù–‹|ìês±Ê_œÉÈ>ÀÑAÚf˜¬Â^ýü“ð·—ЂËdʼnò„yxÊÃáä¢3ëÎXç™e…·¸Ë~Êšs4K¾IÐHë3$õÏ_,71¯Õûaý¨ÎlÓ9ŸƒÆàìCz/Rè¬ö‹°Ã¿fKX,Y„´y|dÓÙDøÇàÖ>ì‚•m4ײ§ÇffMÇDVÑ_´ÄíQqRÒ¦#÷Ÿ­.$é}€Áw~G³âj7†ñ“„ƪ½†ZÊ‚u…¥7nn‘M|™­9lq¥Ûh¢¼…‡(Aý+¬™óC0 Lþø4ÿ.Ü êã®Ä+Ûu8 ^Y;Dz3ä¦tíФ2ƒ§’<1F-Ïó_£ TÙUæOÍ#r oüíbÁÝgqIÿìè§uÐ¥§Q>9ÀfK™E‡£©´/±õ”S%zïÀ$4csnoæc>âLò±ßu’1¬ôgô^޽ŽÉ÷w¢½•Áfd¬úËåõfÖßD—YxS4gî¡R"tnÄô}dh9,ýìÌœ¬áóᵉ+1© `\_¸zÍåíÓኖh‡ßFŸI~’á_*DöŠeìȶS4EEŸY>öð°”îžT3–_iü©Æ @þqF"|êpÛ,+JÄ9"†Pdå7jõ; a׿—wú¬øV!“*Õ¼»$÷‚MvÎM*²zœTƒÖ?HÍІB/›ƒ´¾‚¤¤™¿z:F=ïùÓÚkxçÃû®£¦•mØ>¨))S²ƒ¹Q¯3C™$;Æ€lÑ"Šü{ýŽìfía91™õÃ'Û?ãŽü¾¦{ Ô¹c·׉²k ÄÊÂÞWé~”äNfÅ3¶;>ªÃ¥½€%·¬Vݳ)õM޹A•ç wöÍîÀ$b¶«À€lbD„+…Åþ~²>ÉV¼æIpÆx£MÊêŽ'޹ä¥ÇŽÃ7Ñ.äËfðÍ*óë,Q‰¿B¸ñ¿¶2:ð#³»ט½K1&¦”W!#UºÖ;éeä#³E jªÝýxm_é#Ê!¹Ë:`„&? 2.,€76þ•¿=‰söˆÒi¦¥º|C nÄ\ÖÅgùC mš -~DÒ¸äŒ'<>À1ƒrEtäÙ{Ϻ“¼Bzr¸ºÊ2ZKYHÚ±¤5‰V9_Û´/ÂùÛå²nV‰@U®p®P¯S5È6'ÿó3UÑÒZG˜¡Ù³[ùNKpCYÕã)ÿåmc1ýùÛ„1XJãNÅà¢Ý•úJœò蓟þÑã÷æ>ía^ÿ° âlúr hÔö·’Y í“$¼U%ôÈM‹Öð’üL0GŒVSþ¯5sLwå4ÄH²q+_Ô/'{ô÷L ,¾ŽnÌÛk"lˆ= n’1nÖš¨YÚaÓ¸ ¦7p‘¦ñ: m/åû¹têûtîzªÏE¡†f¨nÌþ·¨yÓh¼HÒGß^k†;?¢rSÜñÔÙÆµG´Áq’Šƒ?`¨!ൡb/‹FžÚµør»Æ¼GÅ<¯Õ\ºDXíð‚áµãFyµªWA "AÖ½5ƒ|`Ì!¯m;ˆry‹â´t }°PW#M$ƒóÞà+šjB RiÌÎÂ&ic·õß •> —aZyz-ó^ CÕóçøû`¥€¸âìˆÙ+ %ƦÚqÄ«ÇÆ QÕ Éè”EILý]¡Hç*úÞr?Æ 0ÖÖñÈ…ƒ~´å;SÇ_%‡ÆÜ,³,¬¨cw\Jªjp PÙ^‚cÒdLŸ.5HÛõq“è7·0 i|>Zn‡ÝöŸÚ’µíæHýu<…¤þ‹÷G<“ôØÞÑ6^ÛÇ uɦrM[‘³ ]ÏjÈIÛE¥á®q 'Q˜Ð…×ÅWžÎÉž¬ÿše«úçû“Jr&¬ 5­Ó;Ä<žÕÏÉ Í® óÕ@6ÆÏh}weuºF阥֤Z»QíÚªöæ¡™©¢%o]X«+ CÛæ{põÆ=\»‰3°vd)1xâ„—/"tð{æY‹…÷òNÑžf®ü·„B2߂ӳ]¿N'‰ ¹NF–ø& ýº÷y¡–CÝáq“ăÍya$º+ó‘dí\¡gW†¸þÞ¯Þü‡ò=­µ<‚ µÙ"½&Î3E}9Ÿ  ïâ¶¶›`@úD)¬àìü´yæ'¿hí¦sXrJã 4Eªƒ;t*”Óªê}!|:¹+^RRwÙ+Jƒe»ØûlÊëI¢õDŸy£ÃC#8$݄5“~½D ö3'Ñ ~ó¶6AæL2’U?­¼\•¾Ñ“É'uôçIQù#x$š4t|8Œn '#÷wXûâ]Éã<¤byr¹ÎÁú` z䲎£áL3hÇäj ¦û#·^‚(}xÒ*{Ðex£¯~ðz@Um "—iý°œJA,Þ YŸ:y„Z jv°5u ,QèlavÑu®$œ0p1·4å¶5D‡¬> Ëwqž^Õš%ƒÚsÑê ¡ FúÏoùåi†Á®æ]{¢NõÒá}WGž¶F”yÝ8Iˆ4*¡+à1ë“6/ù °/w]¡kò†ÝXV‘ÅDd'äµòlp,|ÒÛiX튪^£ÎItwG@ÿ. {íùù¤‘¦ƒn7T³&+áúp‡˜j> m«Ì ?¹ Ó1$¢\ Üm‚NþA¬§’‹¨ç¢LB}má§æuÜCªñ:ø&vWéÅè ñl"y=÷-s´kjÜeI›¨/í€Æœ‹1BƒS5°vÀŸÀ$ƒ8êfº;zàÒД”÷TÜÐwîD ¦| Ÿg¡#†l×§;ž¹¬h¿˜ÈŒîD~?-™3š´ï±%/Hî^s}Aïäi¶·u¢0 ùg)VŠý³"Pn4²—µl…}˜¢W É@—PRٰ̘B7“±DÚñjýN3;N¨ÎB˜BÇí ¢©÷Ý#gᘸ¡ÀƒÃlÊ)!–IŸþ“šÔeôÛVˆ]‹~²v,Ò­}­ÀËn*ض·ï÷È3zËʘ¨TX™£IÉ@™¶_ ÛÇ+ª<4¤”ŒîÿLÙ.Jó83ø*xnÿÜ>b ýÁ)êvVº—õ­–vàóS]Ÿømïàëõ¼mCv˜]™¤ÈÃZhA¾ÞiØß_ç­ ý].“űˆD€ç`ô~鉵qXþµa¤ÎÑì«Ì:‹Î´"l*:@-ÀP9ö•WÎÝy‡ ’Ñ axBËPly"ÕOµÐJçc_éÇ@ÿJÏÖ}5ÑfH|ÐÍç· Cê›kª^Åø£)t[Níh‹Ù§zi`›‡|ª:XLñíeßQ7¯¡Ýq œ3i›—·¯ÂHå!'+³.1ïó­SÏ•Ëu{WmT!EJÖÌû<P‡ šS wÃY•ž3P[¶öžùy[ôÞ™&†¹lº¨°L®Ë›w†‹,’xô“z±ÅÍ_8 ÖUW¤GµßD¡‡þèÉ]ÉÖêº.SiÛóH‚¾kT)9U»î­J>ÙPJl‰¯ŸRíçç)WœËÔ•úh{æ³t”³z FZ*¡)`(Ærõãy§ü‹ue«:ªŠ]öÄóu•2w›É}ñI–ä¦QåÝë¥2»+‰¤ôZ!Øp0Èí9¿îÞb6  Éæx «Éâ©$jaªØ[=r®È¢”pÓT«`•*ד5„Yµs8 ¥ËˆEJÍUüû$<ò²’ä;·ëÒòÏ0º'ÁŽ gû¸ iýˆ79µêûž©†® FH{ØÇYÓ¾ºvm´ÆåŠo— V»¿ØíN®€[¬ðqÞ%œñL–™HÛqTÌx»ëoáá!ú œc¢,u?QŒ8ß^w£lñSnšazÕ•äwò$šï }õGúÜüžÆ’ÚgÝ“-nÃ’Ÿ¾Ìø£‚Õ>˱á]_€ðÂm8f˜~˜H!»û·þc`äÏ‹Ùôr2ŽŸZi®ómÇæ´0A‚ê³ÑhÕ„ÚØr]¬h„j3j ª‹k“¯-5R,n¤Š7íZýÉ›¨:YÅÜWÀ¹×ƒû ’w…Ò?½¬Ø65’ ó4>‹«ÀMR$‚DŒÈ%^¾§ûù÷— 6 J¾ûSR­ô¡gI¤)u‡a„G pÝé ZŠßÂËÝ×'‡C‚h묩i |)sò÷t²$8^p'ówÐŒèeÊG¹—@9p­=ÚÊ)oFÓžxšÞýhZÐY3ï½¤Ó ÆuáWáY»§CU£=ÆP2Ò³]´’!}dm˜Y_©÷;K¤>•­Óûiì‡/èŽyÄ8WÅÉk¾áW¥ÀI›P†Ì;Þýd¸£±ê)S„nö <h !úàá·WÙ€3ÑÊ4Zú zÇXÑVÀ¶ÎûÂßý•ð¨w˼÷ Å…ƒùå¶ÜÉqE ÔÉ’ø×u©JsÆíª‹Ñ‹ZYUJâ ÿpäi^ÌjðU8ÝÌñöA” „©¹Í’ŸÈØØ£5_\áCÏ2h)îzŠ$÷MÑÄÁ^atG$mS^uóßéцMe€Â8C”nÈÐDas]…‚¬ÉŽì&奟|ö¶ SÂ~õ-{Nt˜aM÷ÿ¼ö´éaÔ_ƒr#ßF)‹'ƒ«I`÷å"^å°Ã$:ŒDG'ãY¢‡"ÔóhîÈ×]F[ì“1jȳ­-oïwÄÏ/›è ‚gÌ/MÎNÞÈwNIÉ?óe{šz˜J¼ñ‚ÃGêØ@©FÂü–Ã=÷°ÜM31[Ì0ÎÁ  ^{6§ëh´6ÏW„3 Í;å *¿Læå’»,熪ë`„žšhhn›á¸eÃáD¶8áä×ÉMO˜¡>'µ ˜¨"]ÂgÞyô€H˜Êß¿zåç&ã,l?0V’UH7 [°aŒ¼ lÊ3’»Wk†ž"è"X* VE'jNÕÈA§½+Ù}ìÔÏð]”t„D‚!ÏÃÁÙ±k¾C¼ÐFŸ7…`à VÊgI±õºdØ(bæ¸Û$ÀSpºœÞÇ;˜º¶ú¬Õö²U†Ü³!‚OwÄb®ÈF>{|›EúgK–wõPyE¤‚ŒgÔÒhÿq„Šl¿UsÏýYuœ4EÀŠœÓ/]kõÆh&bMÑ^»y1`rŒG.…C1ˆxËõSÅâ Øá] ŽÀYz‚®z霄M oÛŒ)íÄÁvóS¯»[wÒZ%©˜V×,|^‡[–õ™ãóºÿ[›xß„D§)ShÄœ‚h\ ]]EÊU&”9Æ¥_tWB{ÀG* p[GÏ6 o{°qJ°õ\`yˆ$Yâ“7\¼¾Ú†+Ôom“dÙ”MBþhBb»Hoüƒ[9ÈNŠåß",‹?ûŒÒk³Ýß÷V{d¤ˆ$'Ä/ýݾ£JZf/(iô‘™¾r%C)ïqIá2°Nñdšz›q²´-{?kÒÐݵ€—ZL£@ênƒÒuÑ< [‚÷°¬}ˆƱŒ©„ T»K¾d©ÁtgÅñÿ¡àŸx‘lÔO2ðµ:yéO²ƒÄ'20DÊþ‹Íîs˜àFæVäMQ¼`hi¶Ç «ò*mªé» e°í1åÎöÏÛÀ-rzxT¾¥òoɼÇMN†h]§|VG<ßs"j²ÙÎô…JN ì­ÏœCéÊø$¡Óº xÿ7õGT£ß„ ÂG†LÕªP £&Pø$ŠÚ+Ùr“YÁ½2¼$dïÈÃpo”œ|Ä)<环BH‚lf/ã ùa©n½lDšÍô³[Y¼)•è]”X{È#Ñ£ 2îÆ¶©#³\…Wb½—tènê õ=0÷¡²KêàÝ/8æbÄ$#´’ðmaÕ à¢”eL)k! +ÿ°;(íogåüÞÇùCùáWФÓWq½-†î 4Á  SØ…ô® nê2Ú¾‡oÏãGožZÈ@ §ßÞ_g¦ã`œ2IƒÚWñÌ„ùÕȨÖLÑ=­“D9 c~êìWc–H/.¸ŠLäù`I8ÈQ=âþ¾ÏÂÂßá@…PA€|åƒúWõ /Mê_ù‹Ð o'ëÞüjõPU$ñnaâw´a(Æø0îËìðÄLÜø_\ü°‚sm–òM°‚ÔÀ.¾ `Ç©ÞÑ6 ò‰ÑyîmK|:´tÔ ¸†yô36µQû4a,Ìß)‘p~db»·‹WöG~„y‰E5#8.¢áä¦ìïO«å“$åÙRä­mûÖé PVaÑp 0Aq°ÿôQ–äI!qœžÍæ¥3÷/FûƒÛû´¼À ¬!½æÜ2zô­zH–&ûhö' =Ð@Çü…BCd—D`Aº=JÉa=Í›Ëñ:É“¸_ø•æI’çáâÝ2 cœöóAráyÞ‚Èäèãž µV¦ºŸ#¨w ”¯É?ëjJtF)¹#Å´6 Q&»6™Ž—¿ ¦4ÙØ›ñÛ Ç‘2Uþ­4µOAg …E ]ÿqê§ ŸTZ¤K¹ÿß ÓßýÏvžUF8ÅÜUìABÅÕ&#ìåá¥u«4ùôsܹ}€²ª8«H$Ø "–ÝçiÏÎÖoPݹD­2 €˜OœnñáúÓ@mr¡/Ýõ÷Ó™-«§e…Ȧ:³o¾5zeçûó™É:ù¯Ïa §G1oaè"¤kšrÐó‘°Å°*-½ÙÈÿé æÄe ëßAüÂÏ9¹‹†Ì ³æ…<%<ã.5^¼O0>ôfrè[še±ã0ʉ¯Å ÷! ‡+ìÏ…M‘ÀcÍì| ˆÓÙV#È[1Ì*¦Ú+3¸=v¯žµ¾hZÊÓ%>VùFÿ`byB¡ý‹cHTg³+»þ~>›Z²ëÄ‘5ÿ»„í ­.ùýÕ–d^pç)ù¯ß—Ö<$ƒ½´É™ á /ƒ8k%}5ÎÛ™OÿBJ}C€JUdóãqë§òrB˜xÂRÉ€d…g ï4cÍ‘ŒÈÒE_raì†çV”½ÿ ”2â›r`òYò’q}ºªW„K2€©áC)/vœ¬0HA¯…*¬öL l{à:å‹#ÓYÔ<:Þ]ˆ‹–ø:‚š“Ÿ;:ßXàÖBeU¦ÚØãþ6›¹Íñ>Åî~Éu´~X84Mœp°ò.fÎ)ÅsÞÅf±p5, 8Ub¶¢Æ?Þ > L«Jv­T9¤yÇç€+£©¦â;Ј’Áãó`-¤›©ÁNÔøêxÞ=ÑH#d¿ùÁÑÈZÛ¾/ˆ’W¬ŸVîô²BRÙ+çÀ$?‚æA¬ÿsy™£–™ú_'‚‚>dH³¡Xç('à;â£d7ŒZ§;ﻵRŠ‚Ë%²% ÈFø¯ÂÈ;ܬª]pÍWa#5€? #C¼WcLïF ‰ÍæwùUøÂÀhîÉ ¡øW”À•ÀYì`„”Á}³J vWOK”‚ëò¾ ã7éèM1¦R¦[xÏX,“ÑþÁÖ5¶™ •P“=(rˆáÍ Í]lg‰–²}im ‚šâQXµòüTì ¿üøTL œ0j),z昨c­k†…Çø² 1 ¬&é`X¸pÈ™œ&£f²¶ w—Dr“g–aÕ•B‹ ‡<ÙgΞ‡Ô€˜ŽÙ%y–RËŸq¢P 92HžrX¥·q;¸râh$ØÀé8Yøþˆîq‚å´5¡©¡]¹¾ò÷ŒÑ<šé¢Ö ŽR.øÓKR³roƒËFóÙ¢z_|ئ¸ ¯â,.[¡„‡Åùž_D €§Æt2_=ªþû*n÷%å"¼bÊ»d°k¿½„=ýr˜OåÒZD– £ˆÏ1‚”îMÖîÑ Bµ™ÚkšáþüöOáê|6]ðw“Ð*aUE<̽ YýÍmR(hÖý#P[Y?™jçaðòe,ó A,‘ƒ¹€©ûñ&Få–ømdEðåLÛ9I½´ 5G)ôo 8_CÂÖ‹l9}þT8kë’ ÎÕ ;)^·íÍH!=KÉ×$ºœ‡Â'Ý<ÇòØl&GÓUžkNÔL-–t^¾Á=Ibƒ«¢ú\( b—ŠDà;²AEGYYXFЙöRì¡imàTÛÀ% ú)$¶$iÿaô äIé9” KÂS*°M£]çeÓ(úΨáJ ¯?>D‚LÛ1é+Þ…|KEÛ°"wst¤n²Ù!ÊS9}˜#¥Ö í·lÛ¸ZS¦#BšEˆœ®â–Lh¦~¥k„Q"²8™•žX•iìO]ø»F@Y5ÿ¹QBÕ@Eþ9cÐÒ… £Òzsa]–v²¼÷G'ÊʺA]=´¼ç f]¦?³Pa®µÄÕé_Q0ijÛpq’6²Zò.‹Ù 7„º¦åfT=ÏÔësºñÞÐhëËNº@òÈG™Ü@Í戴xÆü_€HÒô¥%¹ì–YkauIµɜ<»`—ÙI纫Å~ƒ:ê¡Ì÷ûBw;<êîÛYGt¨ŠYçiãm6Þ)Ü‹£Y<ӽŕRÖ‰è7¾„f”Ðcý%Šß›Ç4p•bhì×Dk}KK2Vp¾úHêåñÐ’£”õÆ!LA†ã8ÕZA,Æj•štuç·F\ð=X~ܘ]Ê7ce8_¦ ÖÐ Ú…ŠD¥o€ :Y¨TÄ;þµµ@Mòø(~x´—=9äÈóÛœ Ën2G!}Wg$}EïþeNw›™ß`•)Ö®M¥_Æ¢gIäýt«0ެѿH©–°ÊG¼é¿V§lÓ»\ïÌ68öA«½£ý’ îÿGâÕÚ}£4“bÓô/íEHéœ#Ì/Èüw®b!Cªªö-J­6\ÇçÊ„ÿ[/\Hµ¤òÅwb‘.¼±KÏìðcä¦ß`ýÃô,çN#9‰´SWŸæyµí›™¥¦Ï^Zù;‡¥ru.ÅqF€½‘úo¯©UßÂðæ‹ƒ÷Ó•ÍÂî ëˆr+­MMgh¿n“¢úhó±æô¸mGw~±¢éÒ•íEž$ÀæÒ’¹hâÚ8”{*¢ñÖuÞ…Ìb‹¿Ÿ2â¸Õ~EµÎÍzü;tG.q¼˜ÞN¡ú€­˜b½æßª „z+ؾP ”à¨öj­‡ø?å*$¯Í²(4€ìxÅÒ†eš&2ƒá2?§ºø"Âß}\)ͮ뎩›’—}\~ó#öÖéͧtœVß¿++¢KP tJ­šÃt@:"J/„ݤUî’ªj2yW(u6Uæ^ï¸`fË0‘÷¡37ËRãzíŸö>×;m%™¢&cî¬à‚h2Y[2‹H_Ý’À…– Xš×î‹Xý²Èô3¨.,̱•À-UþGO[%”lene?6›–9šè®6@Á¾Ý¾q$}hNí,ü Ñ…DüAû)s.-"+󣩊=‘ô±5;Î矪æË%8zn}›–-4Ì®œt;t:ÂçšJH§þ)e‚ ‚ätÊ)yº8Z5FŽXînè&ï“Ø6Ô'…‡|Ì)wùU€Ýmp©ƒzv©ë2­Â‹)éÃ"?^΄!3&ääXâe3ÿº?JL´+UG‚ã”üÓ¢zv‘‚Ä÷C}°uM)¨Ÿ‘‘fÞgŽ]†iÊ” cÎNëoÂÒÚèÏá¿íµÉ úþàl¥†Ïýg„PŸ¾Ê …:ã%±3wÐ  ^ˆ(¶Æ- 19K.¨¾Ïvüž‡Ê5ýîÒLn øÊ 19qG;œÛ¬œ /œ#ÉÖ#k¯b5¹B_´×ë1¨|'X§Ád;V®¯ôlÔ œ¨ øí›u«FøÊ—½e7Û߇šG‰Ú¡†0rû:ã¸@óókajAæcËðA½úÚ}Y«=ËÕ*}ϦEL$¯­Xø)Uåû‹ë ƒ–ì`5ôK]­¸´á*y#YÊuU¦ª:eäötÏ2g¬¯×½U/¿h—©>|P4×ö§˜wg©ò¢éˆR|U ±nrãq¼IDÈܼõ·AZ§G¬ÿ°;VåÊ.ú‹çôÎãbÀñ:PÛP[ # c¡bˆÛðÚ5IYhÒJäœb@É–~¹jüáþÔ?~ WÃÔÜr”ý^¤\~Ç_¶‘PŸLc°hÓ©4Ë;¢'½Ž  až÷¦”Õøâ[Tž9¾Í}ïéŠ£Ž¯õ9å{U­èB‘Oæ~ùÈe¤3oHÖ¿!§1Å}ÐQ±m1Ô¿àÆé³»;M3÷ϼÊFŸRB¥…ê¶ܦ¢Ü^Ææ2àþˆN6ZÉÍr©üÿ3߀GáGÔªÞ1×8ú6:MN'WubÔ¯Eâ÷²f#ÚÊÚÝT©$ƒV¬Û}˜1WsÛñ‰Æ¨qê…BV £z-Žh4¡[ùgáŽyiWÎØÄÞ‰ê ùêUÉØŸ¤8@’@”–|§ò Çˆ¬]?Â+ÑS¤«3æÅaN0‘‚¥#ñäÌ%¸ 9¦0·x¦Hì°K0Et5¸Êu×ZŽ^£'²Oâ ˜é4QqGšá⋼jC™ævmD6‘¢ŽŸE»ªÛÅ„"6ýÆÖiŽl„t „e„|¾fCŒr×Äæiá]/ågœQ°¤<5™¥Ã"Ê|l?šK›"ÿÏÜŠ]ú„ 0 ¦ñ‰—o>xBCY~ÕEÍl ×ε GC¸@»*39Õ¿ßC¶G ã‰h×±¡˜P‰#n«}¦’®ÑV§ŸKºÃÞÚ«¨ò Þƒ/DÙ¼´u|—KÜ"®ºT+Ÿµ²úc§~邤Ð@Ò¡IË— ›÷ógô›ë+XŠ!`få"J–ѧ€{5_%Ýd‘ÆUؘ9Ƭtj}‚VpûëQ<Åâ®Ç!ã}Ä·ñc+½±ù%[/+ Ñr… ¶GKŠOÐ:ÞÿäF(~ÎšÆø7uD¸£ÂîÆý{ä[Y‘Ïa’Y¯ ‘èÜk•Z =0½ÌÁ#p –¬£3®À–¼Œ¼´–š«¼¿øTéЄõ'’³ÊË·}Nl®Ä‡ïª|“lî9ôaˆv™=Ô ·µ†.ú9>Çn)€ÃïÀ†7`ùý®¢¦[Ñ9Ðééõ´uÁÚ7ùyæcdè6äßLËþút´0íLYjMbA,˜™»4%G@|Â7aQϘú›N‚,ìƒRgã‘bt‰[wu9÷‰5ã2H/úWËä7Å7Âm£qêÂs`K—“ÿ—nkÜk{_€¼¾Š) wäípðVªY{°lV7¶!ñ¹ÑÉé—˜U$±(iÌïŽfè±»«V\)±¶ÿº:ï•ïxL²¹%V»JLH–è¢eª­ €µ7¹ÖOsuÉÚ2-õÓ€qxí¬(¾|jPž•­†Ñ‚{ßVfDzü,Ì=Üè­ä•9¬žÀ¯VªÓ‡ÕœõÄ;#µÇ~«…3'=Út£[b£k8ÅÎKi¯Ù0^RáO T5yp±ˆ•kG-^€£esÈ¡QŠZ°lŸ£TÃd~±Eœ/ðAÏhójѧ6U6*‰ƒ$aéW$…vͮޓ¯/»K“²lfzö ÇøPËÙÄëЦ¨œX±þüðõU”T¢¯ä7ä »25œß›=(Á1ÿ®ÉoY/MQÝFÎÔ©î—f˜ÕñKò±‰îp¢Ú²z^ú}Aˆ¯|FPe–v’zýTL¡OÑÚÂÒÌçß´ŠJÞܽ'FýPû7»xhŒCóyÅ„^'äoª×œÑ5¨¥»ó¢OKï³ËAžvFCËMtWîÏF¸3ºáR_VœÛªj½`(aZ–.ç\•±u ‹e °Î_\‘¼B;Zø2b â‹ç¸îèr(ÝÝŠ¤º¸'êÜõ?{å• *ै€*AÇú,%8%·c´1Ó,ñpº$úªIBÂp¬Dv ”•¦Ü¢òúÌ;ÊׄŒÇç£{¸7¡:³ÓôßòÌ~1Ñ@¬(p4Nˆž7MZ0ŸÀ¾ök&G-jÓð= ƒìÆœ®@‹ˆ¢km±£öP™ƒÚoÀIƒVOýk»¬2¦ºzsÒ›ç]òæø¶Ï î¨I¯$w9¾ZÚ©ÝïÑ_’&™t©Ã+[ ·<:ð<J Tºf²F&ƒO)ͯ„%öf4.F”ƒÒWbÛ–ŸD‘X-`ê„V"Y±“ŒQ÷¶Ï;7DúÒ´òG—Š®C·eD2°A'1)œ·¾?Ä~H&HðèÛiúT&WÔegjiÍñ.#±±ÿûQðöF¨»m'Xkw ZYGbÉŽoÕN7–]ïºÍY èÉ/€ÆÂÈ@—è¥7GltÕzõ¤Ó‡ÝlžzôiNY nkiÏŒ›4#À¸Ô ˜B=}SeWzy‚;BÔß© âm±)WRÁmˆ‡ÝB5ÁzÔkÇGbïO9/ÝH_‹£°'œíðh$Oݬùzйµb¼vÿS%7r»Rˆø|¤å³Y‰ÜàÔ·j¨™Õ¥‰‰¸¢Õ ³nP»Ûé¢`dÂèQ‡œ^|m u¿=“§!´T¤ºo{TÒÅÅÍ¿C-…ÀFOü&ù`ÐyùÑ·7Ç¥LVžV¾4'0Ùú÷ßcžš%Þæ:÷Â^ü®¡:?Gæ­°\©wi $ÏfG,@XÆE˜2gs;•ñ/š,. µ%Ç4¶:é¿~¤TKí#p‘׫âÈ àiFïâ¯5ù  ŽÅ®}ŽÝ‘àí‘ò6ûŸbW¶Ö,®_p4‘”òŠãgàÛ+ŒüJŸ„p¶¯¾u3Ĭ‡hßUžÕnµøY7f{Ë·VØxtŽ€õ ÑѬ?a)·$w,"8zs?Ú î›¼ùíÛíSë`ƒÝ|“wëºÙ;Å~G5ïQJ¢8篂“Áü ¸—ñGâ$rÉ ¶ÝõsŒÇàß 6ÜÍà[Haígww:{T÷C°Šl4M6{±ÝÔõ©} åAS\ésÔ™n~ú}ÅÒãâ€?F\0ÊqÔY,º¨ò¶ÅŽ_¢Ÿteëò_ôLÆ+¼ˆë­6 † ¶?iÚúVôÒF+1»:/PZ·¢€ åò=ΰ”†æŠ?AKH=|¤\{2Ò×!>y…$/"6ñ6â ×D>ÝND~œ¼ð-³¡±À î¸òÔäKä¹²Ü95w’ǶÄ…èF(Î×E¹ó£¢]ò·§ÌRSÆ’°Û¼µ*fI<#«,†aÈ-EHf©ÀÔ\¸IæmkB¦EÂå/š.ÅèîGF(ˆMJÈj]±#t3Ú ”Ø/\ ÕOBAsÔpôÑÚÈÛØsLàÞÞ¹Éò©Ú?b^·ô¡DKÑ!Ê~°W¬ 3£HÝß<¯–iÛhgss]EÞÎ)hÙ, !zæBŽ5ª¹´W¹YÔñ Ý~Ký0fQ¿GÎ5.d›.·+0ö'›-8zôçÏVwUØÎÊ>®æü ¾ €8g|ÇßÔ"µj%™0¨ p|­_gŒÍcE7˜q-?U“…ª)’dõ®pÑ#%›rË>#WšMc9/Z| lk}ÆÀ¼gÒµÙ€Ò¢öè~ÊÎaAê³8fdù‚(6X§Ï%íw0?Ô—Ò/˜«G’‚Ð J»mx;Ù^(½éÊ~Zq€öÝ$!ïÔÁ‡ËìÆêY~0-ªj¬twhb J[{<&+Û/yœCÙÃ4#çs¬&˜±¼Ÿž¨†m1aiTm:ëQ ž×ÿšsÝ­‘gŒ¿Ã€ìr_Qß¤Ýøôó=w…!"råÃèHò·‹¿L¿–ßOWhm.Q»++ž$ëËÓ¸:¨ÁÝ+S,L™EßyG’°–wo`¬4ëŽó’ s‘·ë’ù”—ùÐÄžq *䔟‰¥1—xŒºG¼øéž/_ˆÅxtâ€iÓUî1›ŒrW”ʽýDÔÖDF‚ûG^¼WÚø.‚zþ»úo÷WTu°-‹ØZ&BÆ¢.˜‹Šv'$Çñ첄[K9?Ú©å?¬ëèoKÊ]ªøMwÛxâuø*MÛŒò޵„jaiÁ¡[¯=6BwŸÂ[‘ïáÅ›x· R¾ªP¯ #ƒ # ¨]îŒ~8볿jUãµ”êö­Éæ*;Æ0ìÁ‰7~lXï}ï×¶;1碽õ¶Ž˜6ä]Èô c,2füÓŸ\±È@m]ÎZõÎ3oé_­´ÉÁÕNæ/Ì4ÜØÓ׊€™ñ»`’¥ÄÛ`mX8bÑ©ËßÁli@Âë×϶³‰PØ%elü…øuýt:¡ù;÷ŽvqÆ´Gþ°³,H2nR9i`¾‚eYü:âÕî{2¢×ì4;b£JZ^ØFR·=&_hkH¹’“bm|.m‹p§À[8ú~ot5dÕ<Õ-Àn®ã‘Sõ*'KÙW}œB•~Ö$}½m|Åè.)¨òåžÐ}P/_ù(VbÇ›|µ3£ä5%B½>Œj–ž^ 6+ŠNÔ 4¹¿ºQñþKH¸ñÃ/§žªœ7ýú¾ßÅø’¤Š¥ä8,òùÆO4#Fü£ê‚`ÃæP™ÐÖ&’ß…ˆ”ªz®½me~'ÓßÈ`\Ãeé>ýÅU9J|ðbÖÓ˜ó\†Á° ½ìuç± Ao]¸mÕùb˜Àôê5‘¹›_`E䳸“M c)8¼ vÔüß⟎’¹ CÙ™E³E8¨)ÒÐtÊjþ=l8v5î’›nýÝ Ë:ã–W0x¿Q–ŽE>&åò«¢ÕϵoiY3B1Vƒmƒ²è¬µëW§&™r´9ÞSȇø`àýˆ¯Ûï}‰Õ¤kÒÀÑÙ–¤–$š)’Û£ÿ¢…TO4§1Zb<·À¹üx¡W–wÀb€g'fªËïãFVîLpù?]Wûô¦Œg:¸Jn•ØGq÷îV§ÍX×Ê(Âø¿°$å*…»Pç{"¼}B¦ˆÚWFy-­¨·á< “e.¿Ð±4À[ÖÞ¥1?æEÉèº9¸ïµ%6Œ+v┩ßoª¤Z[ØÕþëJ§ ²Ñµü21–óü¨Žˆ‹žçìR¬Ëµ¡'j]±>ì ÍÕ8¹>c*´Þ[þ(‘üà>Ó«§f*â¿@æ‰åEì-¡Óðªü¢]ø” ÊR²#þíæùZB€:?÷ç«"BfC¨lm5$ú?O•xŒqTclåM–Xd¦8ëQÞ…x`]Gùu0•T¤ÛáþÎNœ˜Ø½í"_ô[2"«]¨@pa¾Ü•™Áâ±Ö8‚ .§ùž¬·ô§š‡×´›¾pp;¨÷G[s,ìsª›Fc ®Òu¤JiEO&UÐÚ»°ã…WëïïÆ(L ,2 ›¹1n ˆ¬Z¥œéŒUgv=uÆA-¡#Áÿ´ßj´È«ùñv 3Rå­!ÜÆ´l ?¸ÐøÉöÎsß) e1ÒÎwŽýÙMl%¡*%1lm¬q±^‹_óù5dïã¾DÛdÄ ³ûcT-þĺîýÇÁƒÖ|âcÜÒWÌÎj‹¢¼Åb ñvç?+WápJZÕdc†¼e'á/פø¦†ÆjšæÌO‰ÀC½Ä…Dû“$o5?9½¸áí3ޱ/»f‹|š7§Þ ©/²¥•O­«(ÃF6™Îp©ÒSΜí7.»mË @«¸S‰‰AJ]wÙ\lFXßžAªÊu^ˆvW;Êjзa´ P®óŽ?d"'Î&Z$(°bp„TD;)ˆ¾9:ôrôÛ&îµ4ñäÁzöwÊcäíêþ¤J·Ê©Â@UÉ>J`ç œ+‘Úò|‹GÊ’/Ï:ŒÈ…OžSÊ“i¼N¢UêA"!)O«ëD#‡êxÃ{Þy_ô'¿)ZV¦ÈKˆv£Qæ–VÄBŸ[k>¯{©“*¨F؉_\ðý. H½_ ¹±pµZ*%ïc wJÒRr}µ¤æ<ÈÙ…Ãr]é€W™3®ÞÅ¸× r M)O^ÊÓ¥_ ù~»Äµ [ëu AúB(C„èâ\‰fÊKbè9.üÝÝ­½Uxó%¢X±-­{ƒÜd/ïF66K®bÇýIx;®äz¾‘¶°[|øº€upUð@»ª³YþæÞ}ñè0æ¡ù½’4Ñ©ø²íh|d½œ^ ¤ þFg4|ÙP1Ùfö†V£0syÄLü . M1gé¬j£…E7i»›xÆÖ(úÁr“áºVQå¼Z‡¸$zE¸×”û3ìÚà§à Ѓ7V0©‚O‡VnÑ tMœlTH¦[º>C­p”å/NoýR™®éþþ쮑2Ji(ÿÆ1œÙü=¾,,DYíçx?lr’¼Ív–¡Ÿ~¶ ÁpÌ}qn¤¼ЀÞ喝ހULž„@ÿ(Ä€u§p§Böz“êBhðUm¸¬æ® 諯ø©`EãÑöü°£„Ê%ÂiÚ@=¯D>9ßF;žšÏ½›ù¶£A5¬Àc>]Rr€ópÊvh^+HE4#ó¹îiØO::¹x¬àš¨œÕà‘µ¯»h°(jÖ{6ºšš©Ä 5A %¼ðø{¹æ´g™õ4ä@„BLüxÓT-ƒahõ“mEOI”/[Æ£uË´Áh],5õ3’#7˜‹{''QzšÉ´ÂŽêæ 3Ÿ‘‘*–…ÚIM+;’ŽÝµfãáïÈ$„;Öɹ¹º†™«q24+7œÁ"¾Ü CÃ8/Ú9sÞ4c°`3?UÌiå¼zSl``äž "s8MX#DUw|ßpËt”ZKaTQa«ƒg<Í2·€`áWÛÇTÍ(×—b¸W?Qj¹”+³éæ„€èk©áî>§ .ð½ÂÕé?”A2¨s–à³=Y×_å4rjèìBü¸× ¦\³ÜÍÌáô'vbË:Ít–iw¹±ò}hY -Äëd$Õ¬..á…ç?ÎcüÍë0×ï™® †“<ÙÖ‘]6I½ÙèÁ9)ïêíÈQÎÓ¹ñ:Øò:ñ­™—b'?bEÍHšeH¥Mžâuý’íKDz…Ðåoôb„cy&¥íôxµ ¼lŠF%QÔDñÂD ,®Îêzoêb»ŠJ ³'$&JpT*:u-f¶^îÑñ(£pX¨8À9¢Ü‹²[»bËûÔ(¼î d³Ôq +☣Âùrw®¢o ·¾Õõ%åt¦ËÀöà”3)&“\]LdA3óAÞâOÒðL;á‚zmS• ˜´{§Ñóg7ÞŽÐ>GõA- \ñƒ$©÷\A?w*7ŸÐ\«w¥çì}MŽ"§¾×É ;>,¦7Iݦ®òC«*vQ`)HNÝž—[Âëa&=O0èý4âRÙî«6âÓaú›Ða=0f÷åê˜++¦«}¯ƒŒjŠ%£b3®ªe´øŠmþ–é‘é£)æ÷âælÉ´ Í¬ëqدÄõ(¿,«üI\á¬Tý3ü’¶Â[=¹3›ðÉ"–…‘åVâÅþ¾0g@a® EÉôXxÉ‘õË`³6rPÒÆ Ð vøo="¡Å~•Ã_Ê-´CÒ!·ogÂUf®w+ê‘ßnbwîBqxÖ–LP.ÁsLâ/»‰£Àh¸4Z8/êü,Œµo~ü¶¬ùåX‰Æ3“û€!¹EÂ"ä9%Y6­¥Æ/dÜP\n¥"ØŠ—4 ígZÊÏ 9Ôo' UÜ–)Èl¶,Å7zKËç´IǦ’¦EÒÔ1î®ñ»Ú“—Á$nøþJYɦ¤ÐOµCLôò#Ø mØ ²Â,‰Äb2o??:U¬¾e¥æ®.ýà¼À ,託­©Œ$Ue) ²‘ƒ>B—¸#Æ{ùÛ°5×£oÏSð–-ãžôg½ ‚ò°8¬“mþr|äžt1¼ âÒú¦B€°Ð‡gÿß^ÊìÆ×IbNé1ŠkÎLÄì²± –à]Õºv[©&ccŽèÍÆ9û ‰¼¨B£Ýò#§'­ßî‘R©þ›ˆú›ãGò¥ £ýÜ)£JtA­U[b‡æRû"èó­¾Fß|æðÐØ%¿½ndpÈ÷¹rkiòŸÁ5̲œ©2è> &—‰“DïMþ£·Äf=Ü:C¬ê‰£¾„zs‚X–’ éÀß%É‚û´”8 ery}rжf?¼¤í–ÌÀtë¢ÇF¼Xü^ E®3L•ƒƒ>°Ù>(>­ûã’™pt9 ”h‚Q-IÄY/ ì-¾üH ÌV¹3`¤Ìqn´ø¶eDd)¨“Ja‚µÐ} •°erºÇ‰!؃ÌBUzß¼›|ùúµv ÷6¤ ¡ÎÎ _—Ǥ8WØrX§ûÛÖ œ”™’Óç“=z– g°dñoIVÍI móÉO/ûýù×Sòƽ¯ïÀµ 췸̹ê~Љ²Ö~!õçÞ‚q4Á5 4V|ˆî¸e›£‡p=¾1m÷ç„}+›C#NcÄÏÁh‹R„º7¤DÒ^#ª¯Ù+‚Š2à ø„4Ä •ÛMD±# %üû¿kÝÖWk;h¤›aóT¨R.ßÛw©g^ÒRä¿5uÎÖWQ6/ؾYoë“ Á½¬F:#ÊT³®”'§… ÞHšµƒ×¬–´D`»€ŽcÏ·u×qšè~7Y ∺ŠÃ5þK–Hº .W‘;47x$iz î¶Ë6bÀ=ÓKÛÎÇAÜŠRÜ–@A+j †ƒìÕÞeëVþãZ¹,ã5ÛCXâs|€h´t&åå°\PZMzüÃz:ÒÆ5‡ 6@®‡ôç`íù²:R¨µ;™Gâ[óÈ|•“ÆÚäf¨½Uñì7r¨ÊЧæè'ë´’2:|ê<7zìš[Vvž»¹û¶Šðeˇg™xCö“âidHÿdT«“-ÁMí#M Ù€%1&›fEæ¬_xjÁLrÅ›î«0ü'L“ªY8ž[¡G_Xüp¦±Öå¶ñ± Z¿µ>cŠ*› ²6ñ•b¨ßÝAáßv“Iܵrc0l¶7…ffÌ1Æ|U¹­R ÿ%éÐç“Aƒž@äþðÈ2·Ä‹JŠGÞïY›\•SÏXR^IêSsàvH0ùï5œ±u_´77¢)fXZ¯”ø:IkÑÎÐC\¡Ù7g2b(pÜPã0±WV…ó`©1t)jÐ8•ähGE`eª2b–®z“ºaˆµŸ¢ï÷÷MÈD2lë½+-»P“İM5®«N´áÍ]8ðþyñkÀÅ©¯¢"I‹žHh0j瓼4¾$BÈ Ô­Éד"F0½7Èåï”Hl+ éÐyUÃÍmqÍÏ·¥ÙAçGND𾜥Xœ–·â£"ÙK$ 4faÐhƒè¥j¼V!Ò;7,Rn]E c1í-¹Š£³Y±óPn€é\ ®‰óôagäY¼oþÖÈßÀ±È»~Þlð2*-ùþ M/(QçH4’ã¯x¢–†2@•{Á±Š!RWÊ>­e¯ µs¤´JòoõÍì*s-5½§*æ‰]äžËá#~Þx i?OmÓƒa/¥³@ë³$è–b¸s²!Gä˦ÊzáH²iƒ9gßby?R:¿‹xCÈH{Ÿ˜²/Ö¾®•ÎÒsº[®æ ?3ìaUçN6f¥û¾T*§5ÐB~1é´,÷%¢§à[ûÈM{ÒÕÑ)ÕÛf®íXÏjÏ€¬öñMJÎQ×ò½!}—ŠŒ¦AUXÛ§0¿ûíß›p2*@Ž“Sµøœ‡å_˜Ø¢Öð|[[¨ì9â­á‚ö–<÷²äJ[éCÿx¡sŒí®PóºÀ´]c´ èoÌì{ˆ‡ò@bÇŸ ±×ڨƥsgú%«¡Ýç4”¬YÊW¸ k˜Î=ï*m~2ý”K½M¹”é}zx1j% ¯i†çÓ¨‡É'‹€ àÂjØd†sTÙ´ìÌ1këê„­½. vK÷ùØ/ö­ÒÞ:²Rt»¼ýtÐH™?ûN-­¾ÒŒp+G$•ud鲿1â}i ïà#1%rÈÈSð1é´ÔŠü'ß¾“ìMmKƒ+޼í‡[º‡Ô °PuyŠe8æ] Ü¶öQjæŠ¨ŽžÕÓom×¾¾„zo‘UÀW&!‘›‡µg—«,6%(ƒÞRK—‘ÕŠ<]·‡W¾ßyœ ›Çv lH8¥Ûæ<çâ=L©ÜNG*2¤ßʵѻö¹TƒãÈ<î ;é‚‹ Ûz×Mm¡ƒÓ(Y°®“ËïœéfìÛml·ð“ñ 2§Æ]n ò,ßœ~ #³G›ç‰"{V9o ¨&oÂb|áƒå䵺¨JàAOtÇ‹/ó¨ìõƒbÆ[7`CAÈD‡ Ú•¸ >yÊSlöaDÐØàIâ»7^ÿÞXÿQ ȳµL‡È˜>ήr¤ÏR¦³&êK¦jjŸYÙH‚Ž\±œŠ×5ZÎÉ@û¬ È Žò~ëÓ?‰›„17TØéÜ(ˆNú9P‡ÕnúÃð&4«ŒEø÷#Ú¹œim&†~‹Ž[*B¯÷M"Àå(vP‹ÆÓ·ÌŒse?Ô…]Ç8ºØ+eª¼gnD[O?;XŒ¼[xZ¿¸ ÈŽ-yÉ"攬gFçÈX‘²Ú†@[C+¯úXE¹ºX4°oÌïFôfƒ/.¦kS:4;æ˜véS„,Ö…Nûð:e|/ŠúÃüÆù¹SëaVQ:±Í ÍÏzáF¦ÿËïÂÉRôU ÁÞ-8͉òÂÉÄ_#[æZ²‘ê!¶eJ)‘yš֙ç#áÌc%ay1±Þ±ÃÀßQ3%'žHÊ_U¡dW‹Ûm—Ñh¹çV媿Ü_âæåæ— ܤÈeâá §C¯oêz ¯‹½CDЗ‘“¿7ìa® ߎNfûÇ€;Ñy_ŸdųiÞ—©I½ ~õ¼¾;u‘Ëý¿si¥Š×GöÀE¼-²ýðGúAU`QW^@˜"’b{’`B’»Ó¹ø:>®.îtuÙá« ¸ÆN°K}½ú±èIæð¼ºqçîD’ýcO£s™3k)M‹ìDVÄ¿ ¿`•41‚¬©MEÚo7݋͎é¾¢ðFÙä³aeØ™ãï¿£ó)×g€Ñó’w™è¹`Š­s¼(åIjûäjJe¬(Mdã¹Àm¢ªÐ, ¢0(¡³›$hÍÓòôÀÓãù'Cî­÷Þ_1í^­ôL·YÿPѾØ=”Œüpxðé÷í—•+™RÏ"6Y1ž­\Ýä*µ5x¶”öý%8M$ëIÔóÝ‚L¹†Û” X¡¼˜Î(„ ïTWaZpÑim#¡©§ÇÅû-SJR°K{¨Dmó”÷O–Q/Ó¨’Žî%ß@}©2Ù#NæjU<Ññ¼Tk¤ ÷ Ø±Ü§z§2¿h0S^ÃZ½úZµ¥n{N¾ÎÛn;ä#=Ÿwao/á¥âdû|, F¢¶‰ËGoÈ ëÖAïjðúö–ïÏD’r» ¤$Ñ´8%Žê5A ê6"?ûHœmƒ³ë7l—D'ƪ·¹@;&zê›ãPqåQ{÷ï)6Ôå4P8-j¿5~ŒñbÖО^  ¶àó»|Þ(ŠoGtZ4* ô ~5ÅqAd §ÅaYÈó¦öÇÎàJU„in?I'" Gù‘¦óý¹ÚnŒ?Ì 5jog÷7’Öü‘Š ìÉûbÕan9Y¸ì;`#¹–dÁ«!;ü@ :íÁV~7_ŸÆ÷­9¦Õ#Ä2lPÁ5›¯|)|-˜HŽ^cÇ—ov’┸-š¾vÃD6'~ùü¦ðŽ`:ÁÄÃâÇP¸™å7›,Æ& I9¿½M‹á_“ };iÙ™íè@!÷;öÊqe¾¨ðäê~¸én÷¯ë!…x©÷cn€©…~îÍCë,݇ûToبg€'3#VÌ€Ë&;û€1jhÁ¯¯ý÷<@æO2·,²íyÝ =©^ˆ_N9’"Oº¦÷ÉVìõ5×¥)/3O[¸'îÍ0D†¯~‘mW©x¿jýxÊw«Þ?F{Yv1f•ØYÔo( 8c³ïaL8e€4GF©Õ—’Í &™#Ä+Y¢æ¶¹]ÊÝœŠG^ŠÐ|Û‘’¹âàù÷›rÙ£¿P¯)ziÐŒ&Ž˜ZÓyîõ+äúƒÙä)IÿþzõÐèW]Á÷~A«óña_ãÙq4ó/§âºJlž§J×Ðáò!„ Ê-}$ÏO{LßPX§ü½vhvçN%Òœp 4îFÆøÅ³éÕÔ‡«XfíIðjZ”‹©è;¨ Ës¸¹Â¸ ™Uqö–}&‚žÌxÙ9E‰— V±d§Û i‡,DQóìXë/%Ys¾ x5ê5Už¥Ni½Ͼf:"˜hTÿKŸ»øÔÕÏ*=E›Še$~mڹȼj¾ Ôèøo‡ÊùrÏÿg˜ÀL×øÃ1uíÝŽOjNˆŠø!E`0í°_4GíªJmƒõ`“CLï&™{“ΰ,¾\Xuíy×v`».ÅS¹›qÉÒp°;ÿbéÁœ ºüC*½_Î…S+]6ìœHÄ*Ò츺£¨¬à(÷ò¿?~ìÚBwÏ‚æÌ¤ƒ´•f«³§+ÙÌ,ì’>1(~DíKc `|ýÆu&Æ{¿Ý4’¨ÖÀe¹ÿÿG^‰jíO÷ÝÉB½©¼³å•²úI³§ÓÍ—`Rñ@IWÀ*¶¬Œ%jm™cÄ8¿#Ø^i)øÛE«Õ?È©:g¡èÒ½)Ž2L滈Üų'vFÐÙ‘…!ÊýÝÄ®ÉRsòÕ¯6–ûZâ|>Ý£’5¥/kõ/@½ûly,À·ÈLSÎÙ=7êô¾R)5B^µl}Zòñ–¬öÞƒµå6ƒ±T~±ŠŽÙ­¤Ó4í‰3Áàêè¼5÷¶"dƒ˜¨{, ¹H7F"¯ëõÖÎ~ÆŸ*°Ë…[þh¿ôè'#8‚øÝí^Ë{›÷?ǽ÷Œ¿¯Üéù¶’$ñ^£óäl;Ïf’aŸ‘È·êâ&ZõÍÚwš“’Y¸ç¶.•p×HÓ¡G«5—¤, J›ZY-ֲć’ëQ<\ŠïÊâ ¤sjÚïóvïÐ>mA“-”`ÛýcD²¡Ra¡@¡¹ŠŽ£K‹Y‘©—ªåÿI²I÷øù¬S|üc±`"Hvý)\,–·ÖBîeý­|ôÊÖÄQ†'9æÔÒׇ(÷ª+LTÈÓùp)J±/†Šx÷Ù]¬€Ü¿â²õö4óIóAyºª±ÐÄõ„i”Ðç–¼Ãmˆúb/»§Ö=f¢´žû¶Ä½U<åŽÉ#¬B*Yúþä­ã$2ëñÒËÜ,m¾7Þ´Âä*¶„OóQã#ëžýjÜØŽÿ´IþrYÊyg37wŽyÝš ªcö¿Û‹‰Õðtë\ñÅrtºkµeÏYƒ\¡œl2ŠÎÌþÁÙ.‘‹³ö5égô qPÞ—8Îkvà^3Þ­ Å^èm Ð’œSp>•û\‡o„òh¯À©d».l× 0{&ɶ¶ÝŠý C¬-þLc ðÂÃwµûÔ_éÔsê P㙣0ÿŒÇï}¼ <‘•caZv—ó|Ït±ÜüÈ‚çR°0á½ì‚¡ü5¿°*äztÓË,¾•©G„&+¦¹Ýþì¶îôêŸ &]T^Ós3%Ãߎ³q[j7<ªôw³#Çåé‡ y}GÕc ®±€žÉÔj¡e–°w»ý-&¬ËdRáÒÓÅý·kLGÜ=ˆØcµG%4p>6Ó,Ï64âÄj‘å=Ùÿ’ݽ•hTJB-ý9¬`™ ·ø­AÝCÊrPÝÿ›Ïít‰eŸí0K“Áо„ÔœÞ"Qé'¯TcVíBIÔcÌÝ;žÖ¢Ñ'~PQѰ¹ÑS³”k2ÿÑÕóÕYlŸ‚Ê}ɯY÷m€ w²)Êê~’U v¼Y½'o)è܆ ~(ÿÒÜ{ÜTÛ±°—®Uõ¡— ÕY ;ífcºÔÜþQaŒ©ægõîEM•tÑ™g$CiŠ 8©]T#Y~ÅÕ&ì1ÇIÜÅý9rèÇôÎ{Ô¯§VVÓ…7ö1. ¹eAaw„QTAÐW˜ªJayÆþ?Ü­W[¥Ag%·>EAÜçþòƒ#½Ö“ï¯09ùàsh*æ7¨[û¡X¡|KgZGÛ üuZ:ÁAI¶ß`º`ËMý¢ž9.zi]x÷/eB)ÅmÍWIÅs|)â~ûÏ›ÂÒÏÿ(Èé{|þÒ3Œqî¥YsD¡é$9Õ^ulZÈg!(%Ûd éy(|[¬«¬'K3i<>ô¾|ÉQ*¼ð’+Þm'aÞÜ›?•_ö¤dþ ªxŒöì#£—å­Gº› óHy;ëm2*Q~cí84ÏúO`h¬®í½ë\p$ûs3¯˜µÚ”£"”n˜9†ü±¼Åõ¹mÆ+[†!Læ×‡€)p¿4Q ¹›¯€FÒ哪kíõ oúÉ5‡‚i5¨Ó|ï8õéI(·W–LÚ¸–ùq°Æ¦¼X«Û†¢v´èêÌ´ÿ|[ÄLDVüÊûHjHÁ ´y;¼ªL󲬟‚’j¶ƒO|°tX$j"ºv²@§PJ‹£³ü€‡Ÿ¢ƒ~NDwŸœzåêu7-Ï£Ûôƒ Öæ.—!$|¤¶,ZrRO¬é‰xÉ](`ß”âë[f&Oü c½¸œÉ‹ÝrÂÉ—ý­ÍÀ˜f°ëq³>w‰Õ6\¦g“gE§cõÆóÈ‹šYÖ×|à×QKÈ¡½0Ñ•;¶¯¥ð"˜xÂ2WªM »yÛâéPÊ|e§‡ŸIWåX2m‹p¬Ý7=ͺp.™¢5rÎ)F†˜u½û®PdÇÁêÐ;…#ýžg°}Ýñ¶o›Óóÿ 'ap¢-ÔÄ 99ïÉë_3Fö8¾‘}öVI™ëKZŽ‘!¸b8/ÀŵLÅóm°í•Ï—ìzaï, ÙнfPNz@^ XHÚ30G™ë¢q×_bÇU‹'—©™ó\ô:óä¿Ð•ë-C¸UއÁ¾I6›„ˆÚïÿ_2ÍSßF(l\8Û±7=°Áöü"1ï„gG_¿Æ“c®ƒWpM¬Jϸ Î‡|xñ§gmô–Å1åÐUb¯ëúI¨ yD±R”»%±å7A×…,K4–Û ÑDeHÀŽ õ®5>=ÔÄšñ¶Ö¸K+¶j‘&ÞóžZ\±ÏŲIì4ûƒTé£Hågƒ~·¨&Ÿw4KyÁ/½;¯ßÅí/ Më¼<ô°¦¬XßlB-g®fâ òcâ“)qPj—‹#.&ñÆÙ²Fý+Gå{¤MMáts\ùCÔ:ÒP˜Lq r_<{õ¤Mv}ú•3 Ld¬äSñëÿ_ôDY’Bžé_d8 ý'úš¹ 3Ûa1TÍz#‘+Û#b½Ñpµ Þ«§sJ°Q”Ô÷ Ml+cÁ•U‘;#HÓ B©)£«mh·ÏÌì–dM[Gå%cñÃ@G'v/R4Ч‰’xL­''bÙ9½j.°œ£ì]ù3M ,6,Ý–Ï®\É·|S`ð]ÂÐQžšW—àsjj7¸ù«^½xù—50Žƒì`Íͯՠ'èNØ6I-v²´Å2.ÊÀĪ\ý¼0ÜHÅ Ä(@¯à“Ý Ô…z°j­ð¨'×ó(Žé§$ºVfXra¼ŒÜî Løßk¹bòÎà:Ñ®(è“a* AEëvxÄTÐ3îuÚH˜÷ qe˜’²¤TD¢I¸…¿§pŠËÃK‹ù9‚J(d•çùc¤?¶m«ÉÞ|ÏRdo¦¶szæýÉÆ"È%HeÍGøêÎv6ÉôŠ;R,¿ìšã)Þ4.HD+T˜îw*·"ixmÒ ‹§DEö»žÐ‰?¾ ÷Y^ˆ†û\ï[UÞ!B´ûö-æò.wÒ¢,8ô#Qó^pYú‡ð¶¡»fWÔŒ×fÏ Âݧڴ·el3ÊÏGíÈÏ£s¨ìºI±)Á.v8éì0Ñ[«\€:¼ƒÇe«)ælgÚ›ï#Í"-@$fƒî#©1zêY0ŸS®­Š]±¨G¥=Q ¦ù’˜afò‡]"·ËË‚Ø\ì;þó?@"Þ±¦*\¢_2=¨‰×ǦUmå³àÓXU}.Ö¦n¬œ$9 ž°‡[Œþ©m±Î+KE–< çÔÄâ¾ÖG—î LZâáº#mÀÉ·ÍâM›V=Q]ü_ö3/ ºb%n®’=ؾ $fÞ_{`s4½¼T¾mrÁȤp5h{–¶ŽP”ÞzNy—7è—’âkè—ƒoWõ“ И‰Nºy÷ýý'âUQ(™ìzÓñAý¦àZ8–T^Q.}óÙn@…  D±4˜²ƒ›^ẼS‹)/üߤ€(÷f.qÏlÓ„y¹1ÙjÓÿIw^I¦v.À;]“V„‘ºžâ!B?m†ü@›‰IâRWšºßz–Ü‘ùÄúÓ¿Fºø\Ú; ^_»ÓGX¨L{R\K ºz£êÅ(Ó1§Ø¥¬»ò¡Z§£½/9¡·öY{ý|SÅfö[˜çˆ0}÷³—¥8£ª„Žƒ] d+rwaD©/_‘ÈŸ*S`&Œèƒôˆ)â6G‚€.# ´–Õçßs´½ÚêžÅfÑCOXU½k ÙC<÷ŽœrýBÆ\1ðøÛ6€é^;/¶h©¬uלíF÷©ÀÁ·nÊñ¢ÁÀò¸»ÔYûjŠÉzPVë A¡·‹\ÏŽÝZ„ìQcµuðO)©ËŒºÍÆßf0‚< ;ؘ·à“ŸR±;~›QCo/ÙWÔŠ€•¬©!¡üq4¬ø¼;}ûV຾{y‹¥…ÌÁáÖe»ºãå§•|QAB û—¡ºÍbÑÚHR¶åW_å¾§îXüÎplØ¿š!YA˜sàÂ}ç"Òì~YkL»8ré0„³à ÃëÝ'¤ßšCmÄœ"ªj‹jÔàlé¥2¼í™Wú ~yªÊâøa¸6M±b|«—ÉE±f~ÐáeÎ °¸E·PN ¸Õß~çX)Ƽw·©žvO&ÜbïùŒÑÅÛv­Ç¶g\•²_ÕM)‚ž¢göŒšA2‰ÖŽ.¨ PY"Ä•PǘúÚÅr{¼î8Ó˜Iò¾áÁâ ³/‰á/ƒ˜RêÚT—ˆŠG±gÙæŸ ϼTŸ †îbÚeêÄð˜e½àD‡P[@Þ)Ï|4\J_=šê· Ó+Õ‹ÎGŸKXÒz³¡âœí¼VŒ,Ë܆þÞ®?¶×©-«Ét¸Êi9Ú«ZÎï¬u‘ç¯%÷zšª´È4à R¼RÁ~?ʪñªeêºä‰Y׃‡Z ÅÉa :‹Ù†´%ÓÖgGƒÚ+ϰ¬êt €NæÒIQ ¥ëêÝxÂm[¹DÆ[Il\ÿºÀÞV!À™²Acצù˜"½BÖ½É)¯~xXNB™ƒÙg¸[ítOæ=¼šÅð"ÁêIJv£¶‘=Ræ¾g´õ«rB<Ò ™5ŠÆv÷ëÈCkpˆjR²æ Û±wܗˇY¾18€M„ðŽ7{¼è°qù ¤œÅ>å”Ú]<'Òñb2›îÙ'¥²Õy¿É_'À´’4 ó—Lú ¸[°`· x;p²ê柧_=*zUÒ˜_¸>‹ö-ªTÍ:ã˜4<§ä]Ö4|-¢›IS«Ó‚ÿF)Jp‰¬SÊAtú˜ŒVÝèÁ¯/Ððù3àZ3‚½Ýe©XœÊ€þºjÏ{ ֖¿ãŽ­¾–³L q ™òͼÍ#k©˜žß 8Üs{ôe”B¼]'åh{„ÕoëgZã‚pÆ:‘=_ðýºØ©y¦ö¼7¼¶×ûaZç20˜²*¼W·*‘ºòE"_ñŽTì õÛíëQ¶Öuuåš*@‰šÉÁ®g™#Ìd> ¸èfÄ`à87u2Çk©KÌ<Â7(òÉll¼Y!¡-YN¦¤m“ôĽÛ!–‘ßwu²w£i|ötuÈi¾Y0kaPv×ÜŒ#3æ§»ÂÕ¸ šx¬zóàYc+‘ôÀ(A9ïVìh!±gE!%Í QO³ó5þ#Tš"÷×72…µŸžþ‘7þk¦ØGÆóìUæ¤Q.–nÅÈ0½hÞar‘†w:©_šS§‚½’Ûz×sš)=FÁ&«-±$Ör›=ÕÔï•ÒìjÏBü8(¹Æ@f3V×6ãEÀ)›¦ý`胪4_´Sç¦xüpä-ãü#b9½Ü¶¨Ó³·”˜Îή?!Â9öIFF3аƒ“é2øíûÕƒt$•åMk¨0 u shu(F« ˜ Ýõ+AmÞ/Ñ‚7bå8 “D¯Ž5¤“ΔΕC+³}ƒÔâBKU4mûòßúA‡P²‹þ¨7–9“4!Æ3÷”~j 'º-ÝðRÙËäaGŸ@@`O y6‚Q'Xï…ÏÝ»¿ïÎ(,áªÄœ9:vd ™‚9眰³ÎàÈË“©A÷Ο·w;Çóeü>Žî\Q½uí u&lQ^Ì¡“ ±}Úç²qû·ž”|œÉŒŠ™£WÒØvÐÊÎ}<®ô?x´ q íšõeùJ[E2u±·;É–¬Ä9ÒÎ! õ`Ò{æ°ákqñk€ægþHäc”ª!Ž‹„LÔ»§¥»µŽå¯/*8Ú žQdß~yˆÑöià”ÐâŽ+½ø¥ë=ÂÈpÆ%¦{¢jæ^Ɔ~Y CVè¼äXãEÔt ÊK."3&²,§àá†o˜8dEÄRCmÈr¡Öš,n‹Ód_ ¦…k’,OîYr-3Åèc 3%X-äÔ\—]!.0?pI†Be"Œ§’ÏïïÇ «K7(D4÷ö§¿±–û¿€æY_øϽôF 掾<¯&=LH™~ø9ŽLù¨ýiEýü=Fì{8·Gö]>@ìö¿êéäV×9oö~ì¹qi“3ÉAú0µnɆ⨧X•~i9ÒðÎTÅ5ÒÜâšd´Ú6Îb½ù¾~Ùx^6Ò Ôáà,÷¥ý¿Z¾ÿ¥óÏ·4”Ϙ-ó2]8Á 9Ü¥$Ô‹+$ÎÁ¢Ó9|©ÐÙˆ4G•)?I¶w’·ú•“ }œ!’Bžôéy-û¶08‹wSÛê¿<. ñ\^,…ÃHòe$?vo«e<6Ÿ`’¢©ü…v%QWϹÓHD$ÙàlÅ¢óT,S—³Û¢Ö"ue½»=@´k›ÃðË@Ž2ïö8Ðæ‰ýqgî½,nmºI"ƒÓr㓎{ÈÈ4~e‰2<´•´UЉ×0#§‹q7!ÔaÐk¤ñäì©ë o˜Q¿ °f…:²ø…ŸÃÞjO9#ºYMüBAFl\âÙ3A)Å,F?jì„Vâ\Ÿ£|¿ˆe¹Tn÷½³þÛG ¶h¢‰ëñ ‰ÕÈÏuŽç¤Ò"¿žwH°Ò‡LÂN¨!0JµV_Q6e-µ¹È²:aáˆâ“;ä½_-0Ø® TÓçâÂAVŸB?”ñb!_n·ÿÜQpirß–¤8b/Ù¢Õ?l£®Âî×LKŽºC†“¦rÑÉ1çøÅ1¿š&œ&,ZÐq¸ÑTnÊé+…~åÓî ÕŽÒТÕÇ?y+·¹šµ“mÇl·ËÔ õ”:fd{­ùÙpc‘¡ç½Ž´ödšvÆec<à ^ Ò%ã)¡ÉÓO©Ýù¡ãd¾AËw¹==Z.%Ì_š4£D 'ç´{iã ˜Óxºñç@ÿ¿ °X$¿®I?4Ñ7Åï= KËãì8÷!ÆqøÜäuc¢f2Èï×þžîÌód½T1/„¾w( ÷«ªµ™ïužâCbdà#ù¨ó²é9ÿ±K°® û³ ™Î ß<Ñ’^|H¹Ñ0÷.íA÷êÇØò3"BΌР±qBÈ;sñWßä”çÛ]¯>cH+5Ü}²Þ<‡úÕµ–Ñ8;S¹OÃ2=/Vª•ã§ `IÜ@ïÃØ[Ÿ  HDÖí Hà¡ö‚á¬}Œ˜qb»Cßñ/;æ8äk+YêíÙÜ—]ÐL}åµ3xrx€%üº:}5òÛnkfmâüDÄÈ»r–°‰Pû´«T^’=ÕáIYKÛ„™±ðO‡x™ó‹}gXÿeª6 ±FÑ “èÜ>T}öCá2°¾aÑ~` ¢¡^@ÈÆP­Xm?Á~›³Nô¯\] Jv÷mÐJ2K0(Ã{ùRS‰?_™H¾˜˜‘Ë5N8Ÿ]‰ýݵ;«MŠövå`SOç3¥—92¼­·>EéþWSy›Íb $&%=yA³AýÄ)¹X¼$1ۃŷ­âÆ©Ý:èEÉJÝ}¾×;ÃÃj ãX+Ä&ý ñÝB7$ÛU}¸Žê:?¤6'.6¡2,|FBiGO2±E’tÀ׎4¼3dâõBu ï¤à=;"=yÝ.ìýGA¢œ%c2!Ñ/§£DЇ”ùóU^JªGÑ›¤_’³âÆD‚åžÈu"Û Ó”ç`¬[ –áAO-LcŠù/ˆ— Ÿç;y®QR.GÃÊÎV(©‚X}´å†w€Ÿ{)ˆªü$¥TÚœ¶*)Æã q.™ÿµìLö÷’I¸IË|6­)Xž6™ ߈ (ŠÎ\>Ï¢É!.®ãtºu LlÃAƒ½°på<a5·çh6 zê§0\¥4"ˆTKÚ\Ë{h^ì–1JÛÍŸéjÏ¡sNÛÅ„à67oò0ž”H©…˜é-‡V-‰?ö<)†,[–ƒZÍ |`Gƺ§8¶¹F¹¿G˜*¢%#×¹–W©BÆYWµ¹ž£–ÓGcsx±©G›ê%K+ï²¾ƒGªítÊ*>ñ`(µ}9VaPì:}yDvÉ;‘„'ÏîÑhb+ѤO… 19—×·N4-óiãRöÊáo#§è~%x(8Ÿù²è‡ï¥ùÙçí€(œ]øÅÂ~x€”„éV«v †3œßµ¾wCR›½íuÌø—€EïZá(3Df3‡¨ -DC¡ÿƒ± êbA“Ä|Ê"Õe^ª¯a¢×Ã>"I¢µž<1¿á?Z$;ª÷ÀŽó6.I ½¸XÞA YfófïC1£¦*5áÝĤ)èÀÐÙ`¸·´}6 Z]ýÆ9ÈùŽbs†¬xSæ%J'¬RPRâqÂ0q°ÀxWý›ù‡”¿5 /¢Ÿðç$)ö YÝØ§wèÏ@šˆX9&‰±+i(að‰·Í›Ø§b×Uh‚‹bèÏüOÂJßÖÂ×´ÜAƒÉ5ÚRnyŸ‰§9¨¸×éÿ£›ÙWÊS 8te6@²èª Rj³©¸=µxM*p\ ¦ðçW­Õc.ÈQë($!‰šøïr… B\Èbi(c×–—«ü„¼„kÁ­ÎËrj&¾¢Kh¾ƒ{‹Ã/{Ȝؑ0a³ê?¨O3_§bÐË¢;ùH‰Ö\¶½¯lç€ì<'-]ˆoiRØï;°Ü¦a»>N#¼„¸é½’S䣘¼Ò7Ÿc~WÓÊ —OO¶B‡Ò0Šu‹•NAd7wú•»“Æ=Pnù‡êûF«ßzÎñqU»µ‘,3xëºï4 YÉ`iñóëVÁh³á¾ª#íSY°í‚Ã_˶@ΤœÙ¿ø¦i,źò}þÊU"1â™B6˜÷ö þ¶BŽ¢î)ÅêL†¡,r ¼Ä§m!U¹/o®DPð4‘É ¯j:ä;2‚ýÆâÍ-<–SUkSeÿ‡S;MÎý~ Šßcý¼9#Ž-½2øcm‚墤±"<[ø³ŽêšuLpAW5sªÚ~ N€ö¿Íðn]x[ÖCs>f í¬®w„j}JH-mЮ¸™HgvýÑUk”âˆ*¶¨3yÞÊÙVcŸ(zˆ]‹Ô04ú<|‹ósáŽÔ8©l0„¸39̓î2 — wÔ©5‹é“¾ë‚¥½â5åíø÷f•ròŒüVEchÌaxkÀ±ûnô-ЇÎÕ€âsKZkoƒ‰/v,t‚ÒḠœÝ¹°òŸÊйF¥¹VVÃ&ë73œTA—™5esŸÝ.8Ýï¼(!@+›‚ñiàšÞs#|€ý‹¤\Èá‰ö#^5)KÓrä3ÅéÆï~ñä9k›¾ këP$ÜdWlçåÖèþØ Û_ð`Iq¡G§ÚýÄÐç÷ÿ Zã_œ2w<a«Tim«®™©‰Ž7òxÉ¡†eÅA4‚ͬéäBÖ1]™#ë`©øI]èÜ&ƒš.‰ŽðÝpÍå[ë/¬€&.´Cb#ç¸Ò{{x,°A:à±ë×LŠQ—òœÔ]+Û_ï}­­.Ì žÔ\ÍìÆ¬$ïÐCES(«÷^ƒ§¿§–ßöª@ŽR#ãØhf#ºˆ,;¤Æ² xOì-%Tã R¼4b®Z` “gìŒ%|:Íì5q‹À›…eû?â[ñh-¦ÆNŸ¤XuÛ˜´ÍBÊ›îw4ÈŸ 9¥CS€Qã‡#‚L¯ â:ÔÉÒB®?Ýǰoæ¶§¹T+ÎAîóAH˜?Ÿšblö÷炪U„­ùuZd39¡ß¢ºP©X‡bÇ‹Yž=L]¯mQä·1¼ï5¦#í>~!`üÈC±B.ž¤‘ÿô9„€Bš±HÐ:峪“(hœßkO* hÝfó«COºû]ͯè¥û ¦Œ§ŽN¨¦WÞb("ÚÀëHÌ¢_l˜çÊá8Ðé@ÃVð!ꉄóIYi®¨›š­+(™×…80Ÿw#:f†1‹k+HdA÷gϨÈSšÈâîåš_-o|i€þgdíˆrÅ{¤rß%Î, #±y½Æ ndõDQRÒë¦GÉìLG@P‘¤(’o~ícmÝIÖØ 'ÍUíÏVhdZê,]Úd8¼øÃ¡>‚ñ±ÄŒ¶Q•éæ–”éC/ïýùðTRe!«ã¾¢üSûfÝFTÑÍÕQÔ 1•Üž5µ•ø¾¸¾ì&K¨Xq·t5=J›—¿ aÔðƒ4í•$Ü@·F¶-Ú¬58a•/ £ƒ›q,†ÖK…ò˜m,Œ¿W[¢°n«oúƒMŒ-sÅ> eÊèºññ2MÐL*)ËH¸$(»XCÍÝŒÅë9²èÚ»´2 åùŒ¹º©bfétö›•Ë ¬PÎtšÏÜâ]O]УUéjÚ.ÜŒ•öÈ(Ï¥—3§:#Ñhè†e²a\+@¯1Ö‹HW¶Ó¸¡¶=Üô;V&?1ÇùÂ;—xxKà/ÛyPõ2QÓñüN^ºAãìøuDØ·~: õKöÛ»h뛓šlÒõK“3r}`à~­wøÈ’·žšßRMôä²8Í’^Ú›ºz[Ašq‰KæAmj€§pwôB³ÌX¢æôœ^€8Håk[ºJʯz:Ü0Àö}ÂçëÞ‚.ìru&hóìLeÏòôäoG×EÖŸä,æ£ä®×Ž1ï (€Ã|Qyéâ©îÉ&“†]½yþí8xŠf+šRÇþ9¾‡“d×´D—ò(?P”×sàf$z6Tw2pP(U¶èšu-JF[é¨ÿ‚é—¨ra[Jû=â $Ó°¯Ð«ìæŠlJ£W›¸yym˜´×­2uxñ'‹ %Gžƒpnsv•v¤ ~h­Kà¢\i¨.ÁyôãoÙ/ª§‰£À{òÕéEk¯önj‡XY1ýy¸]Ym­-R½†Ï{yÿ\}'.3+ GƒxDk´µÊÁâ¿=1~œ4Õ„6”oQC·JŽáåŸwÈmšC‘ˆ ¸‰íYM«¦ù`Æl<îcú{>AºŸ,Ö9sèBGÔa? Ìoig›|D³Â$Ⱦô9Oh³tŒÅè1Êö/õýLàÄvèMDű|kÇm FåøŽ˜€¾…bÁ‘8+Â>?yùäÀè)U7íþZèEUÅýÜt`—.¡kŠ4z*–Õ-­òúT„h‚qp ;$»Ü«.&Vò©Sðc&)èD^ܨ³ø®áÌ•zàë·xÆdDØ‘:5Í ÅæŸSލhÛ·MK_ú9‘Vñ=sz_Ô„¯íA/–T(Ä>V^Nnš%ÒL{­™@g£}”F¾=í0ÁwœýXO¨¿ž°”óê,vɯBoýmì~âW!Y¸£le­ zdÓáT‡ºÿa lq¹2ï„Ã¥…$ÊäÝ„›ßv×e XI½‰áŒŒu’CÀ Bçý¯ðݬS3À?‡Îñþä·.v-™¥Ô¦Ýݳï¼X€þӱų¢Ó_Ò5ù•c_KoyŽ”©Ý=³ðgöaÒ5·•v÷uÅÈÒCóácƒ{±QgÞã`q¹º¬º=^»Ý³„Äoô­÷T7¼ŒKÏ{ØD`‚¥?¢¼Ћ&¯”*‰‹Š™Öú…÷Ì ¥%;õ›tH±~~µs„b¼ú o8!âõXn\³©Û¡ÐMÏEY<]Ä[Ú°äc0{,ìúA¿ì¿NAv0ÎÎ\JAÀ8e—d¾ùö£b‘“vXÀÂéÅ‘}wk[0G¶é¾‘Å÷·_­8îGK’U-Áz Ó¿jiÃPÂЦ`± çsÄ9¼¨Z潜¨è˜ܯ+š[ÎD–œÎnDB2èÐô¶‡xû‰òçx9§|VÚí¹RNe܈X¦û ÈNüÙ#º,:L×P 7Þ›F…{W¦ù*ïüàHlÒÍŸ‰²œ9\bò$ÖÚS¹®Óf™™£S ¥_— R#»à,Î ZtT実d’)jëÌ,úŠ0*'8äfVû0bÿû¹§aÝçitÉæe¶ØÖ;9×rîÿ$ÛL’z¦ã_’)\*‰ñ*ßR?à5G.²~²T¨¢öÖ,ý¡%ôS°g„“0QÊ5nrëG \×K¯Wx?5ã Lgvàðo¼šhûl‹÷‘`˜]š|êÍ-ZÓl Ë®0±ã§Ê=Á^©ãs€rf»$\m4Že¬ÿ¼Bû¦¦Õ»d(³ø:ôsZ xDºQêiЩÏ"•k&|$hg1„Ú}fæËjš$óŽ‘û $QD˜^{’ÏÐiëú4?JàÑœr3éméô6àæ÷¯zƒ>š°ÊåÖeÛ¹ úçÖž9ÔµÏi,ËV$k·ì]¥‚" Nt+¡A½U8zÄx¤·£ÓÐ ©e5Yaï·Æò‘ãðïqËQßÚŸÕ×(‰èEª‹ÄO«—fÀ·òoaƒù|]st4л¼8\Ñsâf²…`¨Ø1ô7 Q Tá;VR³•nTûs‹r6šíÕÓûø§Ûì©ï4„yˆr/…·a³x`LÈ2÷ÑJ¥£w>K@ýî©.}ܼۃîðÆ|J¹K÷Ãn­jÓ<ýMâô4 çëp-Ù³×’tF?ûDkfò…„ñ\@Ôqÿ!7ÔA%ÀüG÷‹oËÛቊ°g£ý˜f³Æ€/y}þ].Ï;érä:šÕlªQYïh¡Tß¡;Še™Cœ‡¹öo€ÉÀÖUEÀâ§¡öù5 XþuŠ×÷ ±’üí'AlÀ­öWö(Þµ ašcKào#‡ÄÑ› ó‚áðû0ÃÈQYÝ+{þ©~É«ÅbÄ;}†@3úì' Ä•ƨÐcpH‡à¸ž µeåÏÝ36OY„Þ~…ïv²h^²Š£äè’Øx8 ÒÖªP[8ËDB²Þ‚PèŽ>u@ÒPG4Y#è¤YCZ$×g ¼}uNÐ]‚©pŠÜࢱjc¼Ejˆ8 íC?Íe$RÒ ƒÈnL †4—A@$i†²ñ¬¡ªéØ:³N:úËNkÁ§AÔ÷ãÕ<ð¶„¥¨ PÍìlZZð~ìטÌr¢SÇe{¦€°WVØ?ªqä+UÓ|bœAÓMô#k*p3ÜÂάƑ…W&¢iÀCRg/°ä’û)¥”âk§oö(m~,Qáîþ\àSÂ2 M\ûyLS!xÈ(Ù¤øDáñïlô¯ûØQ}/&ÔF¸±ÆÌ;€Ø÷{)zšdŠHŒvæÓ³±œŠ°P9aÝ-e£ÅBÆÀ…È_éfƒ®Œ½R°¥§Òkž÷:‹ [wÊ@`gI5ô°ÎèfúÅry_dÈ©ÄcïÚ‘¦W´ ¹“¸¦”ë5§ì\L=ïz”幘GÜ"›%W^ö.‹6¼ÐŽá×¾ ”ƒ‹Ž@ø«œ¶B=|,æ#ÑÞÉŒt}\ÖŒÊ<Æé)š>¿–åvQù„®Ðþë´G=»ëE ŠUpŠÅ•Þ›WMK¾Ž8ï‚D¥«±€PÃÃr9¨ú½R^™ëÍ86ã>Usõ¼!Ù“ˆpS‘sN„É oå®âÚæLQ9¼³ßN¯0IÀ58Z ùÅóh°ëßє렿)6A£Ïìp‰œvøQÎ4fu¹ø l®Mš{Ÿ9Þ&Áhú¼=Ëu©R욺ý0”äýLq`öªx$;Us‹WGº²â&•pßÄOÜŽwú±ßú¹¯FB¥&±’¡âW•ÅÙqë‚Ê:@¦iëׯZ¤µÈé  í¨ûÅ~\¤3ùEÜÖÈlì}.qÞRŸÜÏ´Ñ#êW¸J³.PPmlóSï?&¿|Ë"iy\xê¨ b÷³8­)7‡Ë_ 0ÒcLRƊл2á{’kúKD#–ÖÜê2îG·ÐNù5uöà™è]ýÙ/«¨Øá/ìñ@iÕi«‡™!PÁ"ÜÁ´Ý &¸+b–zdœZï2+Ȇ]%%w£LŒ’Ÿ_!(ñÚ_¼VF{.5À¨y=!ŸäsM !ärNA/¿€¾Ï÷!ˆÈ•+ži ÜW¤µTõ†I ][Õݱôb>ª„Ióžû<)9Šr–ÏØ×c®–øàyÅf¿s×2e~…[ ìª)cÝyvpcÄ™9k¥ ö‹½ñêµ_…¯á6çAá«îº÷ùH*Xèï¢(Bý†ƒC+•»˜uÙ“aÄpå©“.›ö<.\H*ˆQqݵ3„`Ú#Às‚o‰rLú6€~ o €MšdÒ•M#×òšñ©¦ß)‰ù)Bð>‹0|–Tdž(à‘´Š@òmà¡êtËq}“(ÈǼ­ñŽÉŽØÁJ±òé9Õö=.ùZŒ¥nÔJ_½„=n;ÛS9†E v$ƒq¨Œ@=¦€¿[¶± ÿ³”lØõê¹{¸žD?þÝSV´>ñ‹pJŽyw‰ùóŠbÝIç—Pðm0à„v3¨Öß##ä ÏÙR0¦ ²Ñðú7€ÌN¾±sí§`ç<^cbÞ¹}¯Ál²ÏqÕ·%€õÃNí“«}¢U rµu’Úÿ§p‡~ÉÌ‚‡ 8àWFIîÝøwUˆ¶Óç”LøZwßôjýAIU QúFÆg#=²þbitœt¹Í£Ž’—Q5: ÉábHëئîÃÎ óÞög‰£C9 w®5Æ´¶ª1¨W¿Û’ƒšáÏgφªÔ]k…›ÍR®Zj%2Iè>â¾V…kοŒ0ÂrKóuóTF¾¢wQ’éƒgtv•µ)Ö!ZA]à~lÑ»^N"Y#â±i-{YÁƒèƒÆ©xZk[º©é¯F0³5OÆ¿  ÕKf8âÐ$zÌ/4GˆË # \ÅØéÓÎhK÷êv§L¾Å,"30[Ó×l"Øú!(œ:\ÂTt9W§œr u¢âg~)DFÜ=b@æäÎ!Оlf©}C¨”Ã20ñ'$ÍïÓ¸ÙbÁí솣­‡æy;S÷r r]뼺J¨ωûŸu{IJ2Å]I ùiD×Fo&.ô®\A­H5Žù½Èî²s‘Ç ümšBÅJ¥ôð/ôꎉ_H¬9¢ô 5Êe¶¾ Üw»ãCô*´_©HNú7'ªæ×id÷WPZlQµ‰4kW ýÅ} hJ›«r ð?f^câ.ô^IÃŒ·Àr(LIÊp‚àÒÍ“ùPq%‡DOî¯ô)bÕ¤r÷s†¤Ï”¶µcZì¤N4˜y(²Gžˆ\´õ̭ۨ×p'×ÇÎ5hz•_ëO,qzÿ øÖ,ui¸Cv¼34p—⇆} idÓuYÄ T…¼ˆ_>#F×B¡Þòµ|Ä:¯G×™ŠV¤âbœ'tU_´ì9v ˆ»ªLP¥¢ÙW!ŧÚd¸7Ó†O‚w%¡aïeÁçƒê¦ù§ð/½Á’4õ$vóq–l\ßÑ»œ&ÇA‹¬n 5I(_¶ÁË*¨6]Ø)ÃzL±ãUõÚ=öQžRÿQ°ÿÝCo{àn>ur¾Ý£Ã>.«]’Þ×ôwU¦eoû—ϧ>ÙýXŠ^hæ#‘ÿ›«µr©ë &Ÿw¬ »ÞS¾ó¨$ÐrN!Y~5ßu¾µaª|h!I—3ºäžz|‘›Ü¶¿’OEͶ˜‘Ê´èšr;›.€Xã¢üsà\*¡tð«_̳º ·J,"ý›m¢*¶Ew·%çñÖgþ€ïqñEÝßã 4Òcxéå½ëŠ2‹÷-Šž ddüªà¤’˜ÿüƒùI÷vi®F­î*|èÕåÔ+l±U¶‚¢èîמf”hUëkÑøKc¹ƒ_m £§Ê'WÚ@»3ȉ9ýƒ‹u1ÜOWqÎ'ÿ`Ʋªã¤:@sý¤&Ü‹ ÚLÃÆµ5V§l¼Îbè«Ùì ÊKJlúRWäÉ.zˆ•þGuÿh-­žÌÞ+ëC™OSLJÌG*¼²ohfQšÝà 1òñm¥ÏO ƈù7wòhˆµá‡õæø¡¥¢Gè}³ßiáÈî4…õFückp6‡—2⊦ÀzÁw˜\çº+gJO†'Š3H#ªË/ <*Á@ŠN’4îD(l‡ðe¡T¬*¡[7¥ÛüAÃ%$+(;¹þ écU†AÙ¦:és=µƒU0#éôq7Sw&$Œf3wG^ ¡ðyÁ,ó,kƒ!àßD~t_nèØà¥Ì«{úØ)¨K³RORöÊÈè´f€î ¼½]jýÆR@¬‹D¸G@*'Æ/ZMnAó¼6°"©v›Z€²ÛqO^Z'¼¼•ï2äQH Ø,8îúëFx³–è¨Q•U Âq³ã“ïš6œµó#É?që+Xê5¬H{&´ëÈ™|ä‘ p—(Y?Oæ>Xã<Þ~ðu¦ŸbãÌunLbP˜šUÓÔâô€9-§%ÐäJÂVY=mëd+fhþ–ïRùß~ͼÅrqé‘5ÑQ&ÍY·Pwn¶þ,±{Q§xv‰¾ÄcQk dg.ÖÒ{‚—;·²îsêz„e²}½K‘·œ¯d \0QŒ -9›üÞž5 ¦g3ƒÐãÚŸìü–``K°ö$†-HÑCòoë!Ž&ô—$ ië¦Ä2 V +áæô÷‰˜fl®osd¨l"‹ò#é–Ë"@ÔQ"€±u#ß ‹Ñíö®:‘¼9þ—ìB¿?QG¨¡Ô¢­Bt3VÍØ‡s‡†ÚÓb=Ë~%úc㤎#ÄV6Ž˜B:/$-6‹q¥£(¾~€4¬· Ç-Š -®ÌOŸF“ñ{L^£8].ÚàÐú‹à|QãÚ¬¿n ¯šnò²çÅ­¤=Þ¹èσ¥A]G=ù Ô£ïãàÉB ŒÑσ;  ¾xÖd"媮£vï n”ý\ˆ5·Ê¢¨”½ ‡ÚÇ4Èã´¡Îû Ǻ èÈCì ™´¾&‚e›6µâ#‘ úK$ßkŠ>½®E?ŸZlßjHY¤ì~± NÅjŠŒõG„vNò#0æbNÅäXGf`;'îÓj;ÚÑ- ¡¼Ar ù—ûûݰD&О6ÍåoãØLý3G—¶+½òç¶É‘̬ŒÐ]]àYf"ÚjØ*çí3%W‚ÆÇ‡¸¦¾§n 3¿§ È;x8›´Úh-•ÆZ~fa’9T¶'¶Â[J–ÿ{åð†dŒ3ÉQ(UƽÑpOûìe×6¿J}Aqíhïʶ¥?Ìy~´I[|™ab}2Ûâ!"ÿ«ý’à`DȰJÅõM²ŠÖJT€¡) BJCº5F±úX.r˜ô‰½ôQž²‚ÆÅ,˜Õ\|.cáÃÚ‰€'¥ˆ=`ßQ Ä‰û‹´YÈžd;"Xì°ÙÇý鎤¬ÎÁÕqrCÏ1ÖwtÓÝ¡ô¥»{ú@áí~Äû¶6“gûæBþ°öDdqNââNÀ±¯äý¦\5¢¢cKcåÑ|à´Gõîf`¬í°%dõ ¸™ûýϸ˓,_˜¼ºy‚Î $÷‚KÅq«6[Å9Šm•wg—cK¤U`h¦Þl“¡vLyyt×ýG7½T)]뵊Ûܾƒ|µ=ÝÌ9zfÔ['¹ÐÁãYàñ9ßw8™QÝü0§•¶É•ÝÜOãPúC#—7OÙ®€Ú­±¡JLwf¼‘Š2aoXŽIÍÇ"c†Ç®¿ïÓþ‡ Ÿêƪ ©ÑA‡8’ÊÆçá{8@|#@éÚA“^ýä´_‰;!S¾Ò[ÈRwÜmDz1é3èø[Y’úª= ïM‘™ÿ‘µ: ËÈøŒ³žC¬ñ £6*¾ ѨQ‰Š…ô4¶÷ÑpÜ-¸‹µ™Ïf2ü­6Õ8æÉ<ÌÑ–ôù±…‚¾6©ihØÿuîLþŸ’ ®G|þ/éé‘J¨`çÉ-îâþÖ(s€ª#a ±yHÎv[|ÉîvÂkpüÇ·d Ç[=U@ „9™ñlãPõGÓî)<¨é1N~ܲ0ÁMjó˜‘ÅõW°xÆ;žQ!RÛ×—”K¥Tš«1{ý{œ-·.[ŽBI¨, $вkýaÍÇ€ži b»|ni~Öb‡êŒÉŽJ’À$\cü|Ñ"=”ë·-é C{nYG[i(5»ŸõTânu¼M,[Ü^êZ]é¿a—Aê£ãQº1À¥«ï]Ý)¹®)€ŠFÕI‰ÕŸ„l©oNËñA ËÛ]%(Ç0š‰[ùjè@PFìIùŽBÌ9ùÁâ™.OßÑ´ddº}éBÁ(4g^æ°&egæ)“:o™xxÇòOhLòîÅB`ü}Ô½h´\*¶?‘µ×]&1¨(™4Ó¬ë€ùËa !€”Nã·ÔÎï°åµàƒ9œU̲I)1+<‰Ðu¤ië´ÂÒÖLðPáåÕ9O9Uä-KT¡°ži?·£è1XîÖ[`< §ÝL|·T¢†±ÞxoEÕYçÉ%åe ÙÆ9·"Ö}„.„ªD[Œ>˜”Þú[]+ó1‚‰b²ñ0p5¬nGE+¦ús¤B{H­MÎÈLU©ú)(T11lœ.³¨t]Á]ý}EêZ7;Yg¶¯< SUú#øœ t&q½ }èr“L[G¤!A–PÇp¢³ Gã)šžÿ/}û&œg^>˜Ò|a;ïç»½Û 1¼Ær¨¯¶ÈNGÐý”»´¡™yê{”ÜBq>Š"Wš|b=ÔÉ#O¯‹íšæÔ:ªUiïЋ°¬‡{Ùˆ 5ŒàÏA>¦ÞäÐÓ¯,¦›'Y4Ÿv*rê'cÅðùË™ÁuæÙpÅWÍ|ßbP'â-"‚–fÕlÇ™—3B~ Ȇڃ‚¤ïãü­Ýouþ³®}ÑVDá¼vÍÒ*wÈÕ'|z‰¡5iù*$½q¤ê#+ £ó§"–XcN¹Pd,+Pà²óÄóc@ÛäDQióêȧ©éň:2YÊ'ë:Ë † º€‰^ Áá„­™Jy±U—½œò šªcó©$ eY…Û‡ÌJ'HºÜhÅûé° ‚8'DÚÞ0z»µd 4w|J.{3ÃaÖ°Ž;« ̯“lÜÛK£S• ùiÌÙâqI!xè¸Þ0ûo@‹æñE—ïü.AçΛ&ð~_¦-As–ÃQ©bò„;·ÁUhŽ%'¬£¤gäò ©{ÇÐf}³¤Wóù Å·àÓ׈DZ‹Ï^µ¹`ØsWùdÖƒ‰Ì­_Gz£z>&Ñ AVjæÜsnЄ·ZÎyB?üs~¶ZAøDuÁôE¯Ü¡€Ùü_ý:®Xål¼}ƒ?Ÿþ1z¤(’ßSk$>3–{Oœ©¡&‘x4†VHá:Æ"^ÂiY+B9͵ÏB|ìñýU­›Œ Ž{‚ëyC>’Æ¥$MË”@wfõUm–ýík›.nºYkê K#me™E7$)"ð=q¦QKH¨ÙCÔ7&Ý3d udÏ0£{ò¹dÚº¨F¼cgÔá²hM•‚¢³†¦Â=E0ª"p T~ 'F¤CüpŠO\.ÙÆÇøó »„}WÑ!™–ÆjA« CåÙ×Rb†A„&ã4[+öy–¹ïˆ‹ÒÉXáöùkñ&ÝÞlÝïCÏ:ì¿DÍ!ÁlÎÜÿ_+u–k=HP•Á†0•~I:s_Ì#' B›mnc ÐÂI¡oªÀ?@˜@iE¡·e ½ÿžëÛ8ŠU»6”ì;ßrñÞÔ18¬¾÷Wë™Ã5ß _O*ަíniÅ—rìÜ‚‘9^”ß•}ЦVŠávI¹tG¯ "A@Ê\ŒgúÃå<눦µpÍ»«?««ÊÂU±j}qz`ßçÆ"—×Å“Œbƒ§k` g±Y¢,f>Ûƒ3Ö …” ¥¡ƒ»¥Cnx¶}Á¾ÿª•À×<À$ bùôT?÷à‹%ÆÅ ö„Aòä“ÿ5,Ü ×À8 ÛA“5óÿéñ Ö×LܶÕl>º÷C|¸ãâZl€Jy6÷²jº·…‘¬¿4Ù º¡ã”Û´” ªNî‚BxAåËžmS;XI©‰à*Ý”t[?mM׈£y¢w–ªã¢“°Ý}rÜç ¾¥Óêÿœtu«[ƒÀZ;ÄA[6Šæg÷€ŸkÖþÔù¾l•Æ´ç$<ýŠžb²+ŒÒ»n¡Õ3 PÔ‰¥/GʱÖÖd;K=þ;:È‚ŸQÜ™…mþwU+ÞЗ0é­‚?§þZ_0ÒJsCã53Ò£0”[ùÙX,ªBåRxyÍbX)~i5¯9å¥p°paú?Ì‘%}ü׈yí¿w@\‘}Rwx3Qð­˜h’µFHy¹™RÖµ ÈÂ<¡hþWƒÑUÍã\8;½Ñ ZïÀ~´Qs¼#:£P,JWjîÑ¢xr‡ÌÌWWIÝø7c°ôÓ4½,eGº„BÆü¶[Ìo¹;:J¹‚ ‰Ò¯ûwXvŸ®\“šÐô£Ek¹àÙ¥©Å)Ûðð>ÒE rÑž¾­AÛñX¾á]ƒógØðh^Ñ—*y<œßj.Ч*û쯦Vh6êkeõcGQÁ¹™ì‹¼«m$;?×2Ñ¢ ”…ΔZülML^é¬4U=JÙ–AáÆ=mÚÏ &m®÷ëÁ{Âe5Ñ´¼ÖG¢ØÔ{È+eSøêÓ'¤Èk²‘Ù®Õxž-ûMep=Ÿ.Bó¨%»ätI¢o×”vnãÁûؤþù,9w¨ÏˆÚ‡ê„S·‚ØÇÏ0΂ÁkT»¡ÊØ‚e#wl‰Ô[ŒÏw£OÌ>^ùÒWËÿ8v½\(êJ+ÂB½UÎX²¯Wº·ì8[Šžya%[ʉãG™d]hÈA╜"”(i*}QîÔ¤gµirmÌ¿bmÿ†˜hnÔI‘‡ ˜NK‰j(MN‰r½ê”á ?'.’B²ñÉ×M&Æ;奣é/¬¹<Ž•¿ß8´ƒv'O>d¢M9ĉà›;EòƒóɸY1NO=‰O‡Ì˜„¾!¨>Š;"9ˆï¾‚WAxý8Š8ó'dû1^ï¦NyɶúìÞèOC&Ýʼn­è<=ß ìÙ@ÍÂ*f@‰ÜŒÀ~T3îX×׳U›XçWÌß¶åBpàI-,ÂØ[ 5q;ÎÍQc_ ·¥õ½ ~™6Ò 1~‚û™;—½Âi©åd¸Ôx¯ó¨ß”•S'Ú©kÉkÀ&‹hø/   ;?.uŒªË£ã_ã9" Ü…âHyãã¾Ñ©\Ê«¶ûБ«ˆ’Pí~¢ÍÍ?¬\€è<³êu±rÔBh§Õý*Tˆ1ý²„<…§Î½À(8í–]½´®Ÿ¼¿ÿc?¥«3£ðrãF”ý¹ñdZW›…›q©ßBj„Ì)3$ƒ÷:éU(óä-”çšC¯Å dy…•aSpÀí+)ôÇH¸ê¡Vƒ¶$GNåZíù“˜—#‹®*ÕÙzI)°Eû‡÷ŠStT€ŒkdV±$3±dåqÒŽ¦0+»gg[ **ž%Ä@|¸š¹Ü{H»qã–N˜z·”fmÜÃͺã))hë,Ýðkú¢ªÃÏËG4i” Ñi5ùÂe³Œî¹¹ãÖÎÁ™ØÞ\"([ N;d0*¯¯k·'ÌÖw7c8YÔíÓvÖͺ†ÊñK8#U·ÿ˜Œ2eÍHïAÑå…Õ6)‡W§÷q+ýíÝ]KÖÁ”0ʪ õë5z„?åw„ÚxG¶|•:³ôêéMU&n*z¶‘¹(bk&[ŒmÎ_Fž,G£°s˜aßFËg¼¾Tð{°(*Òêûú1óñJ^þBÁmàÇâé1ÞD(¼ÞL*¶á§ûÖ|NÂÝý@Ê“¦•¹Ûxâµ·K!ºб3nϳç?y¼ £hÀÆÏ^Fx5¤dDÉø2±i¦)‡óx½j{AÇHXI—LÚ@FoB›ÀnöbÅï°!Rä‡ øJWÕÎÜÓ¢¸‰a+——nÎ2¾ö‡7ès#·å½†¿QPW„®ÞµaÄB‡J§aø^d÷õ‚7øŸ&½ozq)ƒX)m[‡½ËòÒUæ8òœt·Ôg~ncáœÇ¿º¬÷ÝÒúôâ‹„>6I΂«Ô/c…ºFNèK8¥°ßm—ÑÑ«bÖªàŒ÷2ç•Ë^«\1³…}¨leI¿v®½(‹:º³É9ña1è:Í ŠÜQ Àd Í= RˆSç@_/›³ÎbkIÌmúÈ„’òÉOXf[€_.¿ÖUIø®¦ÜψÒí=€,ÖKt]#*CY]¡aàà|«ÉA€¤-§d?,¦¼õ+•¼‘~P™Õ]d2éC®ä_fQ>; \e‹^I›³G¿:nh£æsÀÂ\ÉR-¡;Ü2ˆóu3dÞ14¸ÖÍUµ¢ì$Üh“öJ…Ø£aFdS ÂÌýüïž®„¡¾QYwÀGýmLMzt% >™~3ZÅæVàgŽŸ4k&G^}…èÓ òã$”ÇÝ+n¾€0D¹.RÊtþ‰Fyé[¤ÿˆgaæ•]ê÷&Ö…Ôþ’ ×Oá{DžÈÝÌkñ§Ï‹Y“3–ìÿä;S"Êên}ƒ<µ­#©Ý'f 7'^åò'ÄÃ~ ¼LÆ—ÑÊîpß器äÑE@Dz7Ûö@ÎóPŒØ Ø6-Nç'bE£îw{p BÀF»×þÚâK¼P_@e[3½Hnö#3µJëæ/Hðôæ{ƒS]ªsHKKôQq¡©KPµ f&·Ft/u唯xf€Ÿ©È÷ « MN ˆ’-ïT'nðp ·½ç.bªÅZ)¯ĕ̚!ìÀ{ý‡*ßyõbŒ¯F£ùï¾ûøCkrΔ‰ lq¡— ,ííæ·\|˜V>Õg¬Ö°=¿è‡¨\‹u–t¦wêQNËÛÍ>ˆá …óž†àT‰yM«V BË™7_RµšÑÕt\¿â¶)Ùähœ9î¨öçr埠')öDJK¡Õ˜­V¼ÿ#þ¢±ÏWõ†OM"0äÃåLçìa¶@ÌߟE»ø;W‚íµ/aï—sqÓPæãÚ>sH&KîYêÓ|»5Oš\'¨yBÖòâ†IŸ×«ÛWÎ*-”Øšpåb=n¤ØRHŽÎ ޽°Ëê “ü÷eÝ4­í9•ÝÄyžôô¥n°ã|ä'rRë‡Æp5ê„„s¬À¿ül’kŒV³”–›"Æ\QèÓ»K8ðßó{A@©”/©‹8¢¡Õ‚ÎË ó½Ì ”› ’³ $#kv U€ÞUÂx†x×зÁ+|Ú1>ÌÕê™uÆîÌ1Ü £þTë@#XI² iþnNqyšànå…ýøîªDy o_.Ñ*øÕº£d~Øo£(›T†"EȲˉ{:I*´.o¯ñsË”j¼ Š tàª<™n“CРÍMWÍ',š Ù“<^EævYk8HœŒsÓû¦8-`%ga1â“¥…غúE9$¦nÍ£8ÀT£$ZÄÅ"Õ“Ý@Ýr¶{x“Ù½&äúº@Go ãêΓ(4ü vÈk8ñ©ƒf.Ò77 áψû«d €<$WCʦW93OÁII+}ôT™,äX©¨·ŒWAö¶¬Tt€!ÔUJ°y°Eƒ‚w_O/ 1za«ÄÌ, ÁV&³_œ®ÇPù‚~U‚Ѧª4­1ìkîÄSËv>ÕRVª!ƒ0–`âô(—µ^pg]ü±ßµ˜åM ì—B@cpŒ‹¡ÔÆ­«OµnœºìÛQáÿcøÉwB:>Þ±á±Éûh¹ ^‚¬ çÎÖAw>P‰óöž^p‡îŒ”¿uOn¬‘™•ðg©Sýßq‡oßøÂgð´é\ÐÈ$Ûü™Ø%¡F-=0õ\ޏ 3³ÄÁsôqÙŠ\Kõ;]Y&;£Š¥/² y{¦3"Á“´wXàïóýb"¼±à ÂJ×OT«à3f"~²¯­ö-º}źæú=;Ÿ·èOÎOªÍU»âÍ€…$Ñšü›Oh\¥­æ§ý4ÈRš ÿ̼kÐ8˜‹S ° !¡v˜JOÒØþ ¾â•ë¢Æ Qo,FcZò%}h¥pySC/›ªô#â@L­Jæ×7"²’ØÚÕO\0Wð¡éÚQó`ZëXJ §ÁŠ1Cz¦«ûL—§ÃO(qVd´£ÝSà“‡W†Ö´&~û¿æÁMyÕaRf¦†À%Ç ³²´R 7ágPõ[xf4Èm¬ìŸ¼ŒY‰íñZ=qXYý0µË7HWÿ!Ø«mÙ~šŽû¸35Ð'#*Îj]·™z‚uKrÔÜÜøƒ›¥k³«z÷ް'õÈì‰5óí´?IóR‰ulï³—É >­zùÆ.‘øà ”8ØêÿP›.×mÐ3w#‚~±Km%ëå7F ïöîLuåÊ©d²¦ü‰"~X€â˜#U¢÷'\÷ÅÀn§®áÙ Àu ®èÕ´àjëþo‚‘²…讲Ðþû gð,Àý÷r"b,Ü9r¼Éüæ¼eýLcwx‚ÀÎ’Ó½ÿ‚8)ÜÆôª÷ý‰a=º­«hÈ«) )ÚùˆïÒ¹ Y¢knÀ:F²qŒ¡4T2O§cpá/Wn±5("F•Oq 6(6¿rÂoV`Ž/E¯ ¥²ÑßeÊØN %cëçIá|ÐöÇ?pD‹¢ø× ÷ºSº3v/:kÚl´¹Ý3ºˆçcŠšG1Ez,ù+QÄ~ r¦xc]¹‰JæAýMËèeÊΟ$ë¢äˆ£™¯þnfs¥ÊÚÒ»_òtF£(„êTùÔQZÀS±‚Ùd¯ t¶/¯ô•º= ú ©%¤¢O¦å}ËG…—Ñ•Y1—"Œ€n$jû’ñÚ"‚nX¿Ð^/Â)OfUÂÖ;Žpãàùoµw$l1µ µk<ò3•´Ü9?¸“ï2¬`Úa ¾ôË{£éÒà®I£\È~®”ý[°'«9‰XŸ)ŠyΘ…W…äÝÙ5Á”‘yŽƒ´#±J 7ÆžÅÇ|h% ã “(·yyÂÝ¡/ ™C¾^¹3ÖÝUV0N%Q-é’v…VÒSbÆ·ÀøE›øP½r†êAÑFؽ°–I”6øœ3y ³h›ìE\eÖ¬zf~´yëÊælÜc %4”¹à—æ›=‚Ï º×ÁÉÎý8&oÔ:cg+˜ü«€bè¯äÀîÎ6ê:$4š)€î•ÖvPãÇ8}©™+!É—JNs‹¡ VwЦ ÄUŒùˆ¤:7w÷»Tƒâ¤”FJ§`¦TJë^»ÎtÅé˜âS\ç} Ê»ôŽ­%L ɳkp ^Ò/âOV¯¯M7{áV` ‘xu7ÞUðRuÂìò@Þ:BÂ3 ÏLÕ+ó*Ü„Ê5­2»°×äM¾ŠÒr—‹Ómüy¾m¸hþeÆÉ`=üŸÝŸ½]WÜÍ…™˜ ï*d¼ê”Ù•œž^M¨m_³eç)히,اʨgî6‡ÃÀT{<&yŒ*ã1~‹ûR‘w>X9ªäþŽÕÕÂ,ÐmpMQuM½¿]p{”'Cí> ‚žœ ·AœÃ%ŠäÇĉ…qkÖWHThÎ?Oѽ|mÍ‚Ð=ädŽ&ˆibÁäF®Î®3¬¡©ðü© ôpè"«§ _8XZÙžóV† 1~Zõê]ïݹ?öc®K™(oR‚~ŽÅŸëg$½;’†e.i‘ìÿ‹-Õ¯†çGhLÆ´hé0ñ 0@ÍïU=CQéÿ†ûƒ ¤Ãm:ƒ·û†Q¬5BÖ1Áê±µÊ >è/€cDPE aêñf×(¢† «ýà¾>×/åÕo>H–B›BB.å¼ábF÷ 7ûÜûijÌ+Žx)2ѼTBþqŠÓ~t2Êš¾I÷ÂÝVÈÑÐØzˆ¼Ê\ö‡]Ÿ×}7h+ãœHÒ­òoi¬úÁÈ+±Êt:ßK2ëÑ• x@·-ˆöîÈMÓšê–1ùj±.ÄÓã€~2. §îü÷½”Î×5+0¼:b0%ª§@ëû%6ggõª™Ê¾ñŠí؉.š]B³qa…¢…Ë3©iõ~ô¤/·n×ç‚É\›¥ÒR¡‰´ùüâ(¨ÎlÖÙº2 éÔ£uÖjŒ%0ÝòÀƒ’éÞs†DRˆ¾Z±Ñ¥é¨€*´¬r®ãS£ïó_d½cWPê1ïT—åˆ> ÿ@(ÏÅCû†4=†kšB¥Ïy“axÝhnŠ©‰YäÛ =F’¶W-5˜@낲ô÷–eÈŠ4I¶eÂBnmr'Ÿ·¦-ÃâŸÄ° "Äè:yÅZÚä~áÓKÌ̆½0j-›"¥oÛ¬ZÛ< ¦¤«™>y¥7•˜7ftJ0±õjVEK€bÆa›ª22³§¿¬wšZÊH¦ca!7ed¥5uK _ñѬ™ìÉ›ù¶5¶™Å*L#’ÿŽ£xg_™ÄÂ/<µbΟ̿qq\Ÿvu.«&`‘hÛ‚p6U'ÞuÄ“Žù;^¯×û; XûÞJt2 ú’_?º– W×2Íá®ZöÌ´wÊù9ŠthD¾“6Ôe2FlŸjQÔ›ÿÓ¹Q>IHjü¬K/w¶£¦OGÑ)ß+>†¿L6ÈF™IØÝÒÁ|vÇ~¥§’ÔBIð ‘ç¬rؼ¨¸÷jRÉßJã\ÌúV4·&'¡.0ä|ZÝí?8~ÄÍûJÔM-Ï ‚zRbDnª˜-ÔJTY*À·Óö{¢m”§ŸD+Ñð w—ãš TF­s±ú9RáUDNþìÿ²Ò–ZØ;¼!¾xß «‡­R7‡ûY5_ÒšÌaý5½ÀÌA¿mЈÍé¢ôtuN¢ïÖʺMæéb!«-~‰›°›Dýà‚ùΆå}‡çe˜×`›á¢”ä\‰)P-íbÌWó“õéúëËÛµ;ž¬egrc¶U¬bò-æÞHM¡øÛ.Æøãq“*HÁ¥¸ÔÒ;³¨Vª²+<¾j"ã¥(£ƒ;Ö!bzKß ­[ÖàxÓ¡ü“ŸWÌYƒåãW®V?»;íîZH•¯L(¬ATÕnZ p`D½^yÊѪ'Fö܉F@n3bæ÷XWc¡$hÞà˜ôу§iíÞÊT^ n8b:B¤X±”ŽgéžÂrJt¸MÛ xœ<Œ€MÞ¥ÿ&ÓÓç‚¶ßKºÜ4g“šÇNªZAÁC¦í,ó®ë³€ U:W=1rA _*ÕÖø3i»´^Ÿ9nÛL¼Lf´4k*TÊÝ8÷‹åö¿–îzøèyÔrë¡ ûŠÉe‘„pW)¯¥Û¹?{ËVöpK‚Möx‹©—~ÿ—þòìïôÂhˆ|‹iÐË Ô«íVmÑwSý]Z ù#N|±¥ðüõŽ .¡fíHm&Èž”úû¦-Âanw#~ É„ëƒd! Å“ž°fMe™=šÖ»7 =éÞ¦|Œ¦-ò0QH^5£.Š^s»¤Dþ¯_TÍp+ ½ÿëLø1w@r¸LãîjŠÇ?za¾qø1Ÿö]V$mh;™°@¶æç#^Ò¿:Š…ÑzFøn>´XS"yr’´TNRï˜ÝÛXNjkXoÀßÈ»zÖîôI¼Á@¥sÅßc ´¼IšÙœ¦£ö|0½„Ÿw&äZ|ŠjW‘ ùf³e-.O 5¹âxÓ¾µ)à”žzjÑ6IW‘¢ÍAaq,UÄE'ptùÚ _¥¸Á©a;æµ…ëD©; ?‰CÁd°‡›$$!s³¥AÙY,1¢µ'8{vªœl1ü•c?ÿåIñ†<Ž¡§‹8hZTu”¬Þ㣦%LîÿÐäG-‡–f·Ýbf7ÐÉq`£¾q½«0A“(¶}÷>A@jòPOD± ë‘ȦŒëRql8Ê=%ñßÃIúE²Å"z,ð#1[Ó ­¶ñ¦û{YôgdÞí³ÂR¸ÕÔúVtTÊ ð’·Äí˜ö­’fæ\ÈÞµyE+›0+{úädDH•£¢àݾœõа÷|®˜ct¡l¢ÈPûü¹²ªkØ%ñcdGŸÃŠº @Q¾f6 þ“^¦G4®Úó@I™Nâ(—½ÕŒzI c˜õ‚ƒ6]—Wõò³O0Œ² `uI6€¨|¸ç(¼ó…òBxœ€G¿ý»´³&šù¸vùxÆe=Xç_ט?}ž~V» ¼¬Uß³øÅQ¿⥒ôÖvG^úö¨:Rú`În”(}ª#íÙi/°&bâ\"2á°è=aNÐ-öƒRðÉRO·àT'&­¿y?°f·³†`ï²õÁ¢¤$2ßÎ »£ª\zöŒ#*±ÎFìB@€‘=tnÐ'ß´4ìòÁ‘bÃáÓn}ÃÝ`ð¡jÞw·ŠXÇÅ,"Ò)&™È˜ð½]ùÎWIíx]¥|,ôbÏ¢yÈ Þ#¥ô®6ó* 3p47©NŽÍr[3À+®Ü•V»oQº;³i.7Zö\ø®9‘ÒK³±ž;agc•A‰OÍ &\ÜoO´#„úV®cÏâÄPôÌöàšUÙ®4•tø-vÏC¦ ¿¾(ôÒœªzrFÏìÃ.M§¦yb&ú_ÉÆˆ^i¸Þ~ÕvŽÒÂá(±V©i$R¥!D_¡fÇZiމnžuǨ;èªÄéã­mÇ”3· ƒ6À»a$÷•ÏXJSWéÚ´•£‘¥œ†€Y‰9T™¥/~«68¤cÌÊhGZVòrÞ¬D1m¨~û¡¡£™l`Ýš\÷p&;›VÜV´RE«ËäOû£]-þfqôfÀØ™›ž­$ÆÔ…ŒU`Fxw5²“™™°‚{€ð³óþ­4Í…O+IE2€$ªr*#“Õ_q×4*á¿SÒà÷Zݨòéq ¤J‚¼íÞ¢²°xM)SO&@M¬¼’f#O3q÷"ùžQÂUæïÂ)sY L‡¦Ã’Êo™K/|C+çÆ‰NÏI¨3öt/Ø äciÀÞ•.Îü‘?’ÜGº=þÜÀœ›26y9PÔjnÜfê´B¶u‹‡ðÅ­>k%¢ÿÏ–år”&£’_ 8dÊù(¦áºêÜòâàZmyÇûÓæøš‚rœçGÈB·äÀI;\VG*ëZ>¾Ð&òÛÉ}–špä>Äù0:ßÛ¬4ò÷i ‹2ÞêéåjcH!”ò¢‹¾“ÍRz]^éhWs®»¥Q›+×(ºl8ú“û´ÂY­F_ë¼þ~Hâ[cÆåys0õbkiC2 Ä !5@]±Øk…õ³¶}÷ £a—ó”}%”Ú3Z¾J~ôäÅ#È]#eºÁ=££”ɳÔ+`¯¼¸ÜìúÚÂùTò&ª:ßýýëomW õáÆ¾ãÊì&Ïg¸òñÂQ^Êu˜w ª¬û¿ÃCã‰SøÒ3m-©š¡`åk¥ËùKUm„Q0~=÷ÇÆI°¬«Â~ÊÈ|L—ú­o¬ %ñΟ·©éÖN;œäc°“§JJ»VŸkÔgnx0uÿˆŽ•\Äî0Ö/ Òîr9àYv ³R8×FÍN ÀîüfGp\‰áxÓi;âÙFO²¶º»q92Ž4ká1OÀ¸pj£×Ÿ4ÆöïŒÌy^¦X¶ Þzƒ8Þæ9=³ÞfŽÝiBdGý???ñÍGb÷NDä‚ßpY^¯ï%¾Ðx…›<r·†‹ÿô¯Ò9(‚Üh…ÖØ³FþŒËhà^ÞþR”y"ƒ90ZüŒ] ?›<ÄÙ†Õ¼ÁDñ¤Â>D:Ï=£¹3Ïä2m¬Wb¶ ¯ƒŠ¶€Î ^`W¦mã!ޤowgcK² ´£È A/ @ýýþ‰ó€¨°[ŠéaÀ«÷åcEÓ/%8<Ì@‚üik = {ôVFZe%¬5¤EbCñU\YæPØg ší‘Q:{ñ;⟲±zŸ9ö”õo¿~Á¹H­kB;¼ËÝ9ÚÚ4¹¾.D¦OÚU{B˜MWâ?ᢠ£8©ÜÕžKúì Þ‘GµöµÁ yhc“Š—Ôi¾@ïü⸜šÎJ3½`gF€gê©ûÁM(WÙ(ônô¿xzºSäB¹þ¦õå—µ‹¿9Ísš=0„=ÛkÓo€#RlT‰†ÆÿzšÇaø\‘lÄB¤‰OS÷¼ž–Ä~¿;°·ŒK±á4’»ÞIöÛÔØ·ïÖÊ2rª3¾,í­¸¾°â¾Ù:‡D*uf‘n».c™ÁQÁ!¡Ÿ”A.ʾ©OX¨ÅhFýOxþ Qz`·y,T…Ä,4yM/@ï+öò$ü~±ªÛa›t¼šø¥‘8] ñA”G£Qh¼Á|I]rå7‡ªØýu¥Ï¡™ Ι8EzNÚé3±6.\$-Bk‚U" S¦¦"6BIp0ê-[ºê^ƳM2kVØA$ZÀËW¹¢I¦·@§å6`ƒ:»·|ûßïÇâg*á¥ú³\h Ñòo™ùßÂI È$8{Ö`M›f.Oœ/Åt¬ùMF¢ßt³W¨×8dˆ‡ÍñÜ­¹¿óÿ(·VÎÿ×ÄÜz>ˆ ïÕûþ˜{ÕðžÍ¾·Å¼pH¨·½Œ¹þÚ nÉr†'q“^ù§WðNÝ */ì;hÓ 5W²ª¾·Þ•!p}p˜Ñ-ëÝ8‰ ×û·áæLþüî¢BÊ})6cÒ`„ÞYe@Øz9!y” y†”çÿû\Ï ½˜Œu«’ª“qÈû´8Þ¬?WqpŠ0&ícî*Ž@v-­*—ºËSgÒ ²Ñ¼ãT¹åò"¶(kþ¯¢ ·Ê.¤TÎ>“œ>e§ëº7j_¿ ú﹕™x¾*ÌpÒ…2ˆ°ñlø±Ñ»ŽOÝâ— gÍs—ˆ:f"d÷¨Ä€ðœâŒ•StšÍZª¬Ü5ÏÕäwhr®æoÞú!Ñâ85?ÂtöçE"$ÓŒpxs Öªk”Ìíoê£X]ˆKŒÓ'åZ.Xò[ú°DxîoÛ¢e)®ÌÞ¼•ÖÈÝ(©³7´ÈFM[¾ªñe‹q0Ðþ!Té¸K%jÒþKNŒ\b·lõüúZbO''CéQ¬t‡Ó Òm^G”*Ö{¦È{ÿåÖ¸ÇÈ7–a ‘;òì“ÛFZ‹wé¼?Zí ¯³˜“Æ\ãÌj £Þ楟GòÑ/àžSØQñ rŸû­ØN=[€B$ ¹bå»ãCÔIÊË c‰-nÄÙÈTGf+®õƒ®b]S^hw %p™¶ÔÀÇu僵|·¾ë­4]Xèê±~è7oÕú6~ÌMðŒ)ÇÄ“µ~ñ ç ÿïaeŠÐÌ #k…cêÅö¢üÙ–41};£é`ì7/KýbS:í²Èt6ŠSÔ Ä[²yl«ä¦¥¥š…2÷þ‰ÍØ÷-Srä5FG™”Λ™ÑÐéfsb+ô9fX`Ep1tälñ—® §—ŒßÙn‹¬Æy.Äž4ªµÁèê:€–mÃO‹lñ‚¤ùŠdΦ g%GÙ›Š/€Ý¶–ìÔ]˜:–Åáœ(Žƒ4ܤÜ‚aú¡ß3L‡¢Ë¿\À<¢ 4E5Þ ð¡L»ˆGîpünÛß*HÉB%‰£øÛÛG¯Y0 ¬ùæ°Ñ‹±ÉÙ ™@Ÿe¯âcµ6«IæÞy¢˜?æûû›G ÌV„}O sF˜ž¬ÈËð5¿ý¥oTd¼K»•7¡ŽŠ6ô“Ž~2Ëu©² ú,iÁÈ–%á$›XkH‹jÛ`üÅC”þƒ<Ÿe7*púsùoˆèèÓ­E5N6ûÇ›b.ðN˜sÛ¸×  méÓéÑÓ/o¤Æ¾–«íùe¾¶ rÏ­ËDHÞÉn±DXۙȥ+hÁ¢Ü} > @]½?‘ Yé?[ÛÖߥS²[‚c/ŽüŇÌh^ þ@ðú­ (CeçyOÆÒÊ\Èfþ+Sù¶éÑxÙsG )pÂd!á…Ä‘ëZ5Þ Lý²ù…û $—Ò;Zïf¬ªc»Ù‘G™4Q.åanF}Ã=¡a¥¨ö+3_Y«ó¼Š¦¿à–¡Û^LvHÂcØØæ¥ÇÎAZ?å8þ‘#!{Sþ~- ­©†c¦]XÓÉÅ Kl[{‰u¼ì+Ýлo½Pœ3‚ÕŽVã9ºÈYç’ŒCÌ$x±#æPÞü…I()dtjÊ®#‚hzÒJ™Ž.¦ýe8:‚[ Mo¥ä³Û‚­ù¼Ðc6÷\æa˜—UÄ.{¢"£D%éÖÜ›}'ÚDô{Dpzº>ý,yaSøâz¾x¾Îƒ­ëØQ…©Á3’ŠÆZÈ%Ip»¶¹]é‰bæÉF÷˜¢*—³¢2¼G=Ã(,·º €Ôvׯ`hC+‹)*Â'ä%7Ûk8d O̾*5™d'7V^õößÅÃS€6rt–§u^Ÿ{†©nažä™Üóë6YÖ¬&{òï0ææâÑN㼈DfÛR$‡åtFþt=ëjIbN|^Hãp¤Éˉï¯áP€ä¸Œ±Ìjª®Nø·­‚ÌHMMP*UlíÐëân:z _S« 6ÐØ¸÷φÄ\!f6tZ-0rs£=OÓ!cÄf¼è¨ƒ-&1ÊéL Ò&LØEõ§Úð8hþÿß°šï5sì¬ùñWŠ Rê9½t¬Øð˜ŠöŒ)’õ=*óˆ„E"äÀ0{DóT±: ØatQíl.…më\& ¸ 1#8|±3^~Ç—V$æš5®^Àå%2¥ûTsvòÆÌN†dJ¼$¦©n²¯5m4j¶¹7Û˧ÅA+ÜKd5™V˜iôÒÅ÷Ô1£¹Ǥ9@*( ]À§SïÚd±&àÊ¥±9ïmº¼ TD1"2až½¯{UXBò‚ž®àTaû8pÊ_ÇÈå(“Ç®TuŒòa•®‘˜Í¥ þ›´Ù;Sö¿¸•íYó™üÜ,¿T¹£ ‚°ÐRtr©nï.D§ä[þ”hd ‘<4z˼¸ókßNÈ¥6,2Oõñ[DíOoo#ùGÃf]ÉC ëT…Ÿ¬[Ûô\hÚέ¬)ÔËfT)nv˜Î€Õc›ÈÇQ;ýôüeb†1éð8ŒC2tŽÐïþÜô” 6ª‹ùíg!?û°¼a©ò?aóüh Ø”·1‹WgÄ~ׯf'¾¸L¿AD7çå¹à®¦ítˆ£¬C:Æ2ÒÃ=5ÿŸâ%N‚ˆ›q–RQâìÅ^¿ýTÐw¯ß3ñ¤jÿ5 æUø±ª¦Ç‰+;ˆ’Ö¬£Ô;(mý–›œ~j—nŸä)p¤™Õ²m—?!‘˜ï5p±€eOò©ÓªsWjβ<È¡1¨·¹" ¯åGkQÙðè.EŸ)Ú¤ƒÑÛ®× Ò¤¯·wÿ¢ £ªèÝÿ ÖOõAÞ\hä¿ÍE0¡c×JØùm¦ô•Æ• £Üæÿ8ÑVTc=&Þ„.–ÿçÉ4íX¬aUko#µH¼\Ä#ËSö§»(¸?‰ïŖЯ-V·p“˜:æ‘qÿZtx¹éþÚ ¹š]iX+ŒDæT•¶No„`i_zS PÝ^'5ë2bZÜÅ;îÀ‘ºÜ¥§W ò Ü’KZ€ÙP§‰"оÂÎïu`äÜìVȯg{ š¸‡t¤£ÉÎ¥L!ÂPE’–‚¾Ž—Þdk‚÷à5²ýâ\O«5ŸïÇ‘åJjPèÒ~Ó œËõJ:ˆÏtgÞ‡UÕO8ÖŒšÒI‹Ñì­ûuO}$«óéRYòâ’f]Ɯۖöbît%g€Ïhù/œY[õ¨/òlÈ—r¯ X“64g¹É&X`jí,›è¶}…7Wl¡F{¼ Ýå´'o¶g¿»“ (_¶ôŒ…v™HZD¬±AˆPfç´’bQ¬©™‡õ`øR¹æ½T†o­’-µg´K*:C»žÄÁ›;[‚J!10Œßƒµhv–KÔ(žh»À*Hì¶ZaÜe=aÕ@êeðg†s¥ ƒ¾í`¯Ä(öeúå½àÛâp ÖbÑ =s7’ƒŒß˜w‹ò­ï#7>{|Lyñàâf†1¾W`®Ó³ú…á–ŸdÄ¥þU“­BéJfÊð»ÈǤ¼K´Õžý $}MÛlE˜÷¥«å†Ârê–ż×6²Óš‚.›ŸÙŠý^Nê;“ná®<)ÒïíkLÿKh¦¡jj”t—ÅÕ³t—Ÿb{K 5ó< %xÞyU‡+ƒS”ÓðßsÉ ¢Àí%¶j¼DÕõ./í9e¦T6x!^ÌY1N{RN‹µx3>c"yÅœ‹—ä Õ9áÓ]ÁØnˆä¬Àø={YÙ“còë³Ø>ªàžVÌqàrULg<8ŸÓéÜ;²·pbôbœt\ŸS'Ï4¤:}öcÃS;ÿÿä OëkAÂŽ”@ÐíPÄzqë!¢LÞ–òöÃOäÍË"}¡¡L¯#=‘kS'RÕ€ `àÚ^Ë ©0ä»bOå1èDS¾¶îí<ïñõ•®sŠqª—•à™0ð¾÷ñLØ­bUD©™½½-masGp^¿Ê$¾²ã]⨲.hÉMiäK?\MlˆÐ£Ù’Ò-^®j—PÆÜ©GBÆa[R~b°ºR½#¿±rm´©³BP©%¨ˆN¦Pø9öµÂÛ—gެQH„˜ø°ç§îÚo•‚RßëÆñ.E §ùÃè¸}ÇÓ›ãsp‚N|OtJ£šÉ¼ZŽÀÄùoß‘Úêú†Dùên‹T~M¿\5¹œùù{3þüNFu6Au³dì;ßhí±ÑñÅ„nWXº÷ˆ6Ãí úY‚o>>©½â'Õ’-üÆ÷Ñ+Hx7ñ¹Êž }ì.«ìßt^²©ióhþ™…©N$…·H Ó$x™¦ýüVw#n´¢ŸìÞíê,ó[H”ØZ—fäVKg ãm‘gKJ¬ú ­50qJV«6ØÅÂØ"ÆÏš:ÏØ¦3q˱ <ò¶Òp5ñ®¡K:{ŸÛ%©¡q®Ñé¬j^-!”nR¿~‚¢Áµ2ê­£Há1É€Ir¶x •üt‰‰©×E¸u«›>cºKjk¥üöäÐlo=¬ Ü¶~”†óÊ!Ži„lÚµÖÎs7Ø×Ê0¾¦x—ü<~Æ  ÌÌÇ£œIÍsi•™8RÐñõƒø4 ™ˆÄhdéC‘Z|× Ü1¡l]Í”XA$ówþýn¼|̆Y(_Cw|ijÜ™÷0¹†/@¦N£d¿¥Pí¼Í:kENôîN‰”ßQCûº5Y<`¶Þ.5Ÿ  ÒwÛT ÇQ õ½Oȹ®•ݼ¿ˆÂá½<\oÓÊúE(qÿ¥îdÞ+?HxÞƒæµVúSÜüsàÀ2÷WÂH­xëÚ¶f 6´ó(ï°Ã2+ÿÜÒÚº·DEõÈÖ}]ºXIÑÈ¡c7-ˆäÒuæ6(}ì¼ß9‚EÂÇ\•™bs‰qDØïy‹$¹65è7"’3JÈŒæ+7”„²µ0' ÎT‹¢ÊhÀpÛŒ“kc¶=1!È‹0¹‰æ©—ëdÛO^Z·_ö Ä·*€*…¶©©«3[ y’¶5á®NœbEZKJBäƒÀèÁjjrS0|6 ·7Lòò·Ó0˜‘Ãúpo’*Xùp™®øþ3:#¥§?P°@ŸçˆÔ¾™…æãÒ£¬š"µÐ4=ÞâÏ(_8­ohŽ% ÁRxߨò¾ç³›™ñpÕÉŸF:q¾€:»B‰¶w—ò†@Á]ºÍD±dµ^ô%°ŠxêÖJÐ4|Få8üƒ@œDmV®ª^³ê·¹BQž5°mÔ ª?®Æ‰o‡*^8†b£"À+–†W‰œå²…Ä&†žB¯*KŒ*š.N¸T€Ú£uf#$½0ÄN݃*{Äví²O’¯¦Œx¡§P5˜Q6FOi~J÷Ï›(‘*‹¸B»^NcÑ1rsÞUûйn7Ž}«˜}æ¶­!! ßÃÕœ·7äဠ[…úz¥<ŒV‹ÿŒéjgÄÎ.%÷ '§}K¢d•šSiËîLk̹tU•ïVAé»5:怂ljÂ%=V= ·UoÕÇÚ¡Å—H4MzÀÌÈkÍV1:BÕ‹jÒÉ” ¤ªå¿I¤æÂ~‚z•:+ÿ¸VP^e¥˜Xaߪ oÔس…Þ>Û¶®Úh×IUÚ|Ë“ñºÏþ¢”3ôë(ñ  ìôÀߤBÍ[ÜÐáwqh­Ñc‹‚0ð[în ‹Ù¼ˆsSþÁ¾izŸV‘†¶º?f‰R*ñKИ! {{Vá'1q3($M§Å§ý–°I ²ÔD‘g›¢ðj¹pr•¥\C±N¹ÂÚôý•Lav‘ç3Þû¸ÿÙJKQ ÍÊäd¤Sw¢º¤d§èÛi Öâ#ðÎèG¹ø.A³’QAŽñ-׈pƒÉâcƸö˜ÞuÅ<«Î‚LÜe5­h• ÚAíq¨Úˆz8x aŽ‘R‰t£Ö;îFWÜWž>'¶a݈ÅÑ $FJyFZ¿‡0Ü­ ƒÇ8ÑŒŠ•Ò¾UìÄŽj–ì‡ý¹38’;zTXšu?€™xf²±Ϩæ6Ü-vzàÈÚF™©¶*[í‰FÂQ¤Ñ`¡ Ô5,Oø œüÝc;ÙÚêø¥?˜)pU£øòž)݆Ӛ>è· •(/²ù<Ø‹™qNVB—tpL "ý;qþ±À ¸³®HQÝðõˆÍ63 ¯ERi·ØT׈ «ÿA$¶ÖM$YÉâ‰xÝp¤ ƒô2û#>¹€øÄt™ˆÞ‘t•z^døÙçÌúÀÔK+Vš{äý_j*  …KP«1ôû “èòûÌ9¯uE¼–Óöº1¼aBꪆFLRî"Ë8GìcîHĨK&ßÑQ ébZû»fƒœ!ö¼—çàK”S›Yu$–V] ójKÄ?a;ÊN=Õ †“cØåxã¶Xrý™(¶7an†ßüɽxhœ£t±&7‚ÚÛ›|Á:à=½7®¢'e7·¸éý~ÿœÇ'®É]³h%“ÐŽŒ™Û9‡d|g=rë‘¿§{šî˜\êx?RâÏíHýІ‚lHFŒfœµ3©Ûr¾8ÖE´¦ÖviTÓÁrn¹¸æ‡Õ°‹Å[’&/NYúbawZ€7ÄŸ‰q¬üáGdÏ€"Uz ó%½–´Döåš—Ö´"!ÀFræ*šžÁÚ­ ¶”ç&«ÿNÜ–ý\¥¸'h‰á\Àø´•¨­adÿ¶-Æ Í—L¼4ûFå; K%Ãzè#ëÄ(ï^s„>+fæ×ãV°z3?ëå‹LzzÛ5MÚÑ2 ‘+·|W‚yËHjKhD°™&¶Kš¥ÎãD¤Ç0ëÄ(Ûf òÖ9.M±èµó»?ÂóaòÈìú ^êÂSH8õ»qév¼Zip#aÍã@.hÍò¨²Rµ<‚ÁßUÐd¼èUcˆ“öx =ú®3zÇá‘õ2ßA ã*ôTJ²¢I½o`¼ŒÍ)£húîwõ1!ä݃ÀŸ èIAGšõ@†Æ/è>ÌùïyÆ£¹p²†p;A•I½õÂSÞkŽÁ5†Ö=dˆ}ðÇ©W¨Pãì62‘t ^ÚK>Àý¨Óʲ,íÙû)È!0gT’nªRôG^zåsVz îzÏa:Q!ÊE…}“w>ÊŠÆðg9€#ÌEÆÀqÔ†kô ÷D38.ÈÎ&áA±aw/.šBBœíýŠmÍ GaåèÊÜ´ð¨Òh˜]™EƒJªX\Ò4xøôêIÏLg‡=VX½'î‡_9¶¨ 5rÚ:¢ŸÆw7ºˆÚŸ©Ä†)Z)šU8Ç\ów ذˆéIP»i p³+" ŒñâSiìX&2™œ#¥zø¤£ÈK:pÎ9ß’zðœÚ…ÁE+ÍúVúŒväßïhå"Á#{߬•aª{bḧs–½ï²ËÑœ˜BÇÍÅ/1ºú 4«šV)ó]°2;Tc™NŠŽôdÅg€zà"ÒÕ7fÕ¶\ã s”ÞÈѬm³yí?V¢ð­ë #.ð<]±ÿ·ŽË©a”ŒÓU9¥ÁªG{'=¼¹xñ5ë$îÍø}¯‹3ˆš‡;.-"’F¹ !wo¦áx¡áZÜb3Å>N{‡¬Æ ¥3Ö%mÎÖÛÎv?< ¾åGY¨@+V#·9¥Ä²ŒGÜ@ìó\oä 8;uÛ¼P´§ºVd€þ´lÕ:‘›ç~<¨8) h_qÛe0ëÆå,0ý¼û8áh ¾Ž¡®Î%f+K‡&PÚðµÂ" ˸(8æ…WíÒvãÑI%uêþëd«ÖKGV„ÝyÄÚ˜xŸ΃$QŠ倨Øï1& ZŒ8D‚%2‰'%Xrd Oq,R뎵I%‹âÏ_Ào/#xóË[¥ŒÂ¢°˜=µÅ5ô·?/˜>õ¹ôñ›n6—©_ÎTóÅuSSxî •ŒúýH²Jˆ¿Vµð,Ä$nÀ¡«u1AÇ\SñG fã]ì‚pÙ÷ûň¤-“I¤VÝ7d6eŽö–†¾Jÿ“Ãæº±Ù1‰!—”«ùgмS­ÄÉ>$¶ÕÍc ·R‚ª’—Œ!A@#ÖJó·Òºnœµ V—üõ?wdo¨tNÖ-rÔ/ÏsÂëèzm‰-2åF {@ 8ĈéZ©ZIy`¶3)„äÓG%Úõœœz•Ì‚m€°˜d¯^añøµ‚é‰×ž„5•”æuvÛ'€Ÿ^q!q,¦Wÿo®ZUÈÍ_ËÓ.âl3 'I´¥5ά(Ã8jçyîç ˜Ó¥˜Ü"qj(oËT—|Ø èòkÝÄ7ÍÞ0$ÕÂ!œiýî{ô8º3˜M“>_¨ 7ƒ ¨6ÉÈ—«·ØØÆšõåThƒCWCŒ‡¤íF/¸H¾Y7•¢VÑAy¾Ö4y¹[÷Í·æcºöÍXßciŒ’Ú³¨Ê2–y@E¼@éJrT¤XÒtܑӣ'ÎÍ„£—¢&ýC·j_ ݦØC—Xè„gzêžå$Gž‹XÕcAcÍHsô@ÑÇ÷õùåúÖåß®—Âv©S4#•TÜcℊ”Rt0ÙH3HЍ‚V¦sÜÊŽ—,TÃQh…› +F83õoaÙA@úÑ—·%î„úÚâqw‘· Ë­¨ÀÁgTÈÒXFÅ0ÌOŽ}ZÀ Ç`–cÛ² {ñˆ®¼ë8ÉV[®ž™z¾fÄN3(Mx“Ð=ZLï ýñ¨— –ÜÊÍ {µXQÒlWÞ.ÇÛZª¡ŸBª÷oàVÚ*ñØP8Rƒñù÷Ù0ÎxE»çPß „Ù|[ Xêß& )Pq(J×HÔMÕmÑ1,vJŸ¿Žòkƒ²çu¬Î;¿Ò c^9†!¦ûáýkЩØs9hS„ÐÆI­+d–†ª<¿Œ¬š Ð{C‹·Š±ä4~l<´žÖ}oß#jA´Q©*8¢k³`—¨S׿ö’á¢9>…ÿ?ìÛyR•ŒÏ÷#4uÊŒŽªÁJT&ŠMÛEOA-w†’<0üX¶ù&hÐ#ä!ׇ³W5L‹êzù(~Ó¼UÔEˆ„ Þ¾¥DÔR/©§ºUJG«A•HÚ––Çû‘C;7Ê$(Äî´PíÂî‹n§í{FCÍþªìºsV¬7O›»ÿ‘i—„>¯zÅ7eNÖ:²³è‡-Åo£”C^IËÒksÆïãëTD9û‡ŠKˆcºÂÿ‹7(!Íž%Èû‚ƒjuk³Òî=¾À|Öd.ùµÐ„_EMî€Ùq±½_Þ[Bv¸‰KÉ¡¡†sVÚµ¼£ä£÷=UGåжò!@“¦¦WUÊ#÷ÓôF¯Ù}%‡Òü¶5C(Ë1ŽÊ˨3UVMŽüÂñonÅÒª_QWý m&ü(5t4Á\ž Cð_€½pçŽYçuMbP˜6dV4RMÎXo@C2ñÉaö­¥J9•„Œæ. {ÙG7ZV† {_ÓÖvÁ7)'ÍâÁ^©U£Ta§xù½ß}Ç -ÙÕÀba8À ¶_z…[*±¿¿:‘»FÙqݺ›´úO÷©Ó¤»Šf˜še_)á[ÛÿDî±vè‘¢œËÌ^Xù¯1»||ƒµî1ƒH´äÒÌ×á”ü0Vw•NRj› "SÑ4SG Âu :äËk‘‰”Ñ0¦î!À*X»€‚ßU=Ÿ¾´Å߯‰%m…}¹Š%7BK¡Kº my€wü"Vž±ÿ#ÊSÏg0u œå9‚…õ1· ¹ïÄ™¾T¿y_Õj+ïûÇD˪ß8#ý¦#øîúoFA2¯3P:F^áÃ8hݳ#‹lÏR½‚ Ôpߺ0ÄŠl U’×F%é×h|cµ*&õ¾xlý{=âåB,º[86Õ7ùLÞ ì! d¥žÃÉ~øæÑwÊ$ÔÌÌËÆ~︱bcÈïÅWÕ¯DÖË‚{G0eHXëÜüv9ɲ S Ë•ßfå*­ûè`ŽR³ªŠh6Á\ØVÕ³óI¹¦º‹u3aŒþÝ® õ¾úýazpÀÈêDŒ5 æÃ–¶ªø…–  p.ä®nö&ˆÏª(o¥ÝJ]£C¹²‘®­²gYíKÙUÒp ˜&…B¦±hN¢Ztþ$þž¨Ân˜µTôóKüï]=¸èòS&}Vü¦_"²Á8¢ [ˆïn¡ƒ^ó¡ òh)ˆì°Ÿ6öyËÞv©Šeae¤e*€ñ7Çñÿ‰(© øäpµÑš‹RZÐs)©îÎË,X°»V¤|Ý:ËhÚ%ÁMìùÿù žG“·&OµÃ­DñNq:O¦!‡â:¦zÐc­¥Ö¯ËMÚáëé’[B%°/©uCÆF3!0AÇš¥AWDeg9‘("\,QaÏÔöžZ™Rý‹ÎÁÚ«ó=²àÐZØsŽ›«…u/vnFŠU3 °½>éóPu£|PIúýk¯#phÊÙI@ßF•„fÒ‘¸/ù‰ò«èŽ©2øì{Ù"¬fTÜ–é1Cü4pUØr!Ñeš yµ:q B;ê¨ÆÆ€hÆîÇì#é=ç‡È€érEH¡¢sô2fÄÇ…ÛQgZάMèh\ä([D1˜ÙzÿGìJ˜†ow¥}^Ͳá \ŒmcÒŸ…›h°$›Š.1ÔÓäP9¦\½ø.¯°¢ÖRŠ7lM@¦„¹QÁlj½N!±S¨sí(2¿ÂÞƒ«Z,÷Ì“4âÌÍ þ1¹%ÑØ×v3%zP#_}M‚ñ§Ûøu“Xm’Õ¡œ¡„ôþJ/˜ˆWÐ4=Á[9¹>-Y“áñÛ1º™±páLFkïÖ“4ö4Æg^2“?ƒ (@$Š6×áUWúÛÞà[51H‘„Ødª³C=R©PÁÈ>c y6Ìæêô—œrOÖÌä¶[ŠíŽ€°‘¨‰¹p-âjdÃÐ@Œ{½}èìá…Ò>Ô>O?¶’{Þb¯p \Ï©·(P÷“6[®à^zeFÓïÎ'…pþÛÑxúØ2%(~ Æô”W8vœü<SIy"­ Àa †b'ß~àÌ©c õµ Ú°nšr‘ì ò6ÆÞõ0ûniâ[\· qR¨û/jðüÝ“ d€0÷x2ó(´ÒÛvùpR¬&ŽWÙaÀ¡Tý.B^õi%‹™XSŒY’Ý1Î*X&¹«‘$Ÿ}J8F¨Âà‹›:âý`[ƒ{•Îr%Þ7ä”›°céÆDó¼óuýFŒ%'|›3 ÑÅ™¥cù…T“OIøˆÓc9Eëtª‹ø_]9=.A¾ÜÎ _ÊS­˜²béªp‡xê M¼ãTƒ•V7ØÍ«ÚŒ|êóg©Ì€ÞI?ÓÀrïŠ**œ™LVÌlM@—1¨ô}›ëANu¤¿0Á8DÒÛ¡^KX/dÕZHðý‰Ø+èb­b“H*(ˆ8èF7…ñ‘ojw«¶´`*Ï•{1Úýºl ÷,">×óÝ}ƺ¾ÀE›ºPÓ¸R|܃‡'¥Q¿RoŒ,ßÉö£n—ER“×J=vµpçäŒô‰ÁéCWÈx!©Ã‚ ¢ÚhNm Y®çßøåØEôò½¶Øª* f³×'¸Û ö~—Y·;ª4×ÅïNÔ€òWŠnc9¾Kƒ7í×åÁ€9Ë~º ZQØû/{kØíõ“…¶4Õ™ëèõ«ð#H^ÆÅeÒ¼v½#$æ+¹ÕµA¶yà z¦[2-E,  (å=L‚P0Ïç°ÛXíi¹ýXš ;{‡ÖdžÍ Õ¿Õzoü—eíwU╈àtC8‡ôï® X´Ò¤÷ûë_BÁNó¢ì”Ð4ÐH6$뙈¯¡×…]è‘…Æ‚åK.& a§*2„àÆŸ÷bSÎ$Çg^½mõYÝÐh2áMüÄYä@¸êÝíµC:µl.R%t0”µ|ÓοQ½žµ?–ð¿Jü önlO¡íf2îíUMsfð§ò*ýÒë›O!˜ 곕—ÐM eëC»ÎÉÓóÅÎ+`çô¿Κumv!ŒžãþÔF|´XY9ÓѹdCœÃƔ܂ĺ,d²‰¬|òŠšÌ+b2Pk¯$Ã6gŸª=Ù¡rÖíBøÄ}vËèð;ȨÖLBt笩cK#¨l‡Êä2lØ“ ­ "øïºU¼¡…oÿrj)È÷§¾ûµ#ÁLš¦d†w/SÔ0—Ùd€1›¥°tô¥ãkՉ긨„[ä‰\[ ›”pÛ™·½é†=$t“ü·ºå¿†/ݬ!ëTW }ð±ø^ªß.¿ôYY‰ù Pöi@ø¥^ïѯÄÂép~eè'塚n’æYÅ@R3KG@Ø8 ŸšW昒tÅ=ç Ž%"ŽKÔÉ„EdÑpq´¯³Ç3²å`„ñçó `”6­àœÜbWIaõf£ŽkäÎdqT—øŽêbP›»ŒˆÉ1Ë+hKmò˜îÿk8.Ð(Ñ$ËŸ( õšaêž;aÿ%X¾ây[>uy&ci `Œñ••M_¼Ÿ$…}¹°°«… hðMÿA¸‘¤7®ü<{N’»œ££Îœ9Œòø˜xëb@Õ•¶‡| f¿­Ú¿þpúN¾²Ø±„Ý騝"BÁóðr›jcO{÷ K°jŽ\¦ÐíñiÚ{–_ºØÓFDÊ OÞäÌŽÐ?_ižŸèÅ`ût%£Á¤“q–ÄìïAÔGH÷jÊ|,P¼´QI"ùÿÏ +ñ¬Vû÷¾aæµøæûÙG»žéU‰^b[ïò±sVÿL!gHõ‹‘ä™yn%ŸZ>( Öîìsš!Ùý-øß=)öÐÉÀ²âËfZIÏ–îzï+ã`N1„»zñßJÑŸö½ƒQâù4D+¥›––÷!»2|HDZ¤÷PP=ÛÒºYo7Í!gšB 8Ëjp¯‰×lÃF²eFaCÛ¶lÇ¿‹“âßí?¥_HöhÂæ®ÅÌ?T‹NÑ0ö=’¦ ñòÎD›ªãˆtj¦ã7wˤÁh3FÇrl û ßoá×”¾,* ˜³Oøæ¥ûT6˜sž²¶!ô/{Xs‹é³f®º „ž=d]²­û•ê=:Œ¢…¡—·Ô¯Âôv]=®Ò0E‘çx6Š](+Yõ6p8\qá-°Rõ‹‚ªÂÒÑ=Sݱ™ûÐäYP=òÊpËTzD^í‘Ú,~ü¦æ[º'u{‹WCõA˜ë¾ #nwˆS^±^ãÔ_ð¹]¹v1÷@!CüÁq›EUuƒmèC™`² $C(ƒŸKYËþé9ÖÜ`jÕcÌ2&^ä©S!'Z¢¶”(ËŸ<ÆYQ‚4» ¥ [Ï™<;g|ægHÄ·þ27 ß(ïï¸Ôì²¾5'X­ñ¼iÂêñ«È¯°¤)AWÂÝ`Ö¬ÛYÏIz°Ä˜ð ýAø/wëµÜŸTo›öOëâ‚7 ®R&`#w^.=ÆBz[]ü^RÔkhÑsp[òÿ,>ëHuT’ üÿì]ݘ¬7zM ZGÚ:;ŽQ$ ‡íûŽ»^Jé¿”\*p×Ç«tû¤œ” à¥êhÚu­p…§‚Sgù]Þ»C›à™ÏKxÌÒqÐçeŽöfÌÊH‡Î£-‡Ÿ˜«êÚî=¯åG|oi;‰17Ð5¨lKÒ‘¶Ô]ú½.ow@c+Ÿ¦½Ï)\Fõù+ŒÊ‚Ù¿±Þî– Ìá-¼ýë·ÌZBw½•¯b³ý|¿ê‚öqic”êms?ÑÃ7:æL½e¬)‚A Yr Eè|ÿÈÃ#Në93õ3GÄL žåõx®¯“ ©JûDJ/€!f¿¶÷GCª80Ã"ßâU£æ;>r±—Е4Ú¯´=#Ȥ¥¨ó¡‰«:(Ø ©Ô)¢zU5?„Ÿ@”lv A0@ …+ü5v&i™š=7ätÒi@5¡Ç×ÓQɨgÎ{+fhÅSTÝ'Ö•Ñݯÿ=¯£fR óv–×ïÍzM\fëQnìù;PYë£Ç}ZÝÎÕN5] (OKáYÝ%n< nÈ™Ñ_~­M}ûkšL¹.)„Á¶ê·3µ¢:t¹)tØ‘Ôk5Þ¨^T c#˜-% 4;6©\?„òòe­° ;(ú90²{õé²úõM°íÑ#ê§ŽÞP‚ÍË›\Þ’hwµÌ9ÐO²â¨ØR­O›øN¿ Ýå“‹ðë«Æy¿t±«éU©wÝÚÔb¶åOs=“ʾŸ¨&׆ÞÈ@ß“ýJý+b:ŧF8ÝT™‚ŠØ“(™} 6æ3`°§w$Æm[Á©0t­o&8ÆJ¬äÃ6„™­§áÿ6»PG%7PïíÒAŒ-z Òíf˘®‚Ã’ýý „¼Û¯ Ï'-~uª$;ÑéÝê‹ÐÅ]ÂÑ&½†’yJ†p@_sn­j´œæD?¦&Ç É²ý™2*™öͼþå„ðÛš&×îÐLcâ™_ ©ƒ ^\^@wŒYCêAvŒ‘ïÔ9\˜ÀÏ!¯jàçXæ` ŠÇ\<õ¯ïha„6ñC2t‰Ü9GÐ“Û ˜%MO²/“÷ª“#É»ÀÇtÌí”ËÒ¿n’devÐg¸}¡gâűŒ©WEý$5Häíq4»0Äæ€··®;pl *_Žúú0‡Xá*‡pD⊒-HL{¨òs>µfúºZyÔ(dЬ :ð ÿ.°Ýy¬a*HPÂý_‡~\c{žÃŒz¯ˆg`é ¼©ü¤Zl?«^+V«ü‚ÃA´ŽíSè&_ÕåËÀä.O9²Põø!ð™Ó$mî2B6mêé/†SÊîn)uÖþ ߤDW?¯_Þ­ƒ q‰8çÏçÑéÌËæ.äÓ<.‚r8¯»ê¦8þ­M-ö¾äq£XþO–k3‚ÝuÊ["ÆŸ²ÐÇ©v>ܼ?†g»óЃøInV£âÐåKvw¶ä´DXXï…Ô¥@“CÖ±¦ý@è2íÐ~÷ä¥Üð> ©ˆ‚5ò~¥ËV­à8X£Y?E–4ð”´Z¶ÀÎ[¯·ÀkÎL¹Ð≕ïÁ°¦£Ç —žb€$«É˦ð¾€ö,‹Õáõp_a`FSCÑý(,Üd»NÉÄj\²“@`øŸ7we%¸/”b[V\¶¸¨ØÎNeê«ñÂ.afì Ô¡ÔaÊEF¶Ý.V_v¢‰F•xÉ¥9ëï:êìè~mŠå^qqŠ>hYæ5W`ê+8Úg24™ŸËäÀj¼= r+û­—“¬kcŸ;'*8À{ ºÁ}µ)ò¬L÷Ü7°¬v•Ò‡E "f™’º"³.Z-˜Ÿòˆbë%›’n²P€µz‹Æ=êË:³\ ²Ñ+#H›>£Â õ“°¯vÙPRun‹`ò±ú Ÿ½.lIKr”ð//fí’ ñÜ%¥ÔH_t…:t´±å:®°ŸƒÎs¼¾cëc¼HæŒ1L²¤^„õ ·_ L8Æ[ÞÁòã;!‹Š“¯$Ä…ˆ˜Ô/È<*08®v%šPŽßh“‚dVÌI³E&¨S5 ˜vv„sHÞñ<°5Ù$n&ºÝ¨ ë¬)ŽÁ0”‹Aß°Í"?¡k£gä|óÌþSJ_ZÁJ˜,Aø5 c F¶À½jvmG´•Tï¦e>X¼Ö1ðöz¡˜i³8rû°ãó Y= hÔíát…= c.Œ0—'$ jZT³­öpÎ0P±¬\wˆÿ´ á5$^ý“GªÓ˜8ØÚEc,ÿ½ÿ¦[»ï*j˜Ü2~*ô¶õÑ[TrÝ޾Î2äR·Êâ%¬›¼Òc1ç/µˆ ¶3¡ÚaS ©›œ‚ÜLl¾› ýå±ðóóR›Ûœ¤àÀüš©-hÅÍ ^‘Ò‰™‘¥a0\%\3ʇ¢f é/ˆ® …B©ê>•ϿǣŽVŸIåªZPA4ç]#2R2´þ‰ºYòšÌW—ÅþH¾›d.@õ‡tЯVŒ ÀíŸh[[Ù|ô‰W’ÌÀ]öðõ„ûSØZ‹p&Ä@îÆ*ÍÚ8&à7äÍ-uî$k[Ô¦'ßcð ¡áè< °vbqÒìƒ ÀÉ‘eäXâbÈóú4^ô6U‹ÊžJ9dS¬Ìqíhø1›²2!»vÜ-3¬ H‘Øë]ƒÛp̘&éÖû¹©ÅÿÊÐõndwt9…"³Î› ¯G#ñ¾|¯(YÃãõ‹ºðçżñÒ'Ë}sì§ÛAute@W‹³’2 XE_5uÔ#jLØævÀƒ\ãEsÌÒX:ÍEŸ¯ ¡¸0hÓsÞŸlÿ¼‡Ü¡W¼«bÛÇn{Nò\t¹¸ói¢ÙÅ¿ÞfOO¸ªë–¡çmûeØP>_˜Ç.€¾š¼=ㅕÇP¤¹lÁƒ]ßG¿ˆ-ßËš³êJçÏ:ÒL eoï‡7Öö HÐmòàêºká‚ZÈÍtêÜÚ¬mŒ7þ %Ú¶uZ„Œ+ô@ þ²3å„îmXÅpxÕ|&{ã¹ç—`xÍáÜHbë=¸•~á³ õÞA}ä }«e‡e Rá5ýèhÂ0µD+S^…êã/—†ä¼ tãÌç ˜ûÄa±ù <3é±h:yy~–ìjÖT¸3=ó6åVáQ!ªi… ›^ÒÓYˆ˜<ÏG4$"*ºª³5ygôS'èßi¢iÖ®1ŠR¤uf˜½Ùƒ9tÅUÂøŒ“Á‡fâtµÓrñ3ÂÄ&þz Å­v 7—3ô}¶e\sô ™¶ù;“Ð`½-‰;¤ÓÛ8„ÕpøPç3@ªuŽÙÆÓïßO¦eí–L-qÕq£Q%ƒ”'´ô©¥$Æg dÌf7²ÓŒ²Ì&}¶Éß–NXËöıs¶D¥ó&²XŒŽÞ¶yò›ªšS‰˜uŽØÅ¢ŠoÔz…"l¯ó=|Õ)ÎûøŠ~ÐÒ¼÷‰¤”êD€ÍÒp"Ú>$êî^Уû­y@'ðµlÞSûÙ»xø˜Ë_GÓ¨¸»•‘ÀrUà=Qn ¿îOD(\Ä?SNñ^('m«ˆÚ‹ÒW`M&!¤ ~ÌÑœÁ°ÐáÝNÍs¤ˆf-+¼ðB<)±™„ÅL¾â¤Ïèr{½;ÍVì æ°<6¸mäVå-9œ’‹T”—²`|tö¹ÿxÒ£_MY®ò6Wµ]–zíF6wp^,¬.û'É‘RÇFUM)Ùù%©ÈQk²ß’iJ§˜`X@=CÿOŠUô²øŸ›ûõ†-wé<ÔÿI.é/kk%é,3zÀAÄÅÅR+,´åÄ ÑʿȈµ°U¹Mùêc‹Öá*ü8ëo2›r-ÿž':MÛ¥q¢bto"q.ø,:‹×Žþr• (.?WÌK5uþ5‹0ƒ8i3ñ§…´jµ„h%๔}ˆå‚í : bÒ³36úB¾¢o¥ƒAq×2²ê¬œZÚþ :€(6*€ýfùýúEmÁZ .[l›îK^²ÜÇš)°ÕÂPJ§éB1r !• ~sJÁf^JQ“ÿ·0ŠÀâ;ôwE#è•jWä#cÛôhEÕ]e‡Üw_¿ðXÐÏåÞ]¶s.`ùñ¯Áœp·oáy«!–yGüYÞBOAñË’‘?„b]ã^›ƒMhX’Ñoœâå%ÂÝåh׫ÂÉ‘î'ìz¹T˜p/–]x±ì"{Õ€ýä¿æ>ð2¸ A{qÍf$ ZéñÛÇò˜’w[Ë\Pú/íÍ9Ì`|f )”³ëNPwDÒ%®«è)8C•Õ#GÇòJD3]Ÿh¡Þ_a[ðÐxÎÇ}N§øt:?pœŠÒð¦•TL‘ïüˆ}· Ý;zG•e^XQr—aYêÛüór1Gošè9n§Š·ÈJ1#C.é:c³ ¶1³10YÀà Lh{qš•àÍì°[çÉ5ô‡´±% 7Ù5Èh@Ò÷FoÈîÿEZÓÈÝ€D8òIAJkð„ ñ°1€<Ð)o\ü(Œñ€Õ¾îìD-t}â˜y õÓæ%{ö D¶Mƒüª yŒœ»ãÍ6ݽ¨:€Ò_V=P… Ñ‘`ƒžQŽ›­k˜¯…áX¾×"þ<€Õ­gŸŠ!GÃI·Õ¬žìéÂÓþ€Œ<õXÑ"ˆcqsî®f­oÈÆÏcÙ™Ÿ\2šRnºïëW.%ò?ïOØA´ÆìωÍîâ‹3»OýO槸BcßÁÞÓ×KF'¼à Á¹”C'È–r3(Út ¼r;q<äNdÓ9‚¾\âd’ÆG¾"‰R;qñ¤ÒKYüÀ%Ú)õ‰Û]Œw¸’–pœˆv¶ê "Ó ˜µ·¢¢Ä åÊ"8V&ÒÀ¦š £È1@âÃÑC³z5‚F©§*›µþƒˆGúuáÈOå8º6WoìÔAc«ðå‘jEìà`'™ÇM/µÜàÃBÿ-öÌd@©ÎËÛ *ŽòdœÖ&$`ëüíz­3Æm›¡žôÉÛ郀ZM¯Ç#$;4U¦Ëìú8¤Ò5«ùr"‰å(ÿŒyë»Ç.ü·)}gÓ©ºr!Ç‚÷cŒ›“½KVE+"paIwl=$ƒ±4H±Èẻ¢-ÁóV¥Ä.Øc ǶËöОsä'å@…Ú\FµÏF³2¾ŽGúlŒívàlï0ZIº‘7±IHTo-Ñ Œe%Kü²¡Ç<ÁÎÁZÁ{‘£!xE3Ô Äjå´l›€§²ÃO±r¡€kõcçž$ŠS©ˆLÊÉ ¥¤Wn+׋ÑŸ xûĤ¤5º¡,‰×J"ØÆ ÖøEq‰é”þàaYL®Ð`E4Åžš·QQÓ2ìÿºÇ¡ýsÖ1¸\°*r;¯‚„…чZuæ%â©áûúä×Þz-¹(@n=)™²že˜°ïw#$ª_ ­JŒO[žì‰éÎøaW®ORcÔñòÞ¸vÑõÌ‘çdSFÏ/' ¸v „×ÚGýæãþü©2ö>Õiû×î¡z¨È7 &ŒÞ!Mɯ#óö³ÓëÜÝVØËu^¥†éÞlË xzþuväE—ÆíÅZgutâ7:ë³zsrtJ ëþòW3Yeý¯õZm3Ä!³¦³ÚKð@LÜH/Û,|äØEˆÑaì\6Gý ø'·úûwåRªFøt_ßVŒ²¤qاr-2G›ö² Ät^&bÍ¿ÊÁºp ×ϵýl_ÿk̬×9`pûÛߦŽ3Eîe—’(i@­ôÐsë”n¯gœôûÉx­/à„¯Öñý_A ˜0qÞuoÔI0Öý¹ˆ5óÏõÍ Áe ’ö}·å Ʋ?f•Z‹Ø)/+%ì/¥Í$®åçN¸Y€3P®Y«Š·‰ÜK>§›¼Œà^÷dÏÛ€T—PÏ91?ü%Öid›ÝZ Ñÿ7Æib0 úÅe9½…½ä¸ÁY RW\ƒ"#/âUíÔM_2ðâ—@ð?â¢M͈O§£= cú(»_°Un‰à{ü ¥‡9ÿZ³ôˆõf㉩‚£ "¥@68¬‰AÕ[qRtòn24–mK£e>Ë@åÐ3Ý– Ña žµ.ÃVE/¯#Aé—ÙÖ÷–}œg6r;ªþ%/gÌØáU˶?¾fL®Ä ¶n/3àtÅq²’$gÇÊ’_E>×ÖÆ`ê<Šoð/ÈX@ï¯zZpKaçÂfü¹ñmó44–‚”/>Ùg6í~Û¿ßcoÞàtõÎ"±˜›ˆÍ‹©*Ê* ¦J'¾=¤.Aw¡nÂF¹×âM«+T¥ ”†Bß·tÁ‚y5P LõkÿöÕ!g,a}f‰ï“\g»Ó(ýìÉ’X&‘=k5·o’Ðrl¹¼d”zf32hP‡hOËG/]/¯‘…„Ä”XËè¡Q‘[Úíè6É—½) qGÚXx}©íèÄjó+Dbš—<õd¦>QdÓnúÇ@ Svè5cÀ„0ˆÉ4l$¤öÅèúû à“qœÛ×릱<þýƒø>?1`¿[¡ŠÚæÍ€ñÖFG¼Œ XæÒ⋊~Q\SÕØ4=&[íMÒÃæD"¸M©÷¯Lq¬^b¿A´“Cw½”(šˆ¼üR©Ù¾¹Ì¯xnÛ+¬û!‹Ðk´âêÕ쟙ýÑÊÁ·lû”Ë]*Kî?QˆU 8^fÊO:Ýq¾·qÜ{œŽê׎cãû–k5=ÇÖÐ)dÏÇôESå‡àý.VéžÊòRk­î‡:ä*L$Ï£ßÒ·ñùæOÆÁ¾†–Ð<Š~úE¥Xݬƒ[t^e£~™¸AîýwlŠ'lÕºAG¶Ö€Š¸`å…#˜OÓÚ¹ö5“½C‚ƪIP²<…-Õ¶óDµ‰XÖï—³# gòÞ×V¬ó]q^~X¢B!±û²‡¨o½£ üìE©Kj<­¦)¤ZZÒðœ²aû‰u¿H£Ü"\$™)‹+¬j}åð;Êì¥j6nÈ âh¹ÜZ¦•œ¼Ê”M(¼©I"˜ÂU`äÏøÓÞ“nrÿzÿ;5‰Ï¢PÔh^?zÓV®“Á´YÁ6]B•¹^ἪEê;¤Óº#->i¥KW`,™B:.¶rÿ í¸7ÊM2¸ýSWßVžþéjV‰ZF¯À0r»©”¦ÐÎûyêCAíA{;…¨M~>´Œ ˆÁP)»é}7lµõÒ­às”RŒl0Vm9ÕHjZÅ÷ùò¯_¹} ¡èÊ3 {$A8·*¶a߆ðû§*Gö²ÕRœÇ[‰s½ËSŸ´å:L“»-Ú’$ƒÖ6 sj cƒÁôœ‹ÆâtëˆôÃCÈÚ§Ô ­þ‘”™J¿o,FÏÂþ¯(| S¶H1mZϳôzúv«å ßSµ503 ýz§&9¤Ž¶8¢ìa¯ñ°ÉåO{°¤% )î epPçÁýkìçÞ„a”=Õ ÷ŸÏñЉéÔ(MÝsˆ·I–<°†pO­§MFšKÇfo÷;IBmü‚Hº‚O;ų$±Þ5íX¿îxìÞ’Çš-óÅW€ÈQί¨Û=Ñ4‹ë4Y/ᣥ×ç€&@e§½3).š’sâ¤EºïOø¾‹Œ[ãT_“‹}ÎŽ"RÄ8 E¯ÜílRu¢Dˆ׸g<â‰R^«Ê· Å!  ×›˜µuýpk’f¬ïÆà‰Oé©R ÌöÏÉs€Æz|ý&ZVgeõNBÈÜv"É›ìqúÚ‚ëèd1‚¿³C¸ó×!A {“‹Ï;ÄÓ­Aœåj¢ì¹Ûï yÉj2ð¥Ò8< °ÁýÙKCÓž 0A·¢¸Ž›bkß#ß#ùª¾q‡†Ý´Ø¬Oðj#ˆé1Ð X=~&ž„òÜúø ƒWE‘R§S}Òe"¬9=¼vH¢AÈwX‡.+Þi ·áðúð}°çÜ$ä¸á8i,ÿ/7¿û„‘Âᮼ¼V;û'Ï£ñè܎ݼJßÛ¹ô{g®$ëÓñÅ7½05‘Z ´‹ñ­&­iÀDG*ÕŠ½‘ãúŸ¨Åò¾Ç/½^eŠ9f†Îá2F`Îÿœw;î\ø%úŒ5ÆÖ …Ñ =>MòföÕ }âS­3±¨ž7±€¯ÍZÆIž×­×î@_}}EAø[®Æ9]²>ÅhÓ¦›ùÊÖ.¸`JæÊ«±Mu(‚2|¢_¡¾Ó„ã©£«òôÃl·¾k&iµÜãJºù?c2 À›‘-õè¨HÎø'ËøGœó$D?›Ú‹”‡ª\°Ì ~k™B!Ù‹þ´ØCõ×Ux\­^…{ ÝÍìÿ9dJWa÷[Vžx+‰=Är¢ û÷×!ÕãG… ^r:¯bd›pt„V µíFó6+n¹$zÙá…ãu_°@IgéþÎÀ¡­ÉêÕÆókj2g_Sk1î#»#E¬U$D?]ÈNðås01R¾z‰Ö\‘¹°¹i±Ÿˆ.gxâðj"V’£bK» ¦Šs>HF¥öCÂÖÃa¨¢:SzVOk’Ž9®æí¬Ÿäv>æ£úß#®­ÞƒúQ.´éï&ÃŒ*ƒ©m/vÛÍcLÄ8­z®uÊÈ´r»Z¸B÷¦J%$…×Aå‰ë(¦…Ü¢Çþijè‘>ˆ÷Ã:0T$ȉ¬þg üR 3.è0Y-ó:®`­KÖ·Ká0•zÖßê÷·±Iëxzĵ½Jâ-nìã}=‰2,ò/ôÒ¦/ȃ!ŽÁãÒOæ§’Ä_v0Äg"¶x¨aØÍÏ,íàâšÊikóKº÷>ªÏ2ëðÇ2UØFLXËv›éÂ+%¤ì ùM"óšð}k »jL=½y©ï ©ÝMÄ…GIE*ï¸NÅf4è-fæ–º(4ûŽ ûNƇÝÛÊ*ö.G%)'BâscÊJ¡Ú¾è;»|êø²ìÅx†BåMšR9êâڪ„x(ßt ùKA16ü値CcÙÃÖííqD¯*({ËzuŠ×ú¶ð¢Ð×$í´ ‘$¨ÀdÛzáZ˜ãîD}S.™ÌÛ[ƹ¥±DRd=ßí—ËØä- À®Ž^¤dä!L;x,ßç)‹8?q˜hÙó–17Ó Iãû.UaQˆ‰´]!‚â‡1qA—À½Tðƒ§´œœ÷–ó"çºmØßÄv ]±Éux¾ªìSk+=dÜìþÃ6«ÖÁä™Ë½:Ïɯ*>sÎYiïÈ®ýìù @«Qï‹ò7¥NØ=õOùÃÅè…³ÚxoúÉôdÈyðà0m·4Q#¹†Ñ€ã}X¤Ý/ÿB*Ÿ–Qž¹}ü VΗÝññ·WOl:»mô´‰‹„W7xú7-Ý^Ðq•¤Xõm3º(¥ö˜†Ür—ž™CK]¶þ?cüq,°ª{“ñ‹SÐ 2Ják€ c}Ûöÿ^‡±.#°boÿÿ'É3ê>NÅI5™ÃÎOq.«±¥r™ÿ„n ŒVxÀÖÛÚ‹ŠE%˜«Ö¸ûwÝß…>ù8—ÀÙt˾uM³Èv3ê§vm8…µƒuÿMª§‘Ã~¬$²„Úwkløº¹Ýõ³%“rŠI-cVþü;Æ"ÿDèQQ6#éõ·ksÝø?fŽ„oýéáª% çyNàC]×v’§û2`]wqOV+Â4²;Ä“âS;X½»GÚ†øsŠ8’Ä6µ°eòƒ&>„kŸÁà//?¹«ß!{Ï ”3azl¬ü@uK¥~Ð~1“4@6’úåF1;ÁéX7+þ6Ú1dº´ë[~[¾3›Éøôf2ÿÛ¦™Y6%QÏÂÈÄNÙ+ïÎ&œÔ.ëT‰²=鼸¢ÜD–K±;É|"Êš¶©S5`¬`H’ÖTå¡.«Ä«ú ‚ëá#ŽœeQþe•ô­VÞA Ûêóë4³E~g¾T!ð-‡âþµ^°mêäv{l8¢T&ãw3Ç­D ¶ºYìóøfOØÑvWð_£¯|è¥þ%¢ž¹zË ¥žà$%vuIcÙû=÷ÔÅ8ôß³ {@ž[Îvzxå.É ÌrÚ˜0Cœ˜wÁK¡£·:ïyŒGa§)n„’ÐÍ+¼𣸨“‡+ÆÜú|]Ý@%7’í¯4; èýÉÙ‡(#¯…$¢0zI"Ñ¥º$°kòÕ#U‘®Cîßì ² bÑæ“;ÑVN ƒ]Û[üÐøÇè>Z=Ýj«½³€¾,¢HZ‚ýæÿ˜û²3hxGÝݰŸZMú¨ (b6èlÖ é¿|vEä,ܯ&8‚ŸUÂA?²)ÿý ÚVQĤ\­îæ—nÍü~À€9Éù¦ì~¦'½úñ‹gÖÞÚ­¡,{µÖP © Ò½÷yßÚUTie¯ýÒ¢Âuµ°"£ÊS­¦àÿçTö…±l †6ÃF~ÜŠ/]ÅüÊñó5½ðï‚g9SàÈBXm»E«Îa[3rõ+ö÷†µa»Pµß]ÂG߯ÅQ|þõ)V#“È¥ü²®M©/»uê#ÛvTaüG°mÃÅ_¥Cº¤Cüð`@ÜaÕo^Œ?¯cµ>#…ÝCt0Lx®£hÎ'fã×Ó£sL(e“ ¢•JwlI߯”#È×RÕ¹ÚƒOp‘vÇeøÃ¾~’V-±¥×¾Ø¬ðÞ·4›fîrÃèØG)yK)Y²bmEç¦îþpžø"çvjþhÖù%#|Ø¢yR¿Ù#-Ñfàñ.’e·ÒTƒ-—ñßòê6ÁÝêLü¬’d0X‹ö @Zk“ i[TQÉšßê­†ƒú“Á°Î=}÷…£P”ƒOkÛFjü:¥?îC>Ñû|Þ’=d/k%VˆÛ.A#ŽP´|ÀæËªmÃ(°$ê…Á¯ñÙ):ŒÕ]Þ$)9˜¥ŒÚÜ7 Arf¹÷þnÿwPz‹)ú›€9oø<:c¡>—–[´#[¼ïr(ÏJ nˆqt—¦aqÜõ5âž‚L\ÛŽ‰À ‹Ûi==°Ú¨ˆ¿‹ƒøÏ Á¦¤J½[Òîm/ºÑ/ý£Š[®§þ ­SYÁŲ3Ú¦ýÿ2ºÆòˆ¤¥'-5Á!^OÅs}+ÞÀí¸©Û=ïÈìKM$€ÁðÒùýù󣇾½ósûtq zmÜB(?O•C%¹rÇ%PH˜¶š`BÉI‡ý,;y: ½S¨[EÙêp·Ï ŠG…÷# _‚1E²Ýø%"ÝŸ¬ :¯W°v j65b¨L¢~8°†ibŠ’!3I×Î/ ð¥ÞÓÀÖ¢çsMe.©YiAð§¾ZëÏâØïĬ‘™EàF5è«$Yãø‘B© ™ÿÚ¶Ž²ö£ éàù:]ÝDÏõHJ.=I.L¹<çs)O<ºâ׳P™¢¾A%Ñ=§GUÕfWw’fýühÝm˜áÈÖjê°©{½Å²fnâèòè3Öv ™œ=füÕžWœû_ÈÍ ü?Ü/70 :ý±|ìNõ;‹¬»‡åfÇÅ»ÌHèvxù36²ÌÛ¹¶ÑX¥Ä‡Dö®½i„÷!2l“JÎdï&¦ZÛŠ½«>ÞÕAÓø_åDŠðÂx0P}åç]_ÀG ù£ÏKI0ršájÐ~š>Ó¹]±æˆõG£t›Ï6ØMl)ÁáGc<ãYr…ùv†̨P¾5¬,“‡ZS“XÙmSóE²7Ö¡ñú·׊úkU_Î;ipØ©»õý6‡òHŒ§‚{¿17· ¢FB)¦)øEš»Ö s¶HR Âá¬{½ç,H•¦ò|αYâœ/ô!GòØâ.Fn À¬Ü}¡§Æ²›yÚ釴@ßµõýlF€z‰]U/÷C)·™Á÷?Ót4‚¥ä>Ž4/á–F|·S ;B…·ÑO3ÛÂ!ëB$õÝ.ÆåoÚåÆs•Z(Êœe`[;Û:¬\%Ê a;áÓ;ϯñðãåüÿ  BãL²¢ë†•ÕÂÁÇ_‰þ¶Mv••Ú»6°3ÄËb|´óÚ©t„+§?Ý–è‹û’Ô»¼q¹>a†zJ…wwPÈF¯`–êâÓz2AWšŸŸgÍ5ÐE!Ô1‹iÓÝN QØ‹IRJ½Ž¼›$<ØÝÿ®½–÷ ÆvB”ðHƒ›zk2¼2¬Õ¥ìKÆè‚¯Õy¾§¶©Þ4Øì¿p^ÁûÛBv˜.”xÛîç­®ÕÉ?¡ÂsÑîdCöØ-<ðèQ¸ùƒ’0MmC}X—X’õ\]&U±£ ¯}ÓD<¯2h¡ªÂ›‰Æ®Òf[ì®b̼ù–ûìÆEÊ'_1ø`”¶¦l°° Â¦JÚTN–¦ü”p|/Íëvp®dôÜ Bº3¦BÞ '(,b½©Hÿs8Dõ~9M©Édú²w!©ƒnÑ“ž%ä¾þ¼©O’¼\@Û,5OB@¹\®kƒÅRz³“òJ"1ŒŽ4¤:{”$´cnj7-OáÛÃ]¡iÅ ¸÷¥éúÎiÅÎÖª!‚Ï;ˆV7ü;ùd„3õ/«·PÈŽN"p/û£êà6SÂ_Š–LW±ä¢w… v^[2´ 1‘[lbá1"Ãéç?ºÌWîÓÈ‚"©Æì¢Ïqc¥q®F¤IÁ>.Ié€7­è¯ÿ™«8ù@œ¯!ºÈ>ÇrámE÷.A««aþÀ´‚@Å9œ· §Rž_ŽŠ¿ðw§WDE1ÜÔ`Ç"^Æ_C=²<‘†Uº÷ðâ€}Ö+~¯NŒ¥;êŠË°D{&S ÑÕ[±zSýÐ彸P»ºYL~}= OqEmz¦ëj±éì^P󌜭-^ûvãÑ{¥¾ÁÖ›A¿å¥ jTýà!/Yçઑ)ç ‚9¹ä¡_7ô 3®í­üâú4ªÓÛ'óZîÓ<ÚÔFš¬…6PÓýnL­ŠîÑui;j.Ãÿâ9¢x¦¦Î; ªÈu)êù•€€‘‰phI(Ògw­Šd¤òoýþ'@%ä:Ô4F€vÅ›Œ%{Ó/,Þ³=ªÑÔ˜n¯ÞŠ7"ªú„Vò”DjÆÚÜÐÍMØÀn‚ŠAKq4ˆ€ØçáOöÍKÏÙõª:ÍTZ<)W<$‚êó.†ïobª ºü±âlêÊÙèoX­t‘«Í–×â„«¿/¢:à xÞ¦¸ýAµ¯gÁ¶&ŠäæóK_˜ˆAœ;aÑP¥ð|¿_º Q|DpÖå‘ 7ˆt½’>+‰9Pn·Õ‹TÐòT8çÄðrdïÔPÛ]E 9}ièˆz'’V0 J¯‘ZË=²&ç&¹~ zÀ€m¥J”itxrç;#–ÐwT¼£ 4ð©-Ë’ž L Éo(í!Ÿ ²(Xœë‹{í»ÁK5ÝïäëóÝPh>a@O¢59¾ë"§ÝqT’×&|§¨§õÛè=÷òµê¦– m7cÝsøàœµAlôˆÊ«2ïÓþ*ãOmêд[‹>•îgȪ^‘f”mÛº)ü€¼8j½½ o„;ÐQìD×­ÜÕ›®ã °B¥È À1N7ý×ôú³`yHž–䵫äx? bJg:Ûl¡3 C–]¹¥â]ÓAœÞvÊÍA1WâGùå³¢(§{ûYuuˆ2©Ïí’ÛÖ,”!·”¸°ñÒBæÂ`4¾‡þõ¡ÚbÈÒiðµÚ¤ KØÆâв;¨zôI©­ôŰØW¥ÐïA@bò.DÐŽš}jØp.œŸŽù)É5‰k:Ðìsù…?DZv}nŠ?˜‚6}Èã¥n÷¶|lC (jNš-7W·d4s¯MYs~v¾«ÆÛØ3ŠÜU:½½wÛœ[Œõmc-ô@?ÿfôY'6‘=Íß  c¯™å‡Adé<5üL%ã/²­aƒ9 §˜÷HCu>ŒœSÄ8x[ËE™åâW©åÌR›/£€l+Âdw@òoêñò3œî_3N›n/æ–GrX}rÒëjº}ëî$ù¹ù¡û\Ën ¦Q`ô](&öµ:w£Hs=VÀêð\ÚÍÆHtÕ¨Äó3Öv‚¼?s#K8³Õ”˜€#»(k[µƒÿ;"Ò4-e̵HŒ½åV›n)ïØœrãg ©Cˆ{%¦ÅB¾¦Ûiey°‹ ¥'ʶpÇëMxE0†c¾÷1õ„¦“E5´®OßÊC£`,0KàÛòš3I¨žK|5þÍ‹ÖÓÕìÖ³–öÛy:§©‚ÎYV‹ÕxS!‹„D\ ™_Á™¢ðÁp¥{ ¥Á)Õ$5'ª ?‚\ØC¹|m;¸ >ß$>ÖÊ~ Î…–¯#P_¨l™oYñ\„]¨[KŠã­l¨k*ñ/ó°v"Ì £ÿ ó ¿ÀÃ‡Ì ±S©z§^+V„[ :ü‰¹pÍ8,a¤mlû‰¡ï¤) …’¸’*b8Ãã–ÕaÐ~ñ7>Šg [ºf«€ z¤?è š°o.λ,k}æ»M†eWI8%Hx*<î1kbm 4Ì\¿uȤª%8—¶6¿%ñêGŠb7RÐäùvÉÜá  Ù!y–]tIº‚’…ØÂa(S`?«n™– à‰Õ’!Æ+Nб¶u‰ú,¨UÀÑUXÍöQsRA ªªü•¨w=OÕá.Ëkˆü*îã8*Öƒ¢%¢]ÿ4Ìͪ?^ º­\øo‚¥ôð_ùïÐ_~È:Í9ÄÈ„–C("î0¦tý½…íIJ-Ô?ñd·7ø!pª€=‘ .±ì_¢Iû¿Aü­`8¼);€NÃêy‰û–¦œ0D[\0«Ö³ø ³wŒá5á¿’ëÆ&Z]œ¢MDŒµb àv«Ìùníë«(‹£°1‡»f£÷]HþeËGM{²¼²Þ×>§±”wå%dæ™c  …ßëÈöáñŠßTÎ>ÒN²©g"»­ç¡X[Æ‹?c‹sƒ-ºQ˜{Ñh`ú|ø²{@Z€‰›ÔF ³É˜ŒÙ$¢-×eÚ{O51t/ø´ Sø‡Fùš¸ ¬mI~¢j/¾}£üµ€‚Ry$-Óüõ}‰ÿzb`&ˆ!†—^bÂGÏ4Sfd æÜ~až‘ÛT@VjlËÜÿ!ØÇ‚#.kfܾà tŽƒžïs&LÎò~„Q„ïë)_â2¾F¿û¢jÅÈ0ï<†Ú ‰=ÖHúÕÛ¶&µd¯Ìò¬íÚ8~D%ü$ƒ¤yΗœö±©<ÙcsJ2$K ñ~ È©hÄÀÛýÞí‰Å–Öàî~jC]1l^‚‡•“`ÈåB±l<}a—ö g2ñºˆ²ß(fÏnéü»S2 ÖäßðŒ_špW }¦™Ê¸¯'ú­Í(¶­Í"äP¤%OmvÔí\íN³×#×_A¤!åÙ;=’6‰Rü>.™ŠC8‡WŽÅa†Ú 7;íéÛ‹G0*<¨‰Ã§È£ ¨÷†¦òQ\^¦fxíTÆ¡Ù*%¼'S­}è#/13Hbw7éÐiìÈd£,ïxp€WE)aŠ¿ b¢GrZ.…[Õß}œKŸ<3CSK“E(õ~#=~$s°«’B'T+¨E¸žÉS0ñ§WøfÒo¦¥Ž÷I|gíê1Q*‘C0>ëâz;ZM‡Î^×’— Çvå`òá‹J$qç§ãšÛíë79¿çëóΜtÂv^]pÞ }Üe«"H)‚¯Ý›œœóDä W²Wǽ¥RÖ̼ڇ ÇÛŽ8#×$ãô-2Ze3(™}JùŸ µ&*¶K[³ Åœ7׳m—é`·eʲÅMD b+‘2ø1uy°-J e<òòkþŽ©)rÎP#½½Bø*ëk‰‹[ÓSל}ÔòD.ÖhfG š5—RoŒmÊDÝäwø÷[ÿ‘êlý‘>¬VX" ’Kiš'¸Çqöš Æo}ˆÿvÃËð222ÑDOÈà›žQšŽ`€Š‘ëKäb¯Æ+Fi6ÄÏrº^â’-2„FJòåL€I¢j·t™\RxH£ÁÑù@Ó+KeHÞAÔ3lBÄVe~ž,MïûiØüª¬™·$qÇ_P¯…+û›}€¿ þuõ£-T{–-…H `îÐÄœFÔ8`ÈÊü'Lw2k‡8ÒlÛv˜vÔÒÓî°å·I-¸Öò WRwoŸÕîMþX)EÕé³V‰M>ÛÂU¶dig/ÿi¶øï¿Ro-³a}å6ºj[MÍ/ØVS¹¯C<šê!i˜äbuèÑæ2¬ü²o³nœ ðÿ¥ÂÖ:;ŽûÒwÌŽ/µlïS»z¿ŽZÎ,?!ðD¾ôu?°íklë6ŒºÙBÃÄõóî²ÄM)þŠÛ^š8Dç,…Wêy G øÂZÿ½FÍÛuÜ%ðü7ÍÀ¿Çïb–úÕLˆï“å;‡ˆ_¯“ïæ;ªhê› $/Œìw¯yÄÅÝò-^WH2þèHj»,›÷jv¿Œ­ÿ¡Åy«L“²K¨|L±šèoN(^8óð.ê½°õˆ$äƒLˆj‚!‹¦û zÚP%xòÅHö4?œ+]w"–†³ÎÀá¸' ¨-áÁD¾¾6Dŧ¯l¡èë¬KM™9çÆëœãò#_ŠŒÜ@„qÄP_§¢³ôU©%Ó¼¡Â©å‹‰ÏšTlˆï^ÚáÌ£œ1Š»ð&sX+>o®­G ½üS¯~êwŽ ’šŸØlœ@UVœ!ž?±æ™òKt1 ¶¼ó!Ï(ÌîR´6k"ôàA¬‘|x¬Y2 N}äêÝt¶îüô%n%!®’sP±sú*áèc%eE]Êã¾–0]‰›M*¡« ymI»Ü<,Ú37néòö ˜K£B•¬ àq[lÏ—%¥¦ºo‹%¨XRY –+¿Äkâ¯;]U_ð¶=†Àf™Üb+Ë­›0KØ9TäB7Ôð+Aj³-‹.¡â31 ¸–90K#´¾ûþF¤^-ãR˜zÒ;xå¢ÇœÞöWX’Ë’öº­ëî³`¨·q µc<›åýìBÌþS4cÎz{Kæ2;¡Ú›.L5ÿ¶öA˜aU¤0‹]öìwLÍÁ‹ýzÜGß;*Êš ÂÊÓyÖG希lG!ÁD^~ÿÊ·‰ ý& ÅÀ˜ßçÄ>WWüy…š.¦ÿGïJ>ˆ˜“D{A„÷uDÏ[ZÍ×yˆ(PtÍai9gF_iâ¯)C·Y’I)›©t÷á¤czËj³i'õO¶6'nþ5òœì¤|Mú‚âàJOèI=8ÊûóHÈ?»}”LÑ;ú±~„úœ£î24lcîvT¯—”™Í º Ï'yÊWXxþv,k¤•%Q‹ÜXYÚ4k=x$%Ï𘮻+šË‘GÈ~pùò*µF=݆;aÓøXú¨”r„¤ïI¶)ñLÿKF›jÛ÷ï™öÉœ™é¯iQü*¬Þ <…¤G@3ÅûÀ`ñtÓ٫͉ºÖ¬è€LøÕ-‰Ð¤"J1ÁexÕ³æi Z§Ö<µI“¸êvà˜Õ’¶dbwO劇‡”††Ñ†Ø`sýlWsÎ݇&,ÚiKSµ…ÿî&õ–ÇòH¶™@—]gÓ—äY‹&©>l¥e¯7jæ ½Ò:RÄŸg·ŸJ&1c™¸§"ËÿRÀp$ M* Ò‘#4g&‰„Øÿn>=3•‰á;•$ÃÙ×´åÖM.zr-iU)ç\G÷O|=&´•<þ¼55(Vާ õ{Ô°¥µåzÕŸ¬£ƒL–xBw»µ•˜3³î‹™©€üU˜ÄË=Ëvæ2â“GPÂé¹ažîœ_H¿µ»Œ–öQ”H#c­|åýê´_?¾LR™†`<®4žÁµH‰^k¥Ð‘üÌ~ð˜Áß'ŸU×g^l^àÔ!K"<•ÃGJÞJ½û«A©h¬`ØË=ÁÜg7¶Û…)eé%ŠM0²)wèn ‹4 ¬ÇZ©MÖBRÊÂ5‚Pöì”IT½OñÑØ»ÚÕq¾Â­d “ïJ„úWÖÌàÂcõ쿽I+[þðW lú:œ5´Ôô)\ƒ½¸S–ÎY _B`'T3¹i“86 «¥Y¶pkv©mj¦”_óly"ÁU‰%j‚€ê’ '1&=ÝŸånm6§Hix•SñAÀÕ=&2Ó¬£ìÙ­,ûðhíÙîz‚¼‚ Ë*Ì6ô«ïvƒlD¢þô{Qþ6wfú~V‰ß-?IáØPƒñzUvq“Ï©˜\;‚2>QÞú^®?ëŠîQ%àX×Éàr"³},.•?ù6 i¼`‹ríÍ«Œÿ4TÇh&‘1Ïbòtë$¯-hþ&Ëi‹ðPíØ‡( 6í=Kê°]¶êôÅN.›V× 1Ù®1éjŒ-ÇŠz`SÝAŒ‰,«Ð‹xDå¿÷ÚuD¢¾%0==ÓYÀqÍqFÀÊiÏ6‚ë–Žä]Ím £œ¹ÜÎmýLtZÓÎ5ž3Vº¬s:x {€j£j,Hª½ùfn¡»ŒÔ -·$X¤½û/ÓóM©˜ËˆŠº¹²ÿ—¤G$ýñ+ÀÙî=륤µVA¶Gù·Îôåpª?•&N @]pÀ˜zÛøäécÂò@(±¨Âîƒ6QG²¤§É¹jŒ“²ÿäµÄovÝ©Ó}hŠå<-ë!PÖ|íð‘ž×w‚|ÕgVp‡ž¯±>_ÉÉ8øöÒ-Pöx±OÖÁÈAl¶Wã H²Æ§ŒÉþE€é‡€eTV£¥€c+‰dN/m€‘Æ,)—´¼'p8¶¡t»ÖjõL}JÁé) QgVõ9låiè_ÒYu0´žZ†“ fÊx‚e)ìJIòÌÉ>ý‰eð{àÔ½V̨ñƒ+~r´&Jµ—qýƒ­-ª×K¡«×åøKÂÖ.åÀÜßÈ(áþߣŠb,Τ™×Û­—-6 ÄðÁtRC‚X‚ZÊ‚qô{C™Ì—ÔÛ•y‰Pã·9™ Eÿ#4;[Õ¦ BéÄ¥Ëù} ¶ }H¢<àŽÜnÞ…ÛPU‰¿ß"*íŒ<9¾Ú¦$t¡‚ÿ,nªM==ôlìˆo[CçÏ%m)ÒÉÚÎ •¼ÊAn×þ¯®pÐÚÚ/j>{¶ëžZ2ÌmÚþivG ”KaBãws+ž¸ZŽO¬ôµS]naÝ'oã?1ù…õ·%£³©ÛÝ–ý;ÿØ™ùÌn6ËìÇ€òz•ahÖÃQ9*Jkýšk£8¨ô¹âäê+º¸˜kÚaõZ|ŠR¥ÕÓÍl™¹²²Ç^Ü»{ Ç…­Öó• 3ÃÄ"ǯç×E"/Êt@`|pw¦,Ù£Áq÷3¶¦/"›üÁÆ‚_†ÜM /=“:\;ƒ!lW²†ÙA#4Ê9¹ÃÆ%ðkSñ.Ò¡³Yˆ6¶:3r9 õ‘„‘ÑRHŽÝ¶‡Â=m ¬ž¥d-Þöîó¬çU}Á:³haµ žö^{Nr<éAèEìCŠBæ&~YºÒÑÇ"³ü£h(“¼¹ZçŠpÚǧs‰!@ÒËü(rY©Ò8uš vƒMŽkªÞ%ÀÃ÷Ï-ë#dº„»B\$S]YtZxˆˆSžî£Êìx7L%$xÙ4¨™|.¤|ìÛÝ4Ó¸íÖD$©i›§>õ‹‚OþXàcü½nô;7‡£õtBp"Ù«”hIÚ‹ÛØßQ'áox£àj=JÓ”lþ&¡Ý`' Å¥\£wÒä®B­¶®Ž1†¯¬‹ëb4¯ EçO–!íý›" »²ý®ª’Q¯äÌ—‹î+¦– ùíeÎeúg: ,—W÷ ¦›F,[D[õýîË 5ô(¾4àp¬ƒQÜãõFÐA H¬X͹_„ ¦0Þ‚óµdþjbO{ Ü ó°ÍV”9E˜ýç83Že‹½®8v»Z@¾Œvà’úÂsÈv/ã²ÝŽì#§ «ÉQ0NÚìšß›vÍ_+ª‹ù9?í¥í7@dìnP.ƒZ@MÊ·âXÎïi¦¬|ͤl1qÛÁ} y-Uö<Ÿd©¥ o\õË´Ûo¿ð”a½¯Õ¯ c°8ÚC'vMR_üí`„6‡,•™P³F#úc5I&9”ÿ#‘Ì­úZ¦ÛÖLSŸoY¥õ?§Gähá:Ôkó‚ít.TN«Ò|ÞrÑ6Š0 ²CÂP½'EC²!¡#N…PTJnŒÚgÇu'Ÿ8nÕñÈ^MËà•”äÏ&ëýT´]ÏÉ‘y8.èCÇÞŸ·ñ’ÎÙ•šxÏý;²)\’Ìn6—=M¨&©µ/4™6‰.”—í†Éc’Gz¡"Æ`9™rŽvìfE…x,cn+ßbÖœ£ÑùÖÒcüɤòÐS*`¾W°<)¨6ưyÅPÓ ?˜tÿ Û:oB=ˆ‚ ¾ñôà'3ºÒ1ôÐtŠl¨WòèÔ¹þÜ“«ˆÙýí6“»½õ5¢7âe)ŒÞ†ÅȤAù¨¨§Î#Ò?©|$öÙÑ‚h2 Ì7¥y®ÁïÃØéµ\•acáat'!÷}rƒ+DrwÅâä\.BË]–3q) 3ó¬Ó.ÈL€Ê¬ .lPyÃmËͧiÄÖ¿ëtnõ3Çéµ¾š>Ó7fÚԧâ1Rï_‹pXöKg€Y‡ñ|ãÍßÌ?4 óæJ˜œw$Òånb’ŽŽà˜f ¥Ò^Ù†I–ÌDÈ“bc:Ó ÃÞè°ž•Fxì9¤¯³ƒŒp(_  J¹è)r5y„ŸIŽ2ïÍj$OxÅ¡ìàšãÚ#Bqº ÿÇÂeÂè;PY>{%œ„7PçÃO•Ÿ\dðc¾U­í™CKç€Ïe‘Lšú½áTkÀ•>Lc;~sQzÏ*ŸÜ®~q¢ˆ 7“¥äüíÙͺ‹PΗVC3/Ô|1rZà^¤‘éóNÄbjù <ÑÜ…Œ†+üü¾'õ÷~»•c8ó0°hžq<ˆ_yÜSö';^h´ƒÞÌ9‹C:ꀟ 홡¨}Náý`Ž$ßd ³š¿Ô®/9¯5‘R» OÈ9"&(È9 ú«zp—ÊôŽùR%% ­‰ÝÌ›sû6þ`7ê%£f'êú>6NG¿*‘]ÎÕ½»ŸÉ[G!²|Ä{é”e„áNÏý^•O«†¾P^{I¨bÿ¸ÚøTÍM¤XŒ»ÉGfgh -.#{ ”Wjž®üóþv'¡P0.¿"´Ž‘‘2¹NàÍíö=†…G²€¬§4–â\öqÔ•®¨ÿS s ƒ‘äc^<ñgxâm9VµËeà\¤¤ƒHÉá‘JàÊÍ‹™Õ$ëçô}jÎYóè¡€p1¦Äjå¦ùãL¹pÄÙ¡aJ× ôì]¶aL¼¶LØR‘#ÄŒpfç/–·/¬íÜv÷­õ¾— ¾ªq¦GÛ.€©ezº–ÒãË)B‚Á§ B’ëGÛ˜“±‘‡æáá$"ú ¨ëQñHx«Ú›Tw^çÞmgõaþ2¬6û€ù<Ïb sˆ¬MU@[Õ7^ŸÚß©J¾ôaÝöÙÁ çïè‰saŒ»c׃ßzrÊ}} Ù¾q™J{¤ÀŒ·ÍW Jÿ=b…è²±…K¦sÐ^%Y}ÑjÎQ KùÕŽ­﯃#s‚F‡Ó{ó¢£¥,hƒÐ†-ŽÒJ¯Ÿ4ÍÎ›Žš%ãFÍî§Áï«3Š°Ø“Ò¼“c‹Ei7Î5½µ¹àé*F¥7÷ïl†¬hGNyÝØÕBüC—7VX@ñÿ!íÜmmûŽ5 ìǧHtÛÅ àà#áщá"»ª53ÿoR|+êû1ø­«êæŠJ¼LŽBç#©²1"6šrø¥ #ù“€I ’ã<<Ì…EÂH3xÌ—„_•¤°9 ßk~®CÈŽ:VÒøÝÎbE®Ä¢Y‘Ä‚×Yr ã]¼âë{L¼*Á_‡Ÿý*ÿh·=œ‡­‡ˆhò™;ñS'º©/®ÕûŒ0×ÝÌÐbS˜/¨&u»e~ãÃØƒ(+àHUe´ RR¦A}P‹b¾_hÄ"t¹^±Kœ—˜+ð'•{þ¸xyøh‘žFY`u¸ÉD´•è™;³Fi­1…\ðkàO¡Ñš<Ûo¾ZIÕE‡a@ Òèðï=¥TZó¯ò%× †Qøv¼ø,_óO)²ªg`ˆó¿í­þt‘ì þÀ{Ü\ùbjzÌ Á,ÛÜÜ„ïøŒ·–1tcót×8¤'ÇŒfŽh~ÛÝÈlLìm¬ $4¡ïqdr\n(TÏRôÉ>%8**šXf§ 1³nѧŸ«òŠU…ü®ÛØèµquÚLð61§ z7óã(¡•¸EƒÁt†R&¸-cþKh¹-}[ü§õZ÷à#b€+.è»Á4ˆû¹È–Ñ‹ÂsÒê)~gëå=uëöãÃÁã­b¹©Úû*@ÒVŒro$E渖1¿ô"_Ô¸ ð…=ékN—¬UÕª(ØeœàîŠÐX"è~Z:î÷@AžÝm±(Ç P[Á¾« h±Ì²[/ç²J++mà±u§/û¨Ó[8öÀ[40•ñ“›½v ³ÖÇ'oúh¿žÖß¹¯$€§‰Á#—1¶¢áÖ`eœG”ºÉW@ÉNlBÊ9š·Êi¨ƒÏ¤0ËÜ•¸¯É¶–~Ç & <ÉÕ¥¾½­A×mN} ð+œ=Ìœ^íúƒwY+kíAR#„>p¦J”ÍÕ“ò*B%«g•ßuó‘ñA3†/¤øêbÑBÈ:Ïý襎oN‰ ¾ô`¨Ý.žÚOZЇú„A,´OŠx*»ø£X­äyMgOÔ7¡bõÖs•OµŽsòµñ¸Ð÷åÛGNúÄ×˪øôL=®Gw¹œ[Ý|‰qy~©àD*ÖøíëlÁ§KÍKÒ*‹-¨g©Gƒ ð¡¬nÓ> *mTÑ0Ì"D ƒ^þ®¶mJÜê—^èaýMš| „Ž€Êz ή›]OiWí´Ãæ%µ~LŽ prtüû¸Ð -åÛ$¢”þ(²8Û”á2>p3ÔÛ:÷'§;úeNŒ 1»¥;õk©§-xæçÀ¸Øù|ä[rÇ(¦^ê1‡äQB€2§XU6Ú6õ.6D}XŠtæÍOoÐ  ÑˆÜZ´•k3]„ˤj§Vo;¦ÔN~ÓÀÊyûåë°Lº|õ+1ÎOlÞGß”›þ8Uõr<ø³4XõÞôq糎‹þ.´¨óO¨ŽŒ¸óæ|ÑkÉ?S¤…h£.¶KÃ/‡ßÉSÃ:°Ç!Ñw–Aô T«ƒ— aº—¨`ñÆVØ~œuXò ¦l×ég´ÀÇ÷×ÖWäs'Û¤—Y?U‰1BÙNq}> n&ù½áúiÊÏÈV!ÇÄ…×Åþ€)’êžõ‡÷¢¼ uâ3‚ê­u›êé|æ$ ¢C W}Z^Û.E7Ò¦[Ù ó‘èmn¥Éqco€:8TyçMé 0oec æÉ:2 ¥4An¥Z&h™(Htßà74Ãù0”Û=`ÈÛßC,ÖÕÎ?'yòÖ)ÌÆ¬ ýÏÜú¦ ãåŽZ~ W;ŸŠü}_B)’ϰ–|Ñ¥ ¼I€·"n­ ·¯ªº!~ò»Ys²Á×ÅOc  ãLáWÒö*¸åMDÀ6(rrºÈëz™•ìÓuÒ%»ôºe„E=õtr„1nqËÅñ™x¨?ã åØì2ãõŒ†|3fóŸº}Ü[’è4«Å­”ˆý‹JõmЂDž Õc÷«Ý~¦aê©Éqv#t¥f©óÚ=´ÊˆŠ.!0åe‰â>ַÿz{S7•øž ¨õßf­¾µçˆ: <¥þ?¢ócYùUf‰dW§ £ilr¾[å²g²¥ß¢‡ÈCƤ›–B‘VÎ~h0«apwAx®=¡ÍVyZ&#û‰ŒJÙ§(þòyï„б ¥VÂJ¯<{õù_ðαb}y!¢{DFŸ+A¾©Ùü’¤Í9­OyÆNw4ƒw rˆV×’òV¸O2?¨1ă#F£¦ì⃞£±ºÀ?° ÊäF Œ‰"¸"ui&5"r¡ˆ®%=Æ€™„¼ÝÒWcWå%º?*óTMɪ.àýîI.øGäôKuOŠ©'¾p¬ 1ªSyG0y6ÜíÛûGk”¶¬Õð:À< `DÄ)MÇœÃß——a¼ª]ݸÃ94¾Ì}4%Kj¦ï,A2ÏØ-¿`>!î¼î/Ö;3ÛèÛ4€~‹wÚ½339ö‚hŒÐ¾Ø¤G¹*‹‚‹š¦¢Þãð-biÃE?ÔY%)qS„rSB¼¦š4Ý·cíRç*B„'K[M{ÃŒZ\Ùüö¦¹ÒÉŒȸ¯×ïþPtùŠLšîÊgiRPŽê›X—U=¾~#¤F§Â*TÃǺWq§:0<Ðíâò!ÒJGÕ±Ð5(Oò–b~r»¹éÙÖƒeÀT!¢0\1ü‰ ÑHÉH—çõ5PžøÝf´‚3¬ô«•“ðÑɦÐSÂ˯'úÁÞApèçÞÝ´s‡—ØSçüþ˪íá:[’3òΓÂJÈ"½ŽŒ„Ò'é‹ÕT¬ÊÍ)’ŸEãïa&Å‘€Í8ƒyA0òfXòÝò¨Îïx‘FâÀ_ÓFcþJ{Ó©P£¥6ýÖòÙîÒ›ØX6³Ì¨tÞQIå6ƒdýi Šx^:9w…Ô š~nj‹'sЖÞ`à¹Ç›få ¾ DžÅa‘nÔ/ËW=ËuÂäá“ÇFwòsØ¡TkêMQ kœ—ß rtf™$u–“Ô]dM­åÂ6 Ê­ ¸gd‘l©U…`M3~,ÖåèÇV—càîÅr¾\'=Ìi#Ðkp²=Ü~¢¶%À~¡@l:ן^ð±¥ñHÕý5©_홽Э6NœóñóY}6ÀÈAéSw€ BOžéßl®rdõ7-5œ”䳤ü`GÚaL,•"píΟü<8³Áµ› ôçÉ„• aåËX+Tyt[ã^›Zydª«(Kô2¶{ÖÉ Òb:|;‡!Ù†]”Hv’ø7œÄ"9«çt˜juñàbÔU,³¾ðt ×[Ö`Õ6 qy¾ãpò¡4Ç+ŠPÀžŸs¸{þ¾ìëÓò=y‘²·)±äþ”Eúö,ÊwR3]‚å”Ð-Ãj툮ù§—õwÐYÐ`í{ñ÷5]àÄ»–7Ö"•Z]¯jFÅ`Ö`ì3ž8(šJŽ1~ó `¯^—¶<ñ·ÞN´30IJ>_nf‰%öþ¡ÎÇtÚÆþ÷VòtA¦8@*çY©,ãØ8uXžsÊ@pî:nÍÑ<“)x=¥ßÎkÛ÷pˆÁÌR/›f™¹~Ca+횺›€r@&¨’hD€†äÖýŠ£±{o5ôT…´_ÓàÂñwëy ù˜Ïô|àó‹*ÖKóí&lØãYŽk±ýÆ•0¯?æñØö÷Ç R¾˜ÿ|C¶cÙA4I§¸¶O KR*A/7PKªÜ½UIgHâ£t .Ó˜Ù#´<öa°ÙßÚX7µý0µÀß>Æh¢IkêûÁ)dhèÊZZõT™Ãp¹¯^ûÌqdI*‰rœshDŽ:.riÊéúXÙŽ"3Z!ê¬VϬýg‰~')º¢/Ïoêµ4²«ìéí†C´JnB—u®[eÍ#tŒ)_3üzžDÇÉž>HÏ)ÃÈ9p“³‹*¤‡ÇOjüŠeR^úŸÓš9Ùi¯oô¤Á LÕ1Éì¶Y=ƒÚ¨¾{}»kI0n‰}Œ©å K€¯„‰x›[bqI’S¯››è*…[`]ºOPgDzéYÈo¾­QТ—K§Ã»Ëê &+t ìP7|ÀÛDçj»p¯W@|žŽ’RÿI| egoúN€þŶ ”Û¦_kZQ‹~»Žý•"K£ŸK¹* m5c®÷5h“â[S¤aÃ%p¬@X>ih¯””mÃ8#Òð}§ymº†½‹U)D¨Ö»HÒ’¶yΧÕ,‘\×€GìÛ¾ušÉÿª)ä(*À7óa›#ÓÁœD¦P *éÙ ”5O¿+<X>ct“âß{\Õ0q’Ü-Äv†šŽ*p‚ñ«,µBU+3ÃÙ§³£%Išøù5Í’(ˆ…jªõ]µ'c÷ŠB*(÷ÿô´ðÝÉšTYtàÜNyI·f´35 ñPp1¹|KP©Wvðàp|W®põ*·uܽIµ›2yìhE(C}€Û!rçäÆYQ£‘•ƒS6GÆ?ð41tï'oìhìÛ‘VᢛŽúÕ7-j»¥Š,Ø¢¤R€©¯¦0Ø´X6•CáÑÃX’âk¿5í æ)¡èžäôÑÙ_\Ì^}57·9ÊG0²+ðZ«˜X„ÿµ¼¹ªš²õäÜ©Ë~ñ¥º ]7°®8²u9•x\üëK‰ÑACŸQA s$‚ýÕaJB‹RpœÐ)®èZëw¥Àš1oÂj#®Ü­Ü¬÷2±5K½±‘˜bAÕ€Œwn*g¢ð,ãàwª`ÆŒoV¸–8Iž£#Ÿ±[*%†ð‘r’¥!S4Mæ¹ì.¶“ÒžêH¼¤“„s´ªrßÂwÄÑä:ÆÞ, ˆ¦² )ñ¾A®“S•ÆCîÄÌiÙjË5“_«¦yóºªê5Ò:é—FÑ%sщ7&W…ì»@œPVÒûðãb=ÙÍóZu¼<ÄdÀS\Ó]T–  3ÂO]e÷ À®Ë’;|iq=$dLZí¬¼R%ãâ\¥ ;þEt8Ìk!u}ä!¨IÚ‡åЈ×øú‰Š—¨$š[gü™Ø?9$ÚKÔWÏŽ…8Ä ÊIÛ¢Ô¢f£ñd‘¥JÀŸž¥?Dó¥•2qd=¤múúDT‡¥³£ ó÷˜¡8Êé…~å–oÈÈë;_…LŸìQOZwÜoM(.ç7±—½R6ŸDÇbˆ†ùùy!ÝzêŠÅk'XRAÌp@ûı1i3L7ƒDãë4Óñg!‹—&özÕþcÔÅM‡Tµ÷w7 °jŠVoÞZ6º³:ûiAÁ³ZdH-vA¦ìÅ™—]Dý|9¼`s³”¿vO7siÓD4fùÐOxÀ#îU‘ÿŽéj‘ÀµAj­ò( eÛ@=¼‚}¢sÞY2íüˆ2`¤‡Ê-€þIG#°¦ÁßE× ªÍa> :¬ÛÈ1Õ8äà7Šðëá HëÅ¥¥{Èõ¡ÖBv €Û¹­¿ Y¿ˆÿ#­³OŸ „\¡œJf?ÌØµ€1~AvF`)ˆàùû ô‹–ºÕgòíëi"ŠJòÓkƺùÔlù°I£«ù¸D÷Ähõì52=˜šyñT¨â¶<°%Íì9¦'xˆx5õ¦ÔךC1lµ‡Ìu))•{{¦º'òð!3‚zĦÃzԣܿ;IªëCÞ#zL²¢y«´Þö´ÐÖ$Ф } ÇGô€#KB*$ؘu­êÖ9¯V¦g#p¤ñå.ñ{`W\ÐdágÐ:mp\K>\ÎìV(Ák[_yÏH˜ÍxÃæW••ARt ó ªcÃ9`UCd!A,ê.¡ð;à˜AaÛÜ—oòðAQ /¨»Ó ”‰ôîg´=“Y5çEȉuÐzàÎ/ÄÕêx2Åóü|^W€ìô{ùÊ#ͧ5qÄòŽ“¨W@”L¾Hñ-"n˨o“Ñf®’§ï6ñ@ÝD̾_“Làš .† PÝ' ݽ¥c¬…]óµÏî²Ó„-•âV÷ð~pžè’Vt”*÷÷qÝVmò„ óÝ ‚n‹”|aCª)€žb¥sá–~’ÿ¹I¿S8‚2íz={—ª-!øAƒŠ„“ªÕ¹º`ô  óMá—X Žzׇ·³‘GtçaQÉ}±ÞÑ9áä«1ÐÇ[ÍÏ;[ó¬„.‰l ï #r?È_çyMlÁ¦Umb„ãßé"kãê(9¬žp=U?¸wmý>a3Ýîp[j¼ÿOYq†bê›7lmR‹(X;4Q\ÛÍçØZŒ“Þ+Þ­¹g/„H!È”°–ƒ«÷û¹¯÷ñ,0‚)™ÉK†eü‹êq/è&;»v®è­ï,àR&‘jÉšê™â7@¢R¥èÔsÉ#bµ¡PÍ?8(Îõb2°¶ÌÏÿdìe†¤MГ¬s½‡šŽul\RVH¯£ÛH·Ç/\/Jºj>qßp˧†I6ʹòÆðñ™¹Q›Ò{Ù™’‘'}J0“V3ÚNçP“×ôÌöû²©³¤ËÊ ÀiI×¢±ºb¯Gö¹Î¶Éw8´b~8/r-¹XïUÔ÷*á¿;Ú?æS»Dùvå.&ÅuàËIÃ_ežànsm2¶ÎÿÖw1ó(Dç÷:Ç{j/$t4¨—3Œ#Å2.h·È.A“&”€¯sõÖäèG•௔ZœÕ øÄxÊÇåw—­Ã}lk4+Šþ¨´&̸:.8‚Ñ/ï?Ö#íÚ ÆIg‹`Ÿ-9sç{ op«” ¢H©¹÷ŽÃô3¯»ÎÚLYß³Oùò>gÞz)X.ZgpPc0˜+$2÷°‚šç,HsÈù”­{‚±Õ¸v6bt÷c»/íàÃE¢¶kÂÿ{U‹óâxç÷32¦âÈ?·AB„)sGí3{ÖÏï˜ËàÉPš &~ØÒLéÀ©s+d͉ê`l§#™ëMâ]à]c/"ÚCŽÐ„hcR:­2BER¿t ¡ÃÄÌü²J —d©³×‰¶B¨?Ú‚z…9ÎGϽ)á·l ¼Â%*ˆj2Í)w÷³ÿGŒ°»©Œõ˜hhRÞ=§Þ»+úkO³3=¾—·&”D¢ådêeÕkÄè¨M ‹rwÙqÿn+ô§|Œ–¤85€|2ïk3T¾¤7%ÍñÚâi¬ ‹q©ëÙywûN`fÓŒ?sHT“zWPI ‹Îðj¦#§Ïˆ@t`*O€ï¯M[Þì ñ£33¡ rjôFÍN%%ObàüöD-Ú¶”5†¦@Ðr†É+·Oòû£ñ>tÂH´­„aüõºùµYbvZK¾î +]á6\šŽ°Æ ¼²l—þï ÒŠË4¥û™øÄJÛ‘!¸@pƒ~qwÓÜ”/h¬e‚f`&žOUY`%«vp&o™aÄ„x\ Óò>­[[9qq_#O× »a Ï"/È©Ååïc¢³Ëć‘[ ^ .b—ùÂåÝ:.ÖçG!—Èz¯ó$w~Ê–ÅÃ5á eM.vE]ÿÕ|ÈáBž’…S Œ‘&1`󀬮뉗̬÷6ÉÌ©7¹‰¾xqˆ‹>M\õEíMê)õ@õNb#’åög6ÄÔ!Ÿ#"æ¬Ï§ù{n †êÁƒºð ˆ¢î¥¥DÚíŸí$¶¬D( C<éásiM»ö‘”mfFÀýÞC>ÄÝ–Ë}†86À·”P5[† ‡+Q+LÎYT•TKà *(krèϾһƒåJÉà½V‹D£›ˆ  ½q»ŒÔ-&é@ÏÎÇD!„¼)#*+|ËÖ¨‰„o9iåj,…%¥×Òìxš˜Iܤd’Bt¯õ¿Û_n³ÉHŽn**Ï™D]ØåX½£èTéWaƒ`š˜oq'œŠ€ÓåFÈ¿]òÀ±žÃfí«ñ«õÂHÑD¹›qðÍDøÂÔ=—óMþŽÿîCú¹2æ°V®/MBè£Âm<3(µ0+–YŒsös~¯y vKÆð#e¤ø?ÇU˜“B›îD¹ø!ÅÁpG‚(—1Þ_„$š©¤êà¡-•Üva1X<ŽÙÏ[<5Sƒ  V!g®¤“rHyÓ_õÄ—ô?BøKΉ­ùÃlÔé¥MSí;¤$*›Lv×?]{¾<¸V ‡Í%4Ï{þ@‡þäWÌwªŸ·~Ô©ôMTXE8sŠ3¼}ë¸3­õï»1mùÑ$ ý|YC11»Àõ4ÂkS“Èþ/®‚ì.ákcLü/ØqàÅßâê"SÏ3v^BIMy êð 9ÿ„‹qûŸ’ÇÚQ €ƒýÆÈqÖ(i»?ûÂr~ÈVz¸[âŸáÙ”Äð'Yaª•GªâV1”ê&-8‹á œ` ÚÈÁXC¤Ñì(KezYxC0[Sq›ç†é’Ê¡3sÇ.IšÐ¨ÊOÄñ¶¿aï#æõ•`PóÆbñšìB ÅüW>¥èuCU¨`½kc/ÜoþÅαÊ2½ýJA÷¥÷­èúp®Cpû‚9ÖØÁY"³Ra³OŠn?&ÄÒÉœ;0>|%\ù/ÏÁ¨#;Ô°€DÓ–ùV†¤ü¾ããAåò¿Ë}nº¹ŸÕ&ChëT…’ÍK’ëÉFmEÞËØ/`m(òöÅ‘²1̺Ë­£ù*ª›bná¼"'cúßÔö!<-øN’ù¨Ùð²”~WËPðz “\läÀ2è${ÌÔ”õÝ2 ¿P£ Ó8nV ¦ÊPéK’΢'A Æ—_àŒùçÒ`*ª,½Òç5ôT”ÖÁ…T Y ÕKP”ÇŽ6Üéèu¿J¦þLhcе1gÿÓ„¡+EqO4j¶Á—U»ÑW_˜ÖQ÷زžÐ´;ªN¹ƒÉr^+~ Œàÿ1MZ¹‡~dޏqÈ|–ð.‘å1h¸ˆÔ\˜ãaÕ’i»×¹jRþ'ÝúPzDD_¢–ç3olèÐ6ç$(¾âÃÑiëGV ,æÕ²Ê{1ñ¿ì`¾®ÆéâO£˜ýнC¡˜Þ-ËÿFjëP²ln3x½iÀYfÂaL€‘"5OÅ]tâ73\ØG×I;”jëøôêP2“ ˜þòæ‹™Óv*yCGÙÚÞµ08YãfW°ßɺ Ôˆ1«dT3/“%_m©@Ž/„WêèóÓÂPC _Eª¡î߾ʋOãæÌÉj1iÖµ˜q¢*Ì}O`¸=f~[¥×#æm]=™RŒ˜]aEpJ„OuùŸ³JJäÒðĨFËðôÀ€ügBk¦z&úÆËžGetaÏiG YäÓ7_Ñ¢;î0~¯:~é ø}¬mcU’‚€ÇÍQň‰(”'wi íì?uiŠW6ÁÆ+[Òï™lB_D“Ð3CͼÃb_Ûä),Ô{Bˆìú.hÔ—ŒZï IÍ$R¾”ú¬#®™?{UØ5²’þû* ¤éëzÌAh` ::Äív¨Jã\öðdÕ­5 §mdþ1æ9R¸ú ‰‰·NhCÎOÏ[Ô°à]nœl¦Süû1Öð_« úaác«È2cÈ¿51p”™«ØGšÏ&‘BÆRf¦Âža8fïA‚wqj|@nñ[ÜCkö†•B¿˜Ãå2ëÀw|w+÷æÈ´ÓϦ:­ž¿»¸ÍYs¢Pè‰N ‘±Ü‘Ô!oeón8=Íãì•IóËßå¥rý )WÝvÚtÒ-æ~à‹hÛ¾—€ž+tÓÀZöÏxæ³5zÜÿ§/ÔÏ /õ÷Vj4;ÁÔ¼¦[UÎDfÖÄê¬+ojm]Š>P\Ê•¤÷;ä×X-?Z®´Iz‘™ù€–µœG óë™Æ¨h˜i=tß6ö¼aª›U.K­ :±_Ë$k(Éï \áKiTNiŠ$»ËïÛTÑ¿ÿ< Õˆ 04\ññm Q8¹‚8C=™@Ð…WE”w¡Ã@ù—ÙÖ™RB\±“òݬîä“Ì·¯“]×ïåÍEc‘xnËÝî¾YÚƒÝ6÷uFçŒ-h„§iM¢\®¾*þ5“j6]°6}ŸÐµwe~± ˆ°5ƒù°~&ðól•^Ã7pl>„a–~²ñó­½ ¿%EM €na©_±s¶ÏVNbŒ°2Ë„=Ï“™(ˆÌ·ÖEÇ©^ ]Õu$³Ï„Ág8Ñ—J´’×#¹uU[’¹¬p ;*o‹ºxmdÇZæt=gEÛP,ÕæíŽwÚ|®éGƒ·k®' ÚTh¢|¾7‚(xväÑ´ôŽ…×& _¥½E)2Ú†ì'ÜÁÒsQàÄ| ,AãTOÅ'*[o$ þ¤» Nͽ9ÿ?blË!ư¹³L«L•ņkXN=²Û6:nÎøÄX+3¿j™é¶Ô@nEgƸMìøG¡ RþΈo[½ÊBΡªQ…›;ÊÈŽOš¨ Ø ù‚Žvjå86]á#3}î XŸtçgzòµ˜Œ2²;ÃæŒÙ naØ*¥ÔRçk «½f)Ð{¥pÌUEy|œïÉtXèˆÛÎÃCAÍ .ø`ɲCÚꜙb´G=e¸ÏO ÷Oÿ U·.|žU=Q ÿ°L%Æïs±ÍºáÛO‰`X¬·é…]z+Ëi€÷À—uÃÊK ýÎÓF‡ã•Âne;’#>þ?‰I耽!ç“ GKì$1¡îœH`|›”2q‰ÁƹËùÝx#¤ïÎ¥s;Ì냩Ý*2ÄݺÃW¼¥ËÐ )öÍ«¶Ä'ŠNØcÌ­® °:\Gwy3?Ç*0ϯ×0[ôL¢È¹msu° ³Ç7¼tð_³ßúƒÎå!þÁ•€|é‡ óoþpmWlk9ÿ'øq&ösž»õ³–‰©^"˜ìxOº¼5ÆÈoBT»þN dÂFʇLø{—˜ûëDµ—÷¼ öY^;[ÖB2ù.}]§ÄdI•é!îU>H\Ñ«øŽ”GÌ>ªMgúîÎ5‘“·­4⢣MR|®ê¦ôvr~Y|mmE,àt‘àÐ% +-ÔûE—|é1¼Ñ_’f1y1(.˜p¼Tð.7'%¿MÓõ¶°íq@îÎì@²0°-¥mbsx^¤[ÎÑ;Në¤rª v‚¸»b uG@¤&ÿýê•6‰Ô;“]ö—> –BÔÍÖƒD/ÜëL%_Ê-Bˆ˜ZX®¬qù‹zrP¿ª Uµ?FÕ¡Y"îsð €ë«>b¼±šù°uLŒ²OÌœsÿDUvZŽ”A ´Ð8¶âð¸+{Î}›{º2ɳj#ÓežüS|ÿʆ¦æÙŽqË9Æ n,smX\MI>ÓfiªI±%;»ù-v"ƒÎjˆ´)´QúFæ>Ã)yè׸pÜÛ.“N«»–ÚÆE[83:”³™Á³[F˜n>±P—S«çí~I•G¾DÅYQh& 9ÃRð"mù‹æ­ejõøoÉŸÏúQìÌíGáxX¾¥¤º`ÀÇñ+¸`*¹©œ½C˜ï:²z”´~&hX©èéˆR%f:ŠØTR4¦)”©Ë{Yî :05%#žÐî:‡:ÍwçRbËýˆfa2ZŒ½«º4â¿…Y×]ÜÓ¼‹0£AÇ’EòZbK^$Jüø;ÊÕA&Ä­§ûߪ oíG'(ÿÙ›(üDâì„Þ íèÞ¸’ÉC*Aò‰HÜßâ%üÛÆÁ¸õ"ÝôQÏe­ƒÚÉðŠ? ý4®ÎÎyÿßáµm( X¾n¿À•úD_™y±M%¿ÜoŒqO]­Uk€®65 ÷ÙŒ^Hº>ååÂU®M>ÞֺШea‡‰L€B-U§¼LZ!ʈZŒó]à/U‰½‚xÔd##sí»²âíïdÑð@:¿«ýð²§->‘2½ö üÇæ½²íâþzѬ€6bN(KÍ <Þá‹ó"c{ä*-*¾¦lO0¼Û›ëøÜÚÅÕðà8µ‡5us¡Ü@f2ñÈdj)¤†$!Þ°Y=* ÙÙ½#UxÒ?B|I.ÇÝyA7i“>@£Da ó\Èÿ<ÙíHaþAút>ÁÍ"EIðÕ'UùÇ1?ŸôÙ_ETyÓk–ÏÍ§× sÕyÃ@üm8ã—Ó§îÕàmó3Yfw¦+OAü¨ý+z˜K‚ÎuçLáêÑUïà»éè› ÇÕyjyžö•8ùä{ë-/ •EŠrÌÌÆÌ¶!ß*¸öšô0ó¢žp žâ\³K‚ÇÔ¡rŠ«iö&ãÕ ýÊ”¹3ÍÖÛ%4Å‘õ“F»lYswÜ œçŠE´"éžîºHP÷<£<¾‡ç¶…¯ŠaÀƒ0†çMê°ú8ÌŠé­ƒ@1,ή°ª³—ß-u)·|9¬ÚoÛD./Uk\X&`e\~ë°µå½ †§ÐÄùÛ­ûHÇJäu´\/ËñFèH–‡Ãó~ŠógŸëI ©œ•[íÿøbˆ%Ó}ü¨d äh þTœcóŒU-§ÄY£çûºè€N¦Áâ…¯ z n¿1©µUPd°k·i¾4à+è°ä¸Á’|Âû‡DRœ±ó¯²¾7äù¤Bö&Šs Ax³$ë#Æ[ãTþzdÉ͹ä`> øHÞYÕŽ&Ú²óÖµêçD#v¼v;«ŠV˜¾£Â&U¶wªþO«|3gÔðÅ ¿“btMõîaÅPL *NHaJýjáõ(Šr8‘¨ÿb¡2ÍÞVk›!æQ~•¿9ST¿´u\˜î,I#—»€!° mWèÙ¯º'¹bXX€<‡ì0Z•í6BÆô¶=“9¯I?‡‰…V¿3A•·1 ¬.3OÃ7\ÚèÃúI*y{0å{ÇïƒUrw¹‹~ceÊv,! ‡Q˜ž_=-oËlõ;–ìL‚EB€ƒÂô\5Y8yÖþðo7šùãÞ)ÿ ~IžºMg/ï_¹¦X‰Ç¨\ÚêívˆíÁÁ•¦µÿŸým´‚xSÂ_+)=wmÄKË!^ô·Y×86ü¯ CÜ)ybÍfy 3œ}$È ¾ä¹5é;Ž[¡qƒ#1 V3šôoí¦Õ<†!wDXtËàûl¦®E!ýY–Ó#Á»R ÿíŸ6R#%Ùàˆ+k]hvYy¸¹ÿˆ&q ½Vžg”9Év{µdæ˜>¥&¾Õy‡ <ÜÓ")8éÚÀ©uW~d”êaÐêÅ È«ùo­[NþRn­Ky˜ÉrkdOI£¡©š‘*°ëê_€ü.°§\ çv»tO?Q/EÙÒHE‘üêç;ù¦î³ú£~9up´HãHYí¬'x3®ÎÓVÚjËÀì>‘üƒÐ+01¸É$bÊ!»yMaz`ÿG\–Žã”ĔΟt¢šâðho¼/œ qö›7=™…n ,3ñö«ê=Ùü°xÚ1æÈzMZäC×?:/K³ÀÁ\yh“&ÓbóÔ= üvýìŠÎÝ骖 ´:‰m–×~01—Q» ˜€–¸‚©~¦4P§„d/_…Âê•foÏÝ¥Œcµ"²™QðzèQÖÅØÄÁùHÒÄèóÜ‹w9HÂýÕBB_ãréT•úøVAï¹LLbÛèÕc¢ë`HV1þ±[È£‰¦ Ùnã¢)K¯ÞÛþµˆ·,^€Adea\òksy~«)rþîþ´3]Šcnd{–ÑIŒtGDì˜Í´ù-7´ú“ÀséŠæF*Jt¥3æw äÁ±Tö.jaÏÏXs AÌp¤,5ÉÝd‘¼øo¡è0²µGŽÔp„Äþw?³?Ç•Oë €=ðŽÁ9ö$í.~c•¥ÇC¿hsÝ-OF©&ßèüÏÕHZq™ÄIªïÅͨžÔñŠéÂxÉac «£il´f`_ר(KJvµê·¿·ípX†Î/Læ÷¨%êøwá[[Ušu)í‘Ûœè ú3ƒsLËRtÜý'ãéVÝs ¾½bl.%=û=힪) /̆bÜÿÎ"˜:^x*K©ß @]Ï UméƒÆÌÝgW‡Æ 9I”kŸ¸`cµ'íÛVM‘0 ïÙ•]‹sú„sÈÄwG€7¹Ãàú"ÙBßèÂÕØdN³Þpw>ûËïð†¢UwiŠq}JkÅâ€D€¬Ü%ei% ùç–Àô©áø(Fûþ&²Âˆñ¡*ؾÉj¼’è¿âM±&å’S¯´B™¿Un=ÐkÖ¹{?³Äh¦å‹¦€sF)ïE_¯ú¿ü/iSÕ³D"oì{6˜É=Úõ†\eØþ±ð¢oUiä•vÄÒ‡EúH òÜI‡bø(­Nbhöw8þ¹‰¢]²î †$I™ËWZïðÙèÿ„Ô:?^Ëþioi"A §¢ü£íÙØº½a À“P¤eÄÝütTÌ*½ˆ“2‹èžkÎeLJ÷Q—Š[:ûËÁª¶§P@O…ò1ʉ>lêuʘ¨4J@P×'TÄ"óLä^ÍðÝ·“SY…¼Pˆ­N¢½±VX¿ˆÚ$®ëñá‚¶Í,±Ù^ ?}ìªýßïSz0>ÙôÜ–l¯vZ¯ÿRpßn–Wm 9Ê#ã ÆÇ`_ÖÜ4ó ¢ÓT^ ¿Y±Ð]1¨ˆ–½›geÞ4c÷ŒfÑH¬nZ@„Y 2ÓŠ£H;{}0Ñy"Áë~ßeÓ«Æ0æçÝÞxÛP ®ó?_zœv¥øÎPÓ)^aÑ|ÆK.¶z.Kiü~tÄ ;]/MØm¦ÅŒÛ×P dÕçù.ó´O•tº¬ï‰UìæT½~ÍüFöQ}B…Ky H7Ù9X9Å„ËÌæ—ôðĆÊÞ]F<À€†D YÙÒ« ¯Ïy¤™Wí¯=¦½ð½ŠÐ¹àö×#$ÌÙ¥FÌ)'!™•96¢ÿ× w ¦Ôo‡êBo)8â’žýëc0_šóúÝ VH‚ãÎòï‚?hðô}T¦çþ§ëYÏòÆP¸=*‰u á”ÒÈÜÌdsM êŒ k‚é×5M íÄ<â7@…?‡ lØu ¨–®œÁ¬ZHêä—ZM`«ßÅQ–á y ñ_É‹£„Oj†ƒÿ(UÔ½¢3k«tÎ} @¥P5,Æ=4X;ºàÀïS‘S5 oÙ…Só­ÕÙJL­î—˜·$}†ð ˜`ÔÖ3Éqâ¾81óµB'zó;¹Æ„qé‚9ŒUÞc€âÀl¢;n¾Ý*†NßBB™†"á|[Ea¸ngx…8îp,W¶ørÞyÐð÷ °Êûj‚Ƴ¥/:LÛž¢#2Ikh½?n”gÑ#Þ•ßúÝ…`£_K—΀Ñ\+çGƒù êüÙG>… ÿ×› \Î~W“H/ø:-݉óÙà#Ј^€Ê´P¢Ë޽®:$Þ¿‡úÔ¨»"+³âŽd¯ß@ìüý P9ýÓ52a-’ð‹Î`Š`8YÅ0á øpÞ“¾ óVpws{Ó¬!Á+dŒÈÀhŽo´Nè®O>îe¶\U¢ùARÞ+MEã/0Cû ÀÍ„ø h…ymŒOîr¹WœÉ2­A zÖÞgø·eš?µrUGð¦¢}÷ÜK ,„ a Õ8“w¹“¬AàáU&¤ù‚Œ‘{©Lèèu, þœOËðL0+íê‡öêÓó6ɹ¿Œ“.T⢋YÿïÐØuƒ'5Ë ¦Ú—»ò¢¦w¤sÀ¨¶0VmúbÇßGtñL³¡0ô=ëüí–ÿGݵl)ú°–f¦•Qí’°¡ìÍÍÂûøMbDí“`©g,§¶àa›Y/–÷¸š¹„í(ãÁ}DóÁ?Œrx† 7¬tyeª§5¥¾TU¹BâÆPÛ¥v• ±†ëy¼ÓN Šˆ…ÿIcs$AU›&tNÝq`·|•ˆ‚¶RÞWtÜzmÅt€d¤[A ì©Qֺɽ†ˆz¾ÂŒÚHâTÿÚ® 7µ)C(##jœ‚Ú(Š2ž ÏËâ¶žl)õÁ­WÒMD—®Jbì@Õ»ÿÔÊqzA³‰•òÍ0ÐõYxG@æ°3NÀÐß·5 ®rò'uWøÙì¿+øª;Ã/…˜@Ÿ5Æé MÈ݃zûû˜ ?€ºZjslñÁÎå?ÊÝŒà#Óô«›2¬ *…ì:ðïxÊ·×ßrÚÚ”0ø ±lsæ­D˜×gÂí KH»·}’=ìâK!ï:{²"=¤Ò¬[Úó&1¼BÎè¢Ö $BÙ¸“I`d¥.ŒO%û6&r¤£;afÛSÛ8˜õ<ÌFÚǽÀ¼Án6¿d¨}«ž‹=ÈX|;qVèô«÷Á9ÉߎD4_ÁD%íÜê®úÿ`³—t÷Ì’×ø½þLqÙÅl†9žI°8"T¤'F¨6£“œbô;Í4¿hW;TqQ¾ð²õçÙY‰IµGcüt67—ì »­¬Ÿ9bÊ;Ñ#u^ûõŠÒïo¦ö./›*[¥Ú‡Ïl)D.cýëÁ©'.Í%G7ðò¬õÂ0R–}U& ÞÛAK¨. ©Fy>6=j)¢i)K´¶;\öQ—Ó̦- õúÁy^¥ÍÂçžjs/ÀJÞO!¿¡k°™“t’6=ȼU Úål\„Æïˆ@]Ãüÿ}N´g×%%¸sª%–‰}àõDdÉV„~b+¢î²`6c;0¦ïBÓÞ2|>eƒ‰øôÝ»ÙykK¹¸er!q­&\‡ïWæ£(`æd÷ì‹þ™œèçÔ÷öZ–A¸`b4¿ŸîkqC¹|Ÿf—5ˆ¨hïz\ÄCÖ,}¶0i¨ÆuˆÑ G§™ƒó#˜eùqÔðGNž¿ñU[’«±óÉOÖÉ_í@ Xˆ O˜ÜŠºÚÔE"Ö‘ÏÄø³ë`ViN áþÒ²ú»ÂB÷'ªÂµù«šðüDZ¡±ÜsÅç~AÑä4 že%Š#ZBà'm¥Ö2H–œcîÖÅ0JÜ*zjãqz‡ €ÄG[M[,!r#­W(…aupÑú‰ðWY1ãF…‚hLÿ¡ {ÚÍæX í¤pMÃφÎÍ>¨q¥ÿK»7¹ÒVh‘y âpÊ:SÍÜ=©kG¤ ˜âÓ$¾k¬àJç|…-•&yg`FŠJu9Ÿ¾/ÿ+ósjdï‘w¥sZí¥¥Å¾FD:øÍÕŽÎÍ=+ÒË6H÷qøˆðI¼Nt áhâï# FÅLU·6«8XNÓ>@Öå ÇŠøÉ}«Æ&±1šÈç{ŠF‹Xg^)¹º‰a6\šAÔ,`lšôá L¸Gêyü¡§à˜ý! ·¶YƒáH‹«@n·Ært-¡yi©‹Êµ‡>à`=¯ z»¿:P!“Àz­®¹§»Þê0ì‹Ú>ò#ÿÆFI¸hÉ"Kc£Ž¼òL®àIÌó×­šŸ‚ '·;-€‘d¾Œd]À';é{óºä©ûÊ}Âh»W£T6éìU –Œøjaʾ&ŽŠ®ù‗&,öNŸ#òÊù¾¥D˜ÛÕ»´£rh'ÈÒø ~á8 z|³áÝÀ꽻܅G¬y-÷â }2Uh«…iÑlP¬_)û'nKû‚¨0¥÷›1;¡¡e ×¶s¼¬°Ó´kp€î!?£ÏèŠÛ\†}8’ËIÎZ¨UŠÊšpk:ðt(âv×e²µG%BËvl1Á [¶ôïÚŠDªúâ›ÚæÛôÉÑDezò¨9G-ßO¨møÑ†lSvòþ•¡¹@½*gðjSn[ðOºoQfû­‘Õd¤<•Ÿ8(9s»%¬wnàßX6ï;ØÃ¥å©QuFÝ«v4phhŠ;ÍN\ТFý¹]ÜÉ“Eëy½Øá³ ïöÜZG.‡A®èN TíöyRÎÅDÞ„VIé[¢Ë#‰B¡«OH«.^h`?^Š)Í·ëªu¬ˆuwÌáïS9àC?iL2=ÞÇA@¢õÁ}ãê'y]¹·šÿŠŠŸˆ¨¸{Sµl*ŸØxpŽÃcª†[ Iþ[Eê„Y­Bz“*±9RSÑeê’">`¡·JÔ9‰2üNKþy™#Ò§^[4F/{W%²¶D*“ ¸d88ªÇìÙD÷+Iä^tÑ*È^±$iøC ^ wÈU³û6×ê/¥Ðºž¬­D:ðmMÕúÒÖpZ"z÷ _ßOs ü‰r•ªú ˆÖ'ê,z‹™«`)öPõãû‰–Ò†@r4u4\EÉüþ…ÎuÎ¥ÃA€f‡;ÎKà ´Ë“½/§ªþ:SUú3.´§êà‡.¨ü¶ ®´?ݺ§¸öÙ³ró;pOdïØÜ¹WíùxÐì^ž¹”¿P€m¸j¬¬9ÐåÞÅ–Âæš¯{§­u ­˜N P Ù g{IhÚhŠ©‚1ä‚<äLL}I“‹ÁõöãreËжoX§ =îžÖØÑ Kþ<‘Ó/,ŠàÛ9³ÑE?ˆ¿­…~âG}ûCÊBžŽ8²@³»®tŠuw8?1gÅ‚¾Âçm`UñêC¾RíÚ‹á![*ý1ƒu=H‘êÌÒµêvZ±¦Ìœ÷(OÙš pú5¾2¼å?‚ÉžÿÖ×›ÓH‰Rãšï ;áÚcqÖJÏ/»VrÜÕÇLV0b¸ÚžqxÄÞBè/ÏŸ{%Dœçê~4žlùQp¬BŸ©Øéá×G\ÛWôuyˆË]„»‚u°|Œ—"¥ìÔ1)ð#ŽŠŒ–¥¡ÚÎOëª^*[ïº!Ÿ¥pŒÞÏ;(92ü „w g„à?®×F"4Z©Î_hË©+tŸA=•@BæÎŸUš—½–H¿Ì^•xÑÛZè:ªœ–Ä'å©4Ôê¨"Ü[AtËú|‚^ÎT0ÓÒóìså¥âF·ÆwÖ·ÈŒòA]ncšG’!b}~^­œ‰êö4Á+L_#ÉÉ­Â’VJýÏëÐ’A ßjƒx6 .914Ë»íá3À¿ ³çK$üð²â™cCåeyN˜ v 1”’Fp}&0 ‚CàÐݺª\u}n%›A,ÑrŸA²ª¡[VhÖ‘uýX¼yêP©W¿‰ÖžA"\Ðe{8–»=‚ïÏjÆOT>×íÁEQ¶$’ ñ’’È[…À¢L#9q„\Òüa†v\чb¢3‚8é.Ë…‡&‹wIsê!{ÆT8g¿Ž6¶¯¬¶f¹ƒWW+š~¾¸&øp¿‡q¤x³3ÏÒX4 ¿h–~5õY[;ŸŸ¯kv2mcpýU-ž¤Ì/}(/û~CMÕM²×Ã_ãø ÜH5¯Õ“=éhþOÝQ>.ÄÐ*h¯õhë,úÈ{™Åþ`3FžµHË y•¦À*÷ ~gMXPgÜU7x ÅJª|p*+Mž“£V;…µqGO¨Í›¦K'dóÃ^·6ýÓù(~Ÿ”œh½sSèkT • òÈF²‚›‰/½PM1ôOBNRmödq×';”dá%ïï>ýøe|má·aµYËôÊóµF¸-UFúÎS­[zI÷wø¯Yê­ÜS ãØ„;à¤ëáΆ}·Rýć.¢_ÅfnaŸ;ûQ•,Ä ­pJíõx½=8~Øb¯æ}KR˜Iô‹pŠGaÞ ;nHmö¨ù-J¼‡^ÄêvÊøjÎSؘO4ÓSNùž÷*E¡þ¿é›Í¸ ñÊfž! \° ‘*Õ³±¦æ§g«¨˜½äA“±#¾À-°ç×µõzeHáhV6ðq2ïthb7ðŽKT€aˆå€óÇG‰eÙ’+˜HQZË6Ô­—²P Õq†s1ï »_„4½Û@5ܶµ BR‰¯‚Ä’æ‡Jù¯O"Úuæî§II·WhDÛeì‰òõ­‡“‚ýxäA¸0Æ%mô®ßç#×›äwŒ.ÃCÖ]Z§òÍ|ùƒë7-€ßÌzñ–âb·Io¡,’ã¼È+ÊÑóɵ8m"d>Ø`¶’r1?ª$¿·£ ó†b•7èÇ ãKóÙËl÷¤w([µY‹×ØŠB ” `ônݸ ],5¬,ÝÃÌ@±Ù–Hww"®³å¿Ú¾ØWʪõ@ªòªì!âRóN‘h4Ý#À¬âÿqtç”™3×aÖÈó´ÉR Úù†Eqmª¤4+çîÌð¾“I.(ß"J~(çBö}‹Š1íx2ÝÑw%ÐÃmY!#€¯:q›`¸ƒ.üªæ_®èƒ½of:˜F¹EÊŸÀÜŠ–õ×F(‚Ô2²íQÕÄŽÄk¦MÔ±ü—êýâsùV%w2<,›ŠºE•Ѩ‹µ"Çâ_~ƒÃËåÔåRú"© ?Òóû² lþm,%RØk^…¸=ŽkFéÖòHSÜÉrìn©óçöÝ\çHwÁäT¤XkC)ÀSÏNy ,Wb`“ùûoÛõœ~â98\u[‘+’Å._u‹ªS51"1„~ ´wpðÅ¿l¸©zsio°#†ÌaÑ,SÄ|Qï¯b~æ2¿rY‰_°ú!Œ£­L°ÿ þEº—Š·B?V©p†Ù1\ÈQñKC=È{'ŸSåÝûƒxõÍ\JñŒ­çËó5©¿©zðâÌÊ+Ù§gª°§½2+Q¼³l…2Öõ¶Ñýtç¿\V'26ô—âñ.9â*i8I%Œž ÆøÚÙ÷<×ïþ-E{èV©Xû€]^=7 ‚JÈV»òX?DQ=ä^†7ÕÙHÝôã¡ço@Cô3,o漂¶A8EaÉ£’9æ’½è(çBLšcžÉ°h ­"UÌÿ%×ÐÐ 9ÜŽ1®« tÏq_\‹õ'‰qK«·Cã&%à+'hÚŽ¶véç2šÓ$D}jÔÐP0 í.E(<'lœnMQéØJôwí3°«S¶þ$Y 8ËÁZiãëoTâÃpBëþ’ÜB—0Ð?67kÁxQu«|[c¥ÝGu ` .C°gŠúÇšØþ.ÛM6o$¤£«ÿ¤âM1fnpáv™ºø"Æ¥‚ÞL>µŸ?G|‘…UÈ*ío΄0[Ÿ¾sßEl¡Cqš˜z!ÈkWQŠe; ûŠlÀ6«Z\Á+ä›iPISÌ·<Ã]ÛèDJ#foH¸^I°Ë:®$w®01󕊾ßܯ¹-!—nDË}W”›û 6µ/öx¥Ñ[ÃDøÎD_º cøõ%6Ï`@@ÔsÛJ‰…§Q6u}üÖoòÁà8€6|1>¥ æcšðm©Q‰¤P–‰4bqæ»ýx߈kÝw8¼gCσ¨UuŠ£ždðõ4¦ý5£M½Ôl}¶'/…‚óRÇìêÚÖ~o+lÀ^pl®ijY´K¯Mrm ÚÕ l«à MUWw‹€³±@ úAÀµªZ¤K‚âϨ½ÄÏæó„%Àí9 åäÿ‹iò|ƒk‘ˆµdrÀ‹„”D<,¸\¿H   Úx$Ôµfß1léƒëÜi+(6Ýø[šÏÜ;ÁÑñ[S<‡eÿ8,Ïjªyš=nzɘŒRÂ*ý<âöWhö›Ö*ÛL…| yOñ¬âË,M t8žq¡}3–Lx —ÌŒy”2ænÞÜuW¸é¸\Ko# V¹¦€5H&!Z®ØŒóèŽÈÔÊûnQ"ƒÿŽl¬´‰ImÒ÷V†#vïð{é}PEó§©~×¾X4ËßÀ8%<2é‚?·¹ºÛ½k#±+âbƒo2/±|zr'«k/ ùHwÕ0Ú’ø‰.["Êå6ˆ¤‚# ìj2騸ä|^m†BiÐþ*üȾ"@›–ºœ ÚeUë“ùãfX²/v%¸?§‰XXIN§ l{÷.©9!¦Òº÷&®‚ù]þ4Unìf[Š¢,7‚¶2r°¹è·…oª¼ùìMÿù¬Ï–¼@v‚´6:ìÙÕã7ç&Ⱦ¢:û-ÇŸ'ÔÏ·2ÂZiÄûÿ ‰¹bÃóºbÅeuš Ä—'¢àÒín<±â•€çôŒàÏxnÄíò ?µß¤´ËQVuøÁN·u×ÇaË8”i8¾ØU  Q“X›«I»lé!­ðüîÙŠ\-©è‘.Ë×¢;,h¡Áɾ/l:ìI—UREn”InóQ”ÊIîTf‡£Á‡¥óß\,ûDÙ <¬6ªl¢Œš5¸—¥êõû¿ÆÇߪ ×Õ|‚a]hÉ ︖~_â@Úƒ»82„ø;pË»œ@BÁ7r]• ìºçìYO2çor]r*K×Ò0»=¯VJð'o_Ô‘ñþ‚fD ˆO*ߟÜhíààNÍ`䎕j8ûŠ@áœéJ hÓ‰Ö-a©âÅ´#jh_-< ¯ ‚€¶µcHÂWë(è….¤h?Q¥ÙÑ|âòŒ›Îuʃ–N/Ë•ýÜM„ÞÛ/¹r¤4à¤Ï8ŒõþD˜òG)¾â-˜9H«ýíôVw‰Élôjƒ ý(Žƒ+¸ ñhzŸÙ^ú\¼åøa sÙB¬º÷•¨[¸ÏSû”ý…0уf )Ü7Ô/+ÄÆ±ºí ÃV -œÔ±”Y‰Mr6 kÁ& ë?rzû0&l(%á/äÖ6¹T@ã?­dí²]@;fº¬&–ãšóëUßËyÓF‹¥€@W™Æv®n#&™?=§QüòÐ`Ô)jh…u[¸ª ‘yrƒL†$†pf¼"šÿ‰J’Ó9„ÉÃ&MÏËÏdäÚéaLZ²H‰÷A€/¿›×…Âzþ‚¬fÁe’ù\Ú'Býç6}•‡#‰ýìwžî©7Ž‘· ¯è´ƒ:TÑ(lˆq¢¯Ü—mžsnæ6¼_Ýf5,ÄããÊ@±î daXÏ<À W–2…ðG»ìOª^±Û›môtªsrvµBê4[¿´ãÒç@½øö™¬T<°6ˆT ¦â2&ò•½ê~L0Öm(Ž·jÉ‚äÔOÛþ™qFÏž¼sbw8ü3¿ºÛ7§©ô Fã­¯šN¼ 0ˆ^{ab%“b«`úŠæÔ߯ fœì…â‘õY´°|f—v Üü-\|Šù1#BKs³.iÔw7"ädðH#;\Xµm0%RTü³¥¥¾‘5ûYP¯¦»7VÉݬ‡ÊçeH7Ï’´•„¢ãAÖê=¾9ÈCñ¿ç§)EhÇ_X‰B=TïŠDXÙ’žæ&~|ö¬o{û‘Óæ§AK¶¬ýyŽXË÷§ìc¥>ÿ›EÃÕdÑ‚Âõ Þyæ¡cÇÈÔŠ½[ž¾Î ª­lR2Cä)Ø¥º*JÉvYRƒL8•êTð g¨ÅDV¹È4«Ïã`'<Ìß<™±¹«ÅoåíX©CÉ4ªåCŽהʈqÚ&pË¥±6üN²Pšgây²©Å·ÌcÛ#KGbõ„Ãz`+ìA¡ðpÔ(\¸Ô¯dA =/ÝÓ¹Õ0~š’¿ŽêªÞïËnÞŸ´‹85âöÜÐ;)V”k¬ÖÂož$¸ÓOû[÷IÞjó¡Û©!‰hp@vÆÖ—×§EðâAVíôª}’v^Ï^æ]PÖ:qø¬dÞ‘ǬT§Ž‘Z¦×1Т4}H­ãÓž„ÕûŨüdÜ=9V¶°A»¤´4$œ½üæÒ<¡„TâF¢…úužwÖ±Óé>„ö?òvêiκðæ6;Hä’Ô3‹9VÞß;°Ÿ^g!ÌДðVSHײÑV'wT…©ZP¿CIwÃÄSìé'…ft[–ùE6“ - œ¢¦ò¿V×\W+çBÞ‰›ªàß“{ .h+ª!>îã?~R´x^%¿}Ç“™¸‰õ¯N”ž/elt'tbÀô£ª«;µCž­^Å£â‘çͨž0€êd“° h²nˆƘüóJy%ºÁ>mqkÍÚE ÜøoaÈ2ð]‚`“ƒæ«¶«ÇW¢óÜwž}ìvJ˜iå_/Ky‘}Ös#—nà¯a?.éÀò¢x(œßÏq–¡Të´ ï³èGUŠž)`o„Z Fž!J¬;WÀý Qb0§Ì,xoÛl€1Óö©Z8]_ÍùwŽæDÕ™º¸ýåKõ:íg\€z³³o[<äçïÑ3È+ñ ™É¢?rè«Fv£¥zëgy*ÔZ«w#! ­™uÙ‘‚Ë|ɸhÉÏR„§¶ßr}¬ä¹ne^Lh :½¨•ßË\¨ŒsòÞûã C‰p¨Šai‹`¦£ì¼%*Ê•žø9Ur¥sÀز5!´~wsÂ?D‹ÁAºÛø«kFh¨|7ŒC{›õ§lff«Ç°2d6Õ4Ø+8V25>enE«ºædãHá+Ð×±8v J­FœÈ6i·B¡›Çhº~µ¯’⽎ˆ¨³:yÛK˜ 7úÈaE‡°ŽsÌîŸÑ¬Öºvññ?_¸& ø Å¡:ц/iéÚŒ“0…:v4á¡÷]/¨m¿0³[IÌô"æJ¦4|Mç€(ÓØA! Dzmì…h¨ Hý’Å~Ò,8)fP D‰ CÂ)ÕJ˜žµõ2n&F…zÐPƒ˜¨ð´ó§³TQˆØ\þ3 bÍòá¦ô¬óù qðuQÊpÿ€&S2ت®w¨cu¤Ÿk$DRÝÖ5–ÑÊ—ÎŒ0Dô´¿dä²‚Šƒê’„¬ç÷ãš!øÍŽ·**‡q"s+RªÃ'U '… 4z²•µúl¾õÍšô­³áßývF[¬$$ƪ1O@ãªö VlO3r :±'Íöw5Hïë­ß{ž±ó)Û lª~O¡Èœ=™mÜt³°)óÞœÌÙE†ÍÐnŽêºÅÎð¸Åj¿¼¸;œÍÝ‘WÞ"ØzôÖ˜ÄwLi GØjˆt:«Ì9ý5'ï-<ô@SÜlDìê½ÿ0ˆyѳp,'TV;þcRf5WÌXm›EŸÐzÖB?zÅÒ|wE³WxjWh½ Ó¶ö#£+Øç§yÁ!SM7¨³8L4ûŒóñ@k©Ø´…¢öaßó‹hfdÆaC´«HÚ–o*ó­§–Ò²€E |¿=`·s.¨»ÜÜ–kÿ"ÿb>·ZËük¯ èõRš®±Õü6²U: 8Ÿ9•éø»”ÜSFWÙyÇ6"­kEÙ“ú§uoG´(‚2[@Ö=kUqÌæ¤BQÌà¨÷ˆmFPn†("x©¿ás‘õH¥CxΑ"ïŠNxI8߇ÂY.U~E#רJÞx ¯úÔÿD«B|üm%[Íð|ˆBfIºR|¡OuÆÝ£òšöpD@¬xáò··’¬*¢*ä£cOÿÀ300ï¾MRD©‰‰¦š·qüÙÿÊ Í 6ãnÆ—-J7„œbÛÔõ‘::/"€Iiá‰ÎçÃ8³:ß|‰z‹Ö|™wdQ?¤êÍ16ŽŽ(ó§¸_êzDª¹û#î¦AܬóÙRp×\÷QŠ ¯&ñ¼¯8=úùmѵ?3Ž^ç º\öèŸ}Ü;:55Þj"ó?fêÎÄXw¶hoLÊN| ØÀ^þî¤lÙŒx£Ž2âk—35?i:•æ*>ù–^)‹ƒJ“„ñnòŽl’pp¼ß”W¥fÝÌ1t§L-ZdÙk %!A;ÕÓ‹‘LƒÛ*ÃNœz`ÇJJrlö§ñƒ™–¢iˆ›LO°»}õ¿ Ð*GÜ Ã{£€KŽXWL>ºc”F®ƒH»¯áoÒÖ£9ÜÚ8"}²S5Ê|ÚàL-5¤ù%§ʬÆhi r²¹¶ óÝ,¾ÀöUM¦Ô"7;X§ÐI*jàœËXc¯8|‹:·Ö% `ˆÊ¦ë®“k{|¼ñˆ=*|îoÀÍõÖæn'íçC²lÓŸÕ’…O&µM£Tƒ€ ö<–3Õ 6/Õ ¤Ÿóy6Q\]Nljaµíæˆ(àĪrFwÕÓÔy€þÄ:üZ] gçÛ(8ý¹ù{æG÷¶ÎyVjðæ»NaIC¦ÆkvÏÚÂKaj·¶°]%dœj6KúâÈÜv‚;IÇ™ß*GF[ß“šâ:й;)®4~´æ}¡„R^û4p:0…¸‡ Ùø6Þ¡½û̼㭵<ì cõXÒY: Ú1¨µ_û·¯¼¯cÚËÓ$g §Dœ”’aÄ¥Yò¸;½p8Z B†…ø¤®+ÃXrm;§°¹Y ˜ø„:éú¾Å§©­ez ˆT`¶Ì·²ž“P<ûôñçJïj~t¾?ËZä®ÅÈ Á ÷˜õ(- ˺êG¹;sÅ—Æ"P3lS·Hµ’c€ĵÌdºo@ïÐd÷z½?C8z,Ð1ª«›"}PÄj"h¶f|i˜ ¬1 ç ]Ö*ªp§5&SïqÿÝÎêLüìÝÝg>j¸vr  MÍ«l];àEŽå éGXG κ€Ñ>’²—µÄÏøõû1œ O/ã#––§²ŒO¼ÔÒež³Þ£}Ä𡘋ԉn/m`ŽÖYðÝJÉ”`-–üPž%ŠH=£qZ9+¬~¾³\«o–à9×_ÕJ{$¹DÛø.Ù:Z®*~Ü ¾Èó¶Ìœ©TEc¤BvtTÛôÛ9w§xHÆñ¸àðkg£ôƒî “ÃY¡¿¦ê$á¸AŒKîä=ñ,‹ì‘ûXœ@­å§Q<ìßS°9wqXDP×pΖÆàaF=[F¡îÕð'×=CCFÔgýü*?aŒog=k€â ÆÝ„´ ®,—ààRÒ—Ü[t—¤ˆº¥¤ ¦ù»Æ/±—", k«{µ¬Jž; ]K§—gKi1n“2ŽÔàåÇ0ìòž¨JŽ6'g– |uc‘wÄpRZéj{ÆÖ+øëÞÕ›³èý”÷Ï `DŒšã²'ð”`õ$B=R°áTÉK¦öSôkÌ$å­auÒ¡~Ô«{ݘH ‘Ý9`¬ïy·øý_Vžw=ÄNëåÍ]áQbßGA#„\ê0y¾rð'ìÑ— üœæw“å bsßE ð°aÕMãåXB›]Zõļp7H å(‡õOŸï$ ÷ù¼ ¤:aµ29™È‚T @¹’¦K\8Ó8‹CóÉêN¬Ç»t;µa‹¸EFlÀû߃ѱŒ/c›,˜÷(/¾¹(Ønái°ÕˆðÌq­L5waq”{˜7F4KÅúgÉ çþ,€ðà¯-01õãÞpDL)þè6«›¥‚©2aÛš‡ÇŠ 7+¸¥hž4˜9: 9ŒoIšl \é ‡° ¥ ýÒ•.Ó/!¤˜ÔWpêq«‚b¢>õÂJ€rlÄG´ôÛñ5zýx³X™À<6;ÉlîK}Ü»dOëöM­hu³/U5v¸Ò»NÛlK¬/fˆ\ƒúV>›yö:ÑÎE<ª@ô°y3¥EänÑYiTƒ@Ê1H Qg«ƒî²Eòs]”ìêHöÿ(ùãË!Rð5w.Ëk)b|¿šóJr¡-;îø‚¸ÿÂ!>=Éø?.†Ô§+vß&\zc‰OU R0önÏ2-;ÙáÚzyèkt;ÌSÓ܈ëÌ‚ëð|ØVªñ ÜÆ2_(H&óMŸÕedâ¼ùÎVBu2õW•—|߬ ~‰åX€ÜL±¨ý½_к#n1S*¥<™kY,]C½ªrâûÓVo3šo²£¢õùÒ3šo×,ù ňø(ËT8Y²ÌV²Œ´Jàsp›d‹%4¨Q>m:WsõÄïpái&ô 9&ä£ÀEìLVÁ{ž€Èê‡L/mi·å Nô4åÑhÖOƒÊš%¹#'ÄïŠôCÚ% µ¡ÏDnëq¤ŸüQ¹‚2»µs ïSŸ,è%KKj0âŽ]—XøÞâÕ@=Aˆéî‰û©ÝR{C%Ú|^y á¶×d¬m…÷>_X…¬öÝeƒM°×»—qO¹×4É|ä¦ô^qŸUïJ3]Á>çŠw>Ÿr ä¨š! x„É‹Cõ»_³nˆ÷¶ÙpÈ‹doˆ´à!„9,o¯ô"òF¿±…茴ÎQqcŠÚr.:øŽŽ«ÝOzžM[çr±Ë o[ëð ÕǰEût¯ÓÄçŠæÚ4¯7ưrá÷Á6i`äCà¹ãÀóæWŸGØøó…‚ð×BÅÃ!¤ä]@>ðzm{høLã}5Î Þ•¶½jJçšâàŒ§S VÞLB{¹f¶F¥iŽ­Þ„ª—Ç¥–ƒoKÛÕu9݈ÙMض1aÆBížœ¨¢eÛ)YÄý€ËîVD!)q{2™Þëaþõ0ë!GŠä>3«\”.¦ÄJד€úfØ$}Tò±v{‡§µp~$äÿ3¾¹ûVÎ6%vŽy@6r*{h=ÌÅrq­ÓiçÏð #Rµfe)nËEœëüɸ-C™]t ˜[cÂ2j…û\>©ŒîûÚ„[7ä¥Ä<ÜUnìVe7çgš—G |*Æ£²ƒ'd¾ŸêMO¤t*Î)®‹à¹pÉËPRâ‚ á·[2}¯öw¥’˜›±¶­Hñ’¦ÑqAü<Š©¸˜ÞGGwŽô‰ä[”e–(âÒ6akB0é‹­û@†–µ4騅}g9C%Q;•þñHöÈ\ÿ¤Ô iÆ­Põózð-ìËäó”0v2Å‚M1ÆèºÍ™»‘ŸÐ}_ÜVônvŸÿER¤.óã[ªŠ,-¯öcDì ÙL˜U½Þä\iò¡$)‘PÔÿÚ`NîšëðùLf®kìt‚·AÊîÌÌ£äêði’Ò$<˜óy ›LŽ‹2ýj„º»O†Ãà™gÎÂm_§2 Äû¸4¿Døß}Ñ|K`)¥ÁŸ‰GRÄ_’‰kc Áh±Ø[0ÅkaDÌëô Noz…u¿pOñïp¼㈗%i9áä²|o~}voÜËü³ ëÂ\Y½‡š0݈3cùiÀ¿Êý%ßàˆ—ŸÙóÒ/¿Qþ*¶,†*ÖnwuAA'‘¯ýøD=]Ú;Xµç+‰S1if?Q…ë‡ÑÔ>V·ŒwÉ, á8+¥<¨þ…£ ׯ©ƒ‚\vÏ‚ùßqŒ '£ Ô¥yÕØ–mi“FÌR û$7p)`ÑüDé.ìq{­V?›(L´[+C±ïƒ/RŸýˆø÷Vâª|4£¿xs‹ràozݿحýЍ¹¼WV—Umɲ°Ñ§lµá3fWJ†¹ï*/Uˆ à ‘0j8õfcís#i=f(`…¡lNÜ ŸvÏÖ€’mƒÙU}/;éå~½ø(ï&ts‚`ùCáLè.§®Å£Kà›8v êvw\$³Â¡6ñоÐu^k´Þkzå•õ{Z¿}´59à+ýª%º°‡ßù /\›±t~ᬷdQ…ÏBé¥ÍÓ¸vùOä#žÂâ¤i^õe‚,‚Í£æè’ÛÝBrˆ Ëõ£t€wŽèèU|°l’{°ÕŸ¾Ùün¡ç'ëŽóGš!À¦»‹·Ýó`,Fõ‰G¥®?eöÝœµÑéʤâë¡B·Ý’Œ¦±j¶¬÷Ó"Ñhžö&ÙHh[6*…Mu¾DÀQýËö*È©’4çÀÊu!±!HÚÅëGyóÅ—´à‹çüÄß T%06:œÐ…ìì3Ñ}mœ{DJÀ´Z~vËG%A}½OL¡è¿“ò5Á¯9?öÝPB‹÷žGà*9w9ÏýÑ¡Ž•†f;·òð+ïØN­ËPÌækˆ?/?ÊÕÞxËÃtcèêãäó®LÛÝßM{ÐÕQ¡<ƒç\v…§ªž”ï&I‘õ­iþ’” vw²ªq/U€h”EÐTÖ©âž]™³Häú»7ULßX¦Ó¿Ä¥Ù’¬Mx§T5Âý[izšÓ:2n„"Ü&É&¢ ÂVˆŒ»]Æó ›ÝÀP·Ûð0Ø¥‹_ÈŒ%ffCõ–¯VÝ(Ò‘XÁ–¦c9Ú‡Ð&_rKôœOaˆ”£â$=ÂigSn3t9¥£“ ”ëê¹Ñw˜™Qr¾ÜuV+QsȉͧNx}Vöâ» ¿b)j~žh˜‘U³“ŸöA‚¤‡åæN5RÍ-I'Ãî›ìøW‘^–û&ÜBÞÒOEZ(òg3…gkWzj›‚¢Ã; H•c æSëÜìÝógh ¸dâL!ªøt{– {L˜XµËäO/OLìN}—5ÙpN=ò~Ö!‡éõB ÃáW$8Âæ[`„åÙ)Ùõ‡„&¹$Ñ.% OLåAŸ¡Ébà~eñ±,uo,t^Uî¥äÉÅ䉬›ùz{5Æàü¼¶Ábd’ÆÅ•o=é‹t¿ésÂ;<‘|¤élŸæžËMö>{¬[º;–Ãq©P6Íu,O]7ûRÕŸÆLz ¹a¢²O2/ñZ'O×w^¹EZxì¾;$­ ³ ë_ß8ÄxAÜVï±e¾ªD-íúâëw}@ÑõÌJOÜJUSr\©² ÚîççR¥Æ Œð‰Ä‘P–-Ñðò³‚D—ÚFXg‹Ïy½˜¥fW 4]Åõ–JHûŒ­ùÝ…½)½.«+Žhì?•­äR|[£Q)II°(­×}wÊ O¸Q-—ƒg“ÎYê±>“wÕôÐ6ÓB8†`¢Iܦ¼¯@›w­Z©Yyæ‹›VÞ/¥ºÆ /  ÒÔȈÀƒÒNÜU9üô…²¬0¦¨¶†°É¼Ë¸ ùeý±ië8$\Ù·ÊÀ:{|œË{W0X…ݺç`nÚ*ŽÂäÑJÀOkïÏEÕ}â¡GvaE´gN>¶¹P4Ü)6%úqt,Ä´¶ÞX(YžqùÁ~žH—”>ñ ¶ÞÍ›T¦@”¬Ñ¤¼Ùn¯¼žþ<Ö}ˆAŽ&ôÔªXÍÚeø‡O]¤0C õ Û„ÅK{ï—-š"&€LþW+±?}ŒHü#jB%! ³ùÉ>.sö¸(33EKô¬”ÔÃŒ(!šðŒ¥¤Ñ-öÀ¿Ú)EÖ.QD€Z‚" êovoqu;¿%íSŒ>DˆÏ ”á:åNÏ‘ÔÖ‚¬ñ:€–¥1iò×hHSðœÖËðhlsIN7%Î} sÇÒO¯­Ý½í ÃÅY’þÁõöV›¦QÝ2@¸‚N‚ï|4305Fßú…ëÂÚ¤ô}2°ÃL€Ì÷±Mã†Ax»Òú¶JHæitÝqz‚v›crDЛH3iM/„š]‰!Àï°æk6ƒ¦¶{UÆã@YRþ„øÚdþ ­Ñ4æ“[…ä%úb*CÜQŒvdƒÅ{ª”m÷öó¾3Nc]ö0‘ÿµº¬>þÌ”¶W3To­5†J6×"„£úJ+Žøºº,VÚ+BE²›ù° D2ጠv„µ,”ÕWÍý²^Õ^µ=crçÛ.Œ=¿k"œg,ì@{‘,=ŸªzÆ!TÝ/qÀ|’ƒ&>Ÿª h”-»tíÌRáÕÝöwÃy‡lÕ©FA®y³ãNˆøÁãªW°¢LY­½¤¢ jþ*…: GàçPgôò¨åºè3”vÙ€ÿÎyëÚ’÷û7p®:^GaB+®\ÎZ U-pAŠ©2’žÛ?ëQ:Ý<¿2̾ùñfo¦¯ßÉ/°ÄDš/AE¦ƒ½dí´@Ù! ¼™&í§ZÀ——E.!䂎¿tþûÜN±_³ŠSΤ¢Rf£}©®WÜê\Më~ß«”i v3(Ê)”4ÓóÛÛ)‘ …Qnî¬ï‡²å¸†Ýhˆáù4¯LìãH«5?æåÏVÙ4‡@§–Rv¯‰>/òE‡±OlÔ#Á6; u_ò)¹ Ý5P!aêsy$dÖØMÕ“Å jœÃj¿þÊu5Äi¤Ñh…÷yŠ´È_‘s»l½CG K}q‚2½¤†Å"ÌæEý¢ü š~.›Í»üÔÒÓá¹é|cš‹<íäv s½ÙÔ ×+Ê\ØÐÌBOॼÓÞÞÙ@„o®:Ñ)žz‡Ó¼/Lcv®µ%Dô—ž¼&aÄŒ§Úf³TÚ&J¾±'Ž„°œ¹* ZĻ܇ÏÉÅC–Á¿èê¬ÃŠG ÕCµEkµCí©+|ˆás.åKLñ¶nò‘øøp@Z(8&¶¶÷œzˆ0Íþ…]LnÒPAZ›uGgxO0SÝàfÃ=Fta •ôÏ –CrF6“z{1ŒŒw–;¢ÓŽÈœ$pt¢~Á˜ë£·î3Ëw€ˆ 1¬|¥E®¬wᨸ¹\Ytƒ v=Þ+v\LŸ:µß6ݼèmsÞ1Öq-“:T_„àÏ#æÛ¶Ð×Å` ^õ}n¬siyñrÆÑtê¸8Œ¦V/¤Plïo½³YlhýÐÛy`, [>G! óÔëdÓ-y_=¼0ëÇGÚ“©¸²ŠvæKöË,JÄ~íÉg™? ~̦ 1{‚#ƒ¥ õ%›Gþá9[Ç4Üò› ¼Ý­AþÈf‚õ“4«Ì¤­D.ø)ûÙGäÜdÖGͼ·ÇÏ¡§ÐÞã‚Xî›WŠŒ¯s¹‰­‡î5&|Éo½(Ck"ìsàŸ"÷7.ºF²(Å–K΋€ è¦< Çu­¬…+¹–ßÙÐ¥¶bó÷Ô˜`þŒÄiüM÷Üšmµ‰·Egãb]´YjÌBÊîÆ·¥ú¢sw³§"¥³«sÒ©ü™Ù$®Õ2[呒㉄’îV›N…Úª,²ó"áö°E"v† ãK ×s‹õ±-EwïŒçâ`•ÈÝ5Yî´d–ÑM¾Y‘‹~u=`<©Òżâsh!Û-Nýjjó:Ù‰2M=ž9Áÿ û‡]矹Ë{ÎzÊã£kÚ_²‡ø!eÏv’µ™PŒûeãßì•"=mÆÊÕóæS W=OׂÛv`Ò©Á&*P´Û6ô5Ȧ; ú -®N‡«Èk]·2P0ì[ø¨Ь@¿ŽÉFÊ3ó › œQ(ÊKîsf¿ã˜‘H·ë¥Ï )‚Œ`)Ö#/8”œM bÒ;xÿWô&}1й2R†]aè.¥Ò“ Ü<‹q¢ûŠÀê¬Q ݼS)ÃG/·ã®Ç€®"2çoKw!:2ÀP²>¸š.mLÜ>±GK à'µ(ÒˆX/ý[¬WÌÁ‘Q@¢ª…Å/å–ejB~p ábáN ;™]w–šýÆø°Ï¶¨-6Öé2x)“¥F­µ€f?äþÇ[Æ|aF"3BuÎ’0SÜòÆlÏ+·Í©ƒÞ>4V÷b¾Ò¬ YT%q9²Âá7¤‘ï11LœÖÖjÎ¥Ê(x¸†33âeó^ñž©Üß@ æèž{y¤—üô¤çxì`Zagì•_WÂÑ{7ƒK†18«‹@ÅúN@œ¢PCß©Â0¾Óó\8«Îb =w›»9™~NW?Ìc•n‡1 ؉3@öã’Ù\”ìD_ð¤Bå°=’¶,\PølÇùÂi%gsð‹¯„çæOûÙš×[”~ÙÐæaâO(¿’ÆÀœ~šlë(àü|Ëê·NùàðåeœÕÆèt¿Q“Ôª3b«f‚ž- U½[b8Šƒ‡Õ¤Í”M»bf,Ð]örOÊô¹ öõŽ)BžèË㉻ñëmÎUDŒhpfÄÇé £VMy)eÒÏëkÂ1#OP† xígÙ÷1!¢Èýx§E*]@Z ¡ÂØÕ˜Ñÿê’N(Uß@,]¯U=ò¦*ªï,Ц=±¤—^§Z£Ðv„q­Pí±È*½J8Õ£à857]M-F@€5˜'kS;™Ñ¦¨P;&©e…qÿ¼ÌŠˆ¬cy>ñÞò†ä ¨v­4€·3üÆE˜¬€Å‚¼SEV¤MŒËÆYðÿ‹,2‘‹vÌß‘‹ÙzÛ9ŸsEË£·?À¨\X^ìÚõg>~÷sÐ=PÅÑ,­5”)QL@¬´7ÜË?j¦eþ£ØÔSçGú[>²‚àÖñ®á¹Û;6íÇ ´R¾·|RqC6ûÐSo·žk¸W‘±+‰Í&³]°RŠ-&ÀE ̰ ­FH¿ù¸¶q`CuÑŠ»E°(&_æÙøpªv~ÖBÈWS T˜=*oÿ#ÈLæÍr'‡!”ZµüÏq?1 Ôü 7.ZãDšã’=›=ôŠÐq ŒÎ›„‘©B#í$A¶†.òœ/àöju8Þ,jä±¢beŽ«©×³¦Š,„”vôt…r_¸fd>›iA¹*áXý½Û˜óøð) ÁÎ{¼{ô6ý¼+s1ÏWüÈ5±”˜6OÜ>W3#°ÿ@oAçn³¸‹ìî4üx  Þ‚¡bíL‘¸OsIì©ÚdGi×ã,*^ËÉR LÀë²(=\¨HJ'ËJ³RôöíQ‘/|¨ ñz”´ÿÔÌ”ž5 ÆÛÑâ2‘ÄÕ£5±£³Aiò†þUw$t†=D‘z(ðƒBë`ÁÔo6>TËžpsE$ÞEJÕÉÜ—¥(dZWÀ%ïoÔÈy M*g ™"\ÓÙ‚ÎàÎÉøä‹Á{ «¾3cÿÿƒ]j( Ô¶ÊèD „3>0 ‹YZrelsurv/data/colrec.rda0000644000176200001440000010766414741433226014650 0ustar liggesusersý7zXZi"Þ6!ÏXÌã§x])ThänRÊ 3ÅT¬ñ‰ÉhnaD¯ò‚80 ¼t:MÁB†ðZÍE%ï*ò03t‰eùçö0c#zõ0Ž9øKá޿Т%ˆY \†›ÃR2kH¦r-Y{°Úä Âè˜qQˆ‚#ƒYƵVE7<ŒKãžÒpÔˆ.mζ;ÙÑ ¿ª1êAýr.õ¡>M΢հßýˆ”0åôìQÚmÂK0c,.4’ææ ­Éy'´´y– t›'“¸XÅ}H£ƒŒ\Û±ëÁêijØX“)m!„¼I2•ZU×X~¢½OѪtªjs[=áÎ.ý>óÖ.Ñn7Vi Óa¦J_[Æý~QëÝÀÞJzÇ:ÒöçÚo³ï_Ú 'FýÉ‚½ù{& '¯Ò]$ì¦8w’ H&¿ÏÏIÖxÃèwhùµ¨ôéÜìP¢nt’I¸y&cž;ýh? T aT‹HC¬¸ð'ƒU: ÉÞüekWÖ7Õ!î‰JÐP[TóxוtèоļUJóg>y¡lW,ô4¢&¯ZþÒ±s´ >ûñ”¢ ‹†t‚ò‹™DÆ4³-ž¨]ó»Vô^°À¾b[É~/:5ƒš£9(rÕ”gžàœVÜÇœÎ'_L³û{¿ÎvSã1÷aõp07|óÚhªÄaN!„¨ÁÐ[ …­†Y¤ r²ŽtÛ›~Õ’U}ŠÓîÝ™ÊRym÷~/Ûõ§1þ…atÆÛ_Cl2¼Qh…,;U¥‚\¢Þà”0!"äpaË#§Šš„íÛ¶¤›ÑòʃbKÖ #M·Ð@ˆý„¡È]ž“w®Hgnrùudqîç`ã °ú,®=L-V¨È³O+ºq7?ŒâeŒn3ו»ÆtKÁ§¸¬Ä½J55wŽŒÞ4ý¨ŠÉå\0Ûl],Cži¢ô|Š“ÁDvÕaÚX‡£PzÅeßr¦TÌ\wÝcMqª­SÌ÷¨¬»žHJ‹R¡‘œQ™êÙ—?A>'µÎ¾F-³ê=š[Á_úü•>(^-_]j,aÂ|¯úg_UO?kXfgANúp%Í­ý ƒ>G¦™ ôrø9Ö 3Ý{uõG-½¾¼ÂþJÙÂç4¬_J¯¤C6¯©¯øU¸¦-«Ð:SeƒðíéVÃÛ©݈õŸ‡ßÈô?+)æ¯ý÷½ mZV–V³*3³Q´”;NìÒ7®œ¹18Ш¿’³ŸœÊAn»xjŽÌ³žK3;øÞñÒ‘þ¿-3@4d:‘Qt`6®3¶[1ÌŸM\CpfÚø¨¦ZwÆVð(WŠ'àš–¦°æÅÇVúÛe . #ºè-6ï lû$%ºÃÈ$mRT@ËçƒxJXÐŽPªŸårV”@«‹%Êâ‘©ÿë&1éžÝgÀ 5¯¶"káŒ=)`ñÒº-ò=‘”ìGŸb¤;¹WÀÁIJAC(†Ð’ªð¯å¡÷LWÈð]„Ãw{ôÌö~9i£qH©Z¨sòl(f¯Ì £bµçZ}—Èw^ÍyÈ›X?nHÛ(¥ãʲÌÑT¶P78˜pª}+dÈC ¢ŒOʺ³‡‹>Þ«ò¿ÿ $ýÁ‡ŒœOàÊf¼‹Ã8éݾKdØ“w087•bÕ2Þ:4á"Iq^æ{`yÚ—íÙ±Á Öµ¡/ã'î›îo€Úü2JºO>y——’{·º6‘ì@^Ñøš¨OPrY8®J0,N-xƒ‡“‰Q ¼§‘ƽ+:É€¨N ßÇ{Áú%,®Ö牄¡ýbÍý‡€¦ŽÄB \ÀõY’¬)+á)Ž~Ô!ù².ìebmŠ<Þt™Âááö½èýÈævtTf˜mCº˜Éµ’@ÐéÚ«ÿDX×`æûúohLÿ—âÁæ  ‰2°2ÇÇŽ%Ýy(®Â—\åø¶µ¾ó| «}*zj@PtH×ø±”ЏŠ-2Ô3­Õ¼ôöœ"æ¡‘¤¸^cÞ ½œ@ñ¸†¥¡þc§µ)‰^nDüíîêÛ]3ðQ?N0-ÜÄO VÚUZÈ¡ƒP®¯Ùœ‰ôQ¤pN¨½^ZÎGfVÖ5kÿqØ=-î½…n€ë^ÂÛ%ñÕÖãw0ò $S¨…JµÙ²‹äþÀ[¡„í’ì©ê^à4U* ¦¼ý~® áÃ{ ¾®â®ŽWþ°P ãé6ù4)½Ì­öòû’⮼žòMË»ª-ŽM¯Ò³Û˜W&RVÄ=øuîó^_%“n=ÐÏ,ý“_Yð¤JÞ"31·”pxLËh®Æ¢ûÖI¶Z„;¶Í¬Ðþë𷔺ú×±Ü;¦0ð…dQµöñ¤IÚF– ³XPÊ~á¢ù3ÚiE(C5ê@+¤+uŽ'¥/:J8éa)ÜU„ØÊÜ­ÿ89¼JÜšÔщÿnEŒ _Å‹:7朩=>QÂˉÄN¼Fˆ·`+°åzEåÀ7¥ÙUÝ B3xÍåd[ç¾ç˜ðEh‹Ò\Ûžm¯­)_ýï¬*Ȉm ‚ßðù³€Ævílhíº^Ï€Õ“ÚPåŸ\9M€0‰÷.‰ÍU߯*´Å«$RÁ·É*Ñä?xÈŠ0BÒúFqÿDI"þýAaà`UÞ@hTf0ËJ)b*úÈh˜:¯ÚA¤ÖÅ‘i uu»Qf±ûá˜çoOO¾Ò»úuÑ gu Aƒ!äïyÛóñG`Éé_ {ßov¾7Añ`œïèua‰-/æ"˳ä–}ê¼1€³áw¨;d=c\HI«í<Îï§ÖOE~£i/]#ذYA9ünúm%áPÝPÙ0R÷ÛÓî‡)'`ýô6tözä¡?otm«}VÏ(œñ•½†…Òë¯ö¼±¹v¢†}ØnßR8‡ªª0,e÷ˆšÀbR‰bg§×êV¶üШæ©)~Ç=î q½Aß}<]]-ŽmA ©36{ †ÏËÊ-#iL˜ò8ï•öo‰D7·i‹>€ë ðí݇ÁUÀ†%AºpŠÍ®>áq¾¼>Rs„VêmP4a)c¬èD—øƒW¸†Í+ôBó@O”¾úq[ŒCëŒ1¦Æ‹IûA¡Êôù ‡-§ Ч6²Ÿ@¶Ž¼áDãsí_¯e}ØM´è’Ü“{¥±±I7¯Pü›ÿÑž¤Õ#dÐ/ÁìƒemVbzeà²êÐ3/Ù³¡òÄþO§åH¥Ð(™,ý ÿ}–òyØŸRÉ&¼Q‚0G»‰vžŒú{ÌRÿÈ2Ë!4EÐk/™» Ó^YX^þ: ]/µÜ5íì&I&*ß7vy0. ëtðæ_9|-§ÏÙÁ§P0tŽÃâÄ-^Ù•rI ˜^wö<^ŸTÖM+¡´šì¦ÛDßÉå´–e­ª:üÙ|ï%¤‘muÍ4H)þmÑiU/SÂ% ?ôcÜ¡NS¿ð™Â…Vó\;\Am-#¢í¿+øo²áý—¾Á£M*ÛÅœkdm¿™µõ7jýó{ivN# 3Ïœyiªr¡ikâø§¹"§*!KÇqñ<|£“6 ú³\sx°ÿ¸|fHmäÕ^áL¸%T"FzÇåS9‹äÉÒ¹Ö«ÜÇ#¼Í `$8#7ñËšDòµà+ ©þOç`A¥¶®{QÎ#¬n¹¾x¹ÃVQ‹’5÷ C× Óú)ߨó,•íeêöT4˜hZzã…Æ§h”×oR’÷ß‹±E_¶Þµk1>·¬pñf=b}ή·§Z„¸x¢0^½sÛx0ûwžk‡Ýë@%S|þ·… PŽWÇÇ΃•ŠU+²Õ¼'b=Q¾”B”"a—s|ÀÀ}ÕOË2ü˜rÎ5°ŽÕp¥¾lâ“ ~ç1Š~ÚÌÜC¦À"IË—ªå§ôðñ½Y¤FjÎw¶‡ì@”Ò$¬„lNì«îgz´ï[çÑH´9ò§…O§¿«1ïE:¯ÉJL£§‹ñâJWtê^û¬_ ¦†)È®³@P‹rÀrŽÚ¢Lw¦î'óð°DY”VÃ9Ôf¤sJR`Ì”ë faë°à©vÜ>9€År`(i)Ì_–‹ïoû†šyÕ¶…òÜ–zÆÁ­àAd½{8Ú0Š@Ž,g¶2frJE«8ik}m¯ƒ »4Œ¼–£4=嫃 |w'ðÞ¾ëç…ÉMu8ºŠ¾ãªaÖ·Y}j0<Ëévî:Íg—‡í ²½ÐyªI\X.&ÒËV‡Ä€ÜBODUw,í4írãP„>Ïö¸õ`’Èx{+¬¯,ö°À ½ðŒëy?0“r@僌<•é%.l-¯§W΀ñY-bkŠôg„$C?RÖÇl¯à[<†${\xHÁð8{ôZp"ÑÅòy1¢_Á“šl"ý=íM’ÙUî$ù,RH©†ûÀ¨óÝocY«YȱÔùÉãë¿uÙìhaÌ77f#Íá>‚ÇÍ̺°Nâì­jÓÉÙñP[ ÐJ‘)*ˆµ¹ ˆñ @¼˜-ß»¨Z¢V—I¶QdͨüÝàm~¾uc¯œÒ\;B‚Jä4Ž4ßälIL­¬)ÿzýçý·œœá\ _ÐGÛº÷/< $Åø8^±±‹»§ÌÎÁÕpÐRo¥ºˆpâ“E‰ð·yÉ C@·s›” ¤Zº·cú§¶“‘W›d›?Ãd|Þ-§ÀLua¼¸ÁOìkv®ÂãÿìpNãW–O¾Ð2šq2gótwÀ[Ë c8eÀ)”ezù-YY¨ÞšBlšÌ+£†ŸÏˆ ù\Eêö…,—e0AFÃM“ âÕ¸O„ŒE&S-7ê‘áËl9t8»è ºII~"tˆ¾'¯yAÑk&{J¤6.kºwæó¤¶¨Ñ­5¸ÏÔWzðë ðüç¨:Ž—Ìüñâ·eñü—Q§’ݱj·Ö8Êbl¬aÒ †ä§Ë/Õ¢µ%—:€¶>¥ŠõÛÄ¥}¬BYIJ£CFÓ_S,| ™ÅöísII;ìÐ8Êeúä^õzpqsÕQÓ¨¾±áÌ×oöë¼û ù¹ÆðÈç ERofÛRô^vµF¶NæˆUêÍ‘%n÷K¬¿¿°•„‚åì9˜6RgMãØâÅ Ëxmž‹ÎóˆœeÊþ}t÷Ø‘8¸]sþ"Óç}lîQ¯4ˆï°•»Ù;…ïr°èΫ9úø¡©–RsøYn¤>ÆnZӱ蟚pÎèfy'R¬8hÞŠ¥×i\ÿî2ïʇå¸/‚gÏô(Â1EœŒã_Ë ´Â:ZZ?PœÌÿ8´›Ö5?Â’½ ­t]a•ti¯Ñ…Ê_.«6cÁÝŸ‚&½ÿ*F65m•6FŸø:…Ábõÿ´äésXÖDŽծÚzæWÄ–€X5mˆR cò¹Síž]¬ÓrkÛÊIl°ÿtˆÆ²‰©6d|èjæ]·6Cí_¡HBï¼”@é<Ê.z3µòAxùg?ijÉr(ø´“‹ ¥xûLdi÷¢ó c1ù¿@ÒVÁQ|teâ(™».Q6P“‘œ9r%:†˜TÒ@¤*‰«i´°ÖìØò ±… £Î;QDŠôfIBx°ï ï«5ÛB×"J÷ÄÃÅOs6_£™#™×ÃeŽôžìJ“3©J”úK<ˆ-%'C´ëfŠäà£!ñüIzšF¹RÀ_UùZXÄ1”Ô÷’j'ÝÕW(¬=¢&ߨ¾ñ<ñ”zÜx…ܧÁ¤2;¶ôðT;¿HMì ’ô)Ívs®‡al^¨Ç ²RØŽ8^–ˆn ûo~š#BžÐ»ç-ɱ…k)ËÜWÆ¢Ái®·ÊŸÆÏ=ü1à” 1 Ød¯ˆøizAàˬ>K냞“*4ûZf}б´ÜOí¨Ðs !g‘l-v3>ÔjO´‡=­2—“)Œ$»`í"_¯ƒ—Óí/­ÀXS{Hœñ¨IÝ÷†]ý®fMœÌT³Q’Ä@Ù˜—:mÔZ¸cÔù š.¨$¸þ{Xcií>Y´Þµƒ(ı|; e=8<æ´þB5J™8M 6å—_ª‚Þ¼'Ø©l|2-¬nïûÚÓ>X2¤¤à‰ |Þc¢¾ô³ø“¥¶ƒ’³àòo|A$\@7AæQîëJˆÅ¹lF£IAìq¼–§NÆûÞÊÝY¶–¤69ËðGñ0V!›&Ó·åTÉ Øã½þqÌ£‡¹îLóPÊ1¼ÍØo¨RNëV9§EƶÜ5KúFó¯ÅΞòº¦¹˜‰âüPQ‚ã¤`ÛJNÒ@d´7ü.@Ò{š%ù¹€ÑVÊ݈9öžÝ L²yÀGÑÊóꥼë@xh‹ZÃ!BÚÁ/‘eè<-ÌìD¥HK©“S: Ä?rh½p¯Òèa“œþF¸LÙt¨æ‚ 6ÌÍç”0Ut5ìK VÇM\Z¼kùl × ˆfÿݳ䪻 þ~jþ}þGò¼ôf>¾‡3G C—^†[»é?Ê:0u‘)¦+yþžia å±ÙLMë[¼¹ªe¼gÞpº1§ÙZË‚‹k`¹‹IY=B“¬×ßqꞆ’âuƒÒÝ•BæÍ¿s°D‡‘Öàb‹p,ÑÓ¸s< ~‹=5}ÙK„*Òä(°/îÈë]_F[¯f¨¼=1”EÔZuºÝþ Ï‹//D‚à0‘°|˜EýËÕ—+Õ oÏŸu¸%ö]hûu¸¶:'¿2ægò=Õ‹(Ô½Ÿ3aŠVͺN# µ¸U`ãA5âwðYì´$ƒ_rÀ%oŒÚb«£ù+°›Âøn¯'Ô#lHOÿ…¤t¬À¤•è·iÀ—s 93fK$j‚Ššáñ]n¯a[{ÑCéñM à§Oj1AÕç·ñMŒ^ž5*5ðôé3Æ-ÒÄÇÎE@\5TC, –ÇzdÄLˆ f÷êÕ½þdÆÈúg›„ÌÊöÿ;íÕœË% 5>äè7]Á’êÅéϧ׉ÿŘ"}Ži3…5÷°ñx^j#"Öþ½ë ¨£å7†k"1u;‘8"ü»¶‡×=¦X] Â^!×nü¨TU–=±š’ÈÎG s`w7…½¯Ëiøÿ9®àökùW#y§ó¦±KßJ6³®ßnÈ÷܇j…Ÿ¬ «F¬™¡25üèÎn–œß64ïÈÕ½‘àúŽr[\ÒØ÷/<&ÅècµÙ S×Gê7ç 9@jbWãǦc“û¥f×ܨ¶EêÉ·éS¹¿uúX†±h(§‘¼`?vºDóF£²¡n¨óc™Ì¹CŠMÙ;±ZX %€ í|.>O °žü+KœO£bá--]]«*±øìw׉¨~=¦°k¼û°-àÊîV­ átÕ^÷F'ožÂѾ)î‘0²¶}“"z:C¤J¾¸â%… n} ÚÛQF¼·ñ¯_CspК üK’'ZÕZþ"×üV¼äAºâR3µææ¤¯PÙPX!‘î{Ì¢cýdÊî«„ þZº´¾oš…˜êX,oÍqp â¨'ÐY´ìº^FÅÔF‰,—uˆûj á½Ý * `1¼í›Ïÿ¶¨¼LóõDžrž>4[ëÉH ºÃDÕ°1ªcqb|§¾õ£RÚEªã&ò•&ÜŸÖö–#ÚMÙõ!˜Z°õ^NýixƒáTR±=PqïÎ×"lOØ•«(uÄ4¨º+CŨˆ™øÞyPÀÒÍž™)®N Ó²¹äb²þJ0e $¸å9ß z³_ö-Ê<Ù‚z3œ8›Êr;Y™ªîÏ´?©´“Ú_ÿ[õ7°–#òú¢Í,š"„=Ñ΋loÊØE•ÙNÂÐVµhþÏÖ¸ÑrØýTº]A7D‡k÷‰½úx €û¼t(ˆß UE®~O®·èý8Gߊ­ÎÞÆ#õa•‚`|ÞðKÊJ(@zÍdRªVZ5\ÍŒXæZÇIœx4¾!iÔPª<…3‹S×úºˆ‡câבÅûñ*€þçXY–ö±ƒ™&Erßü¼Ÿrém Î…I‚í’+ ¼•°â Z7ð>Ðѧy¶A8êF8j‘è<ýfüRÞ ‡ž&tàÞƒº}D”U”uÑ´îb'vyÍãàå+ÆÏIÔx#zMw‰½½hõK%3a§˜Y+U|¦‹ž•0Îñ‰ul¬„":Õïö&IwV-£ ^)tõ‡ƒ-BIh²T¼vYÝ@-öŽ ­"ëMnÙ÷؇Hë8`·TÊ ©×¯£´Eüƒ”8 9<ǃÿ<ð‚¶MV¬àhOýí§Q´§Œ{ª<噇e\L1`qž{cD|ࡦ5úº«å}ަÛc¸$عoË÷:Ò“ ÞGª¦ÓÊÀat¢ü˜‚¤ü™¿ ËÔ§¦?‘•=˜çdàÜúÿblú;É1§fú'Ôl„§D¯;(«nÿ{ )H¢Nâ eô¿v/IÒÉÈ[:9?½,Jø6U¢Ô¾€gÕIˆ#ÁÒÏõ Ó?pÞ‚•æo'$[wƒØ?"Cz€uåÅ„r¶‘F^^K"žôÝõÃ$eàÕZŠÍp¸ü«$»hˆ2pw©&ÑG-¯›ØUðYJ0°…;c`“ì?(Tå×nþ)å1K®H^CIgõª]HäÌâÛIñîÄ<¡oÉ£„TlFÕ°îïo똴]‚²K#,ßeëÈðßrpdEà5¢êå• Äßl³ÈŒÆÐÕ ´ †Xô! uþêò¼ý —Cip¸”(ŠfÝE¶–ê%7ç[Í`AÂRžÄ§¡é=71*C}@Qœß¼CuÆÉs Ï7Ü'bÇ…ù!7R‘C)å˜W„¥n0îmOàÿªJ#ÅQ¦k5 IÔ”¦'s´ûÏá®yâ?Ê«L%üôË“þ3Á®÷W—¸U÷ÿÛ}G*=Ñ:K¯®§! TÙùAÉÊïk ë‹ì‡CH¢ÒæD‡ ‹k¬Í•åpáÛ90³Ç($}U©”ÙïøÇ² `ÓÝdzkKš§ñÆ?©Ó«:X––¶uwû §Ï¹ÃžAÂΨN4°äüµ”>É®;jyÊB|ímätXʱ`Ng+?³Ã‰ôˆØÜ=>"ÈLcCÍ›$Ä…25Zõkõƒ—¿œª"ÉìÉq›ñKYêæjÊ/¢4vø%ÐõÏ’!P „¾û²ÀWÂoaóF¥ñûg┽á‡òª7ÁÜL }NuwƒšÇv¥àû™/õWwEVóXôV”­˜w˜8„©¨´é°†kƒiÕŠU–å()¬Eaí¯NÑDÊÝk>a1ç|‚‚)!é  ŸBÎ>Ø©ãMŨIâ²`+¾ÅVÒ¶z-Û8½Á-çp>K&›‚‚£ÐµÍ‘ßÞH«>H9¨œezí^nðËK°¯´!Ÿ›˜,*é8. Ïè}¡Í~¯;d%ˆ8 rƒpI-ºé<ú¨W›âñ³ï1"&p&³E?Òû9ÏáŸíþDúoƒãPfO¹[rãQ ©÷ƒ¼nõÌÛÀ½³ÖÈb˜d]jç˜ï7*´Bº²\]êòæU¦°8ÇŸ9Ù?Xev“ÐÀ‰ý»|·ÄúÒÔëhØ7­6‰ÃŸqßtfÞ—Ú¾²Ue×-Á]26†<žºíûŠƒÍx.ÌvÓÊò¯Ec ¹Xã²!ĉ ØwwDq>ùó;ëw,d¤ÿªÎ•'OÔ¿p`ÑÇxX*+îÁÕ†1Î8¿wË¡5hn.˜?#%·Á1*„ Týž—ÂB7W†µ8Dvzc”ñlSƒÿ– JTµ u)k7|,ëPØMæ—”ç”ÉÊDnÙ\šž]þw¥ŽÒmºæܘQ@ ¤¯rô°|yû¢‡²¯¸h¦ Qö¬>üÖÄ““ Àï Ä;¢ù|ˆÐ>-È;cGv?0)ÇÕá+Cge<÷$ÍÕpA„…hÜÛŸª~r6z$p¹\¡W7{{t³EjÍ:‚<ó¨Úa¯Ž£dœkš¡%ƒ-n›Ï_Ç 3íXÀ ¥‚ÑAž·“»@ç9ÞRÄx¨|͘ó8Eu;i·Âü‚Å<”¦ä ÂñýIzs«XgjÖ÷½•@¯NéýÌÑÔ²gŸ{. A†nDÕb½ÇŸ$Køñ$ïújÍÖkï+C§·¼€Ê´É`ÉEÆ(RâtÒ§VSõšÐ–Ïùì¢wæºs²GÂu­½i”5SE]G™^ˆ‰ÕÁŒóÕ=èU5áUï›Î‰bÚx2Å=àp{C;d"S? ™ÇTbB‡r.õq»«ÏŽ—ܬ›"•Ûßì3Üœvw_¦IS”Qqr#ë}Wàa.@´=>îUC3}·#”­–œnWé‹°$•à+##Ë~cÃþ¶~Îzšï?Ψ.V×åAZ<ùRn; °±ÌYyeHJž€™PY÷fö)œd&·â­F€Ï#yN“áúKóð>ZC_ZÄÓ Ô»qšU9öHNyG0tãX¹Á$ã˸¿†ûñ‚¼î¦ô´âáv|¶^¤³©|gµô.AK—ù¸¥ƒ¶¸1hfJ\¢‰‡;ny3fÊœ‡ÎÛŒµ”ž¢*µüóz_ý)‚ìÙ%ÜšRútb|H2(i­XÓÍÀã#T²Gå4¸yc.]óŸÄ(d\ ±8IÁT²™S€N]LÏçt“Œ¹÷Ÿ³|O|±'Dì×8y~RÂ/?¢?ÇW:vÚf§#3Þ`x s$½ü þðR¾1”äTƒúbHgŒD^ý÷mxuÀñOOúÈ ê0G{—Ÿ–^_®NèH^¤T×dælžKº½¹Ь#MX"À#Òæ˜ Ý­·‚¶YßO¿õ««mجŸuåö¹\„¤E€“°:ã¸fúŠ1¹ßl+Ÿ’bÖa³ãâÛ×*Ål-GP3ílžÎ;ÙøðŒ>ŠPج®\('…ðIÎþîh“Hº-fŠ1Ä#Ö‹teY²¬Ï× ©½ÜýË"@§[f3(Ùç"ª³+ø´fpyóÎÇ‹$½3¹¬%Áìæ4YDh§#ô…õü™™qB@ êbÛï9tyNLkLREHØé*Φn’ë T-Ôk%‹ZQ&5#èñ!Ϙ\¨$-Bð_³ÃÿÎAÖÇýMÒ %8.C° ”QK ÙI˜¸óº&xÇ;¯ÏIâÿéú_œVÂz½\ö :ëy4 `_¸ÔVÑ1Còj ìè<ú·SߊìuîOØ©uLç 8ÏÍé ÷ËØFû¾ÊgJ%qAÒäµ Ð*#uX Œù™}£CzÝ:f?wÔâ—€|ÍY‚É#{ Â2­Ö¡ÃÎܰ(¬!îõSÑH[;Ö lá2’æ´èì¯؃=3µÚn(ö <3Ùš­ç=ÙBŒÚ:: ÙÇRqòûÅÈ„âÑÁŒáUíwÒ8Š4OÅ¥õÛ“ªÑê-Éz ¾,K×/8B0À4)šÑH}z8¯gMd,ýIÐÜÍ€1}còCË{ù'yŸÁ0ÊCo‘ÅI?\fWä~]÷¶iÈX²L[Z\m“è% s®ëRL¢Hgh¯rõwÛßM Æ: (íÉ¡â5™îžV›ZPvÝ Yî–íµÉÏl»bþ-IÑ.¨{'§ÐåÅ•EÌ‹<ìPH·Ì*Xĵ]j²ÇlÛ“#íïŽåì(bíc·f Ù‘ÀN”«¯…"¯ïU¡ã³àÍ2ذÏBtéäÆ_›zÔ;ª”k ýO#â3 ‡pÞRéÎØ” šõ`«ÈG™—9Ô6ŒÄ½½öëgw6,Â€²ì+¹42’hþCwµ‰M,©ÕA^Ë˼¬S>ÞbmÜ¡üâC憽"Œ­õãézè?Uj@@“täØN|©†” ,™|²´¿€T SÓdFÅÓ>$Á,5qe.øA«'fÓŠkÉo¥-@C` *¹+SÕ±5tù˜4x²q2à+8i¼IÏ»;>¶Ü†0T}†ëöü—s#VTDÇUÁè—1–›4î~fs檳’V8´ÝòÌþ%Í45OÛ œ×V:±ûpL’²9®¤¬–T ÝÈyg¡Äw5Ëî£RP£»óóÝ^;²×|®:ªÐúnÌ<Œ#KŠÀFð±ÀÏ\äÝñÎ'§`ŒÝÑ;eÙ’¶Ñ%RSkATGû¤U`¾Gþ‘ÒgNES<еnñ³1ÅÁgáëŒf9—3z€2iâ–.SWÓçeìùŠÿ})‚ާ¢?UŠÞ< æAÀV÷dËCº\1M<“èÊ5[Ã?ÒÍÓ¸#›¨šû÷¯6|ž#‚r]WŠ ¥%ÙûÔŸ,ç•<Õzßà :ܺn І_h_I\Jê92n• ÏèúrⓊ6q‚B«î!£.¯Î¯>z±˜3âCØYfû‰ú¼…›wߟWÂñƒ:Ùý§`é+ƒÈ™r}€Ç©Y½Ÿô¸¿("‘øu'Éõþ¶÷¶¬Fõ%¤Àx©Ü•@$Üxd?…¾m{Â`Í©YØy3ümñÕÄI«¸²‰¬$<¢nȈ™U|¡Ä®bf5Ê4™i 2έ¿FJÞt=­^”äHiX¢&‚(˜’Ò0Nà sçÆGë9åK§„ñ!`SiÚåDƒ…Û ±;˜¯ì¤Š¿V(ÙšEvý >`‡;~T2÷V 9¼o u_LêT”}Š 1tïR²=á¦"]aU㉶–¶±h?;ãj"‹žy[¢4›dl0´ªø‰¸VŒ›TÜ'Ž? Ó£‘Aºnž¥k¨4´“ljåÿÕûØÆ°Øµ«Ý’DJu¦”:î·¸ÔCûc·ZÿU>ŒÖ§i—ÐÙÕ‚5|¢®ŽÐÿGo çäÔâ:;kÈ›¢¸“æëðq®)’ F÷U°û[Åmcà“Mh˙Ь2o[ýÆsÞÓÅN½„ý 3„eô@LJŸFÒdý§AkxN5Wk¿u,qƒ9ïcãÛ~‡+öô,¢‹ù6C;ãêTû÷Éø=#T‚zeèm­Ä ^ÈìRÀÏÿ;ÇÝ)޵Á=S×¥¿Ò¦ƒZ>Ø{6ZžC¹‡%‰µº¿mbö³aB–vGîFùQ-Áõv8qŽáxI|}} Á‚¯šè Óø)†¡«Æâˆf´Æþ”›˜ßxïï¶Œ¥tÏ#ºŽÝ:ÿ7x\2”w¦Šê¡½ž×GˆAú·u‚$+Dp–¢‡8å쎚¿¨ñ' ¬]‰y®ù±â’! @gºÓ¸u¡ÊvÛ‚ç§`ðè©ïuaˆ6Ÿ •ð…Ê g<Öôò·°~u йô­9šø”ˆa?ëy°‰FÂ]l&Òy¢è Ö)°4üb­=‡Ïå¸Äý¢4ZõØžsXð}‹˜^÷E À¶”Úý†3J¦Í³‚»?èB~{dÈD "êh>°èÖ£$ù ¡ÀcÕ^Lá¾S¼}zô¥ÈZRÙ¯0:ùûf‰€…Ño©9žüž=ÿÐeËŸ‚K¬qž(‘OY²£gæÿÜSîÔbŠbº³aïQÁ¾€óƒæU,6ì@^…Ã!õæ×o×£ýooí[ˆÞxrÅ3¸oj§Úgp‹{H$ÖèL•J_¡ŠÙ¯® ±ÈŠ¡¬ g”T›;%¾ÝÌÎzPû÷³h êcG²Mr¨-—ðj®¦J¾Íßf÷6ª ‹ó˜n+á¥j ÆŸŠO.%ºn, uÃ÷¦…5¥£ö­ŸÔ„uÙ9P¢7®Qúdb‰ÚÊ;tôéI—ì1+›äëN!ob+®øîÜ«º›¹]~V,ÙH:ÐuÇuß䱤d€Î›»æ Ãåô3‘0ð—Ìá.HoT“BÂüÌb#ÅœLwð¢šxÕZ³P|Ð#Òax®L«E„yý©%B°®xéÉ…±œ®['k»ž¡GÈ+Ò~qCƒUXKÉ×ÙQý´ž0Vj¿*®Î ËiV÷g{FÐR½föÃêòý$dF3w1kÉÌ‹äqc IY¶Ò‹Yšòs7]t¹îï`SXyÄgyªî“íˆj¥¾ÝF]ÇMßÝY© –1&+±æÇW4,ôž™lg”o‘ ¾d, ™#N}Š-×ÍÁ§˜ 8F9Ç,¢¦G•sI"·8=sª{Ì1¦õ—gåPÍh¨§ŒKÓö)³Ók¸„-‰–eü™@F…Ví˜KºØÜºØ çW;Eø# ©âá݃šøãOý«KuýÑ"zçÈ1]€‚?JñH4³ .¼Ü·õÇ™ã“Èyü¡Y±*tv&¿'YÈçÁ.—äN-º‚Öc´€~ªw0 ÆÚù÷Fx «1”_3nì8 ZÑ¢`<ï,<ÐÅû£¨.Åêþ¢{K@¼{ Í+7Ák»u‘%àJMïAH÷4Ø'‚ó³19ó ×yóšŠúÅÙƒ‘êö‹Þ]ùÀ£Ö>1˜¦¶¦[Z ©;¡“¡½Œfɤuo CdfÛOcBÖ}Ž âÎ=£‰ƒ“ŠÈ‡ƒåYñ‹«w)°Iƒe;"ŽßAŽ4Ï)ѝÍû»\K‰+žcÉÜ Ý&xK0sHnSÌÊÂñjð¨úÏÆ2…ë&3ÔõK@ Ôùký¬‘嬿"ÂwulÂ_ûf¯¥'qD­¶çÿ>´t+…JÚ™òX#{#+‚…z¾«Æ¿z¬ã œì†32’<ˆðÏäÏôÖÀ‹æ åF[BV¬©£¡ÈOP¥ͱIî¼ï³&å,lb§Q‘^MÅÏ€Þ„áE8Z‹ŒÉñÁ:ZvíZc‘)S}nVåµ1ƺ ;cg»**¼Læ¬!ÃOlQ/ábùF9oì¹ ±³›¹Är-9J•W¹$ŽjÚÒ D×x/°ªƒ¥*ƒnzåbàØÁ—;ý6EþMüäÏtøÓøAi«0•x\£§Ï—ƒ³B¯Žë±¹ät‹e˜—w/bóð€ 0›-ô+Œ àÒŽä¸GÕzR%ý4Žlï¼f1Ì7-z*ÖG!.r#V_GÊZ›‘0Ëåab´‹l/µúEwA–I¯„†|œÐ‡*;ßx.8ŸD*]¸|¦$½!‹^ üýºFµùh÷îéÓK;. /¸½€¸2âvŒ­¶è5Êja`ËDÓ/AÐóŸ$!£ÈpДõ ]S+NM'¬tc¼ƒ¶íGBlïG\©BµðŽˆ#7Æ#‚ø¬Ç,PP7òp{ß¶!lÕ"ê=÷åL\L×[1ýËÄ#Ñ…­¤uK\¼šÔ-ÑöáM+ë8¯K­øý›<¶¸—¯‡C¼„mnŽe«mþ ó<¢Åꪔ–'ƒ8c/Ù#ß_,WsËÓ i%C¼ul42î‰4Yqsš^X¸?‰³ñ»FKÜÅ¥›<ø÷Ró£,­~àpnôPàÖÁ曄«€Å}AVX¬00*u\C„ ³{WéG³@-1jí©Ê“à–5të ‘Þþ[cO†Çî×î(`à ¹yæ$ªªA{àŒ¯óä<”Q:ˆa(Â)¨®0áö‹|`]˜ ^“¶Îdí7‚,Ë÷Ýø™Z/)Ü<ý&.ü89¬34ÙWÒióWÔg’f`tÿ‹ž|p£3L“êùl «u´åþp X½‘=šoKÖ`«œ²÷7SpFÁ4‡6±Ê ¿½`*rtx “R^ãæ¦oõ`Û¼;þD¥‡Ž·¯íËP³Ú }"ƒ“=Â8©/L^΀ Ð6µú=¹V$UU_óG¦¿ p¹H›¦º Z~ÍÕ^Šýä:Ûö8hƒœ…b¢ñ`–n åÁÕQ{TmÿÃ/,êU±Î–è€^“Ùˆ/FkAJ`·á(ɪTçÑéuã]0RÒ|G4 ¯ §¯Å3 MKx+ß±ð¿Õ¥á@çaNßOȬm\óHjvüì÷4=§™Ùá(Ä@ì&ÈÍêäê¼»…_GŽe-?ôÎM¼«ü˜ G‰èv0’ÖBK>x.SDnÑ_èr‹ y³ZM´Ù0À7Ïúšx4Y‡b>}€ÇkûϚ˃ˆèèÁ£z2e½îÛ&QS„x€áÕ9ϰê’…è Šrb{g{Ÿ‹ò¤Ý¥¼½£Á*ÌRïs!U“cüo.Æ™øöé%©þãÇk/ a}˜ÏÅðãºÞšÛ²‘µ•"/p Q%„9OBdtÏt0ü7¯U2Û˜Œ¢v–æ“nÒoìjîÿ±u¥ñàáíè*íäBÍ?öެU¾}¤Ž¶ L&:‰E¼æ&e@¦=½ÄùsïH˜Øw™_çîñ\w‹ UŸù)´%«?¦^^Ú«BÐt^Ô¾ƒ«,ŽÀç @Ð,x‚,•œôŸƒGv›çÉ+•Ån,ˆ€0,=nº0Wàqk¨?ŒÎ"±¸GCwt6¶'GеR÷Cb›*§Mºãe÷%&A‹`Ó>)£Ú×\† Wsè&ðàñçCs._uŒÌʪXÉ1Ïç=—]T D˜OõÂTe&b3ë}Ø£ubç—ƒæ{Á'”uõnçeG í×Çhñ jÌÒ¹)·#\•/†+žÏˆL-fËüì*¤Å<.õÉ`&Oç^3¥%ðó_ °¬&ú¿ÎÌÂ_E—°Šc‹LšÌ¼`ƒá9(ñÜE£.òЮˆ»Z…L¨:FF·¤Š¯ƒ G –“bÿH)°¦fì4gn¹¾Õ“¯ã‚PÓN7`}"ÍC¹]À;A4üûi‰²Gžé`lkûÒò<9[¢w( ù@$»Tiè“ÝHx{Ûj­ËÎáÕÏFSÝ-ÊÅ+ÝjbÑE3;¾œæ…»²ŽF—jw’" †ò­)UÈ¢±›½©)ñ(Kúë6YPK2tÚHWª1,…¿ÍV#lífس½Ú å.wö˜ŸÓA†!‡HÈNŠœ{lÌ„Z…tKÃù3uˆ·–¼÷5§ØD³Ý廉4M™˜hÄ(<2yrùÚb„BµçÞ­¥îFöõÙ·ƒ·e)ù:ÎÝÁ ó§ øü‚XNoôi¾ W‡q°9¡˜k“'¶._âñâÄä6·˜UΨ…Ó"Ý'CBoY&ÂuxÍy@m:ùe"JSvèÏʧ•;K]§Ža¼,M+4°äi'}ÙÌb€3[ÏÌ¡r5¯ØnDÐØŽºÊêãÆŽÓ"J'WC HA Î…8œ½@ÜÝ(YqåÒP…+;»g²ÔJCFŠTÚÁÒEN‡~ÈÜ×…ýìt¿ÉŒ£ù hγ ´¼Öòš_Ù«¾cÛPó¾KmÒ¾ñº Ò:¤tUÐ/Rm‘nQ‹Â=‹† ²ŸsŠ·¸ªóIeà!Æ\Çûßslsé”vÇÙʡȇiWˆºLŠ;åTÐ h”9Ú6Ã?ùPÀŒº.j½O8ЙÛ{þ¢šO4g$‰–™ìo8’ÖðR 25•[Àó%…a0ŸÝmÑÃq§,¿ŸóCⶪ¶‹ZIšwú²°ÊŸX8ÖKõ_“E>‹×e}ÊT2!ëѬB¹ Á®36´°Àt¹žíÍ TîPS’H:.ÆÆKX…%·IhÀÛ•Qî¥:}7…‹x‚h‘1Ú$3¼ÿA ZJ3™‰‘ž£œLiŒ ÔÿÆ/tŒ+ºza”SIkkll›p{Æ7Sˆ‘Ú1åô6ׂ:’6 ðp°@Hý[W4­gÎhÍ ôS’\VÑ BáeYö¿nÓ®)ÌÖÁôšæÞàÕŽ½P¤$Œ\ )iÀ©:êZ©¾'ˆ yÎFm݃n‚ñJr” Üà¾jÆG½&PR•%À¦;n¯ñEXèl\h(.‚õ³ËGSåfvQ5¸É±•-4ðG«ÐÚãjòÛ¿.‚‰ý ¸M˜ªÉ™4Z’ýÈü£÷M>ñ“RBbOXÑ´%Í3‘Ù‘~’¶¬"ë 6MõÆ &kL½šáùrÙg%‰¶\ZòxÉßÌ£SS‘³M€úÑC›Ä­ÆÌÒN=ÂP L5HÆI¶¥”®Ä{`òûÓÞV}îò‚ÌLJž0aüÖ wD /ÑxÀsOКøD©?,Hø~i÷`ÅxŒ&l;Õ¢õU\J¶Øƒq%J^Þ_:„˜­Wú°<|ÈÔº' ~mi¢K²7òX*‡¼Xv4à}q’Á{ðŠëbÒ.}˜0؉׵ûAØüÛâÔñŒÏD*x>à—]N/²¡“Zázcнm26rù\FÚ4¡1lgÒÕe ì†): »åWÔÌO¬RbNs{ï—?ã¶I –ø‚"ÀM_Ñæ?%é^ýý/BEô Î¹¡?htªîܘÐÌAy 5ø´¶E¿熠iÚ²‘*îb?åv–9îë'„¶yל 6ÍG.ºwŸ[iøUœ­Ù·ø`EÀeýô|Ç!вùšvêoŸ­öëIj¤Î/'˜£™› å®o__é*fBb4d ?Û«Õ£;y鍸£IJÑç`fî3h7Sßs,¾i‡[ÕÓ=9©OXÂÈ̦;žô j™¸h€½A}‚”Þä6ÝÀEäOº®rØbEW¬Uê©äœ 6œ—^W´3ˆF™Êülæ§NºÇï‚ù<ÄÔ¾'Å’{ã2x«®—ú­íГ”<¶es8OxÌÄ”Órüès*Ãdö`z½ƆY¹j}XAågáÎóÆi÷ nÈäõSS×jrÌ•èÞ´'yì“»¿JŒ6åÄ´w탬œC¾9ÑWžSb%¦îH¾,õ¢ÚêxP7ÿ3W.± ϲ+Tï•O’ù" Å– |L¦È/ZÑ3F¡´Ð©ç1|…Cz`jvêÆ’}|r(‘X:“5áʯ$jÇP&'³3ˆ jò*µd&‰—¿ñOmüÉ" $ÿsLŽõ¢­GܘÕÉo*#¡Ò^’/wpcÔÅ 'ß‚Q5‹ŠÞ%®Ä?¼ßÿuÙÃQíàkJ=“ÜøÚ?Ð"9oÆT;HÒÌá®ìޝ$D?¬mCŽ/6ô×þšá\ºêâ¯Y;SÿAeá]A³+tžNÕ­½ÅT»vynex¼Çq:›V{ü­pM»wvôp]$ø‘‚*M^BãA{qœ ¯ò>‡ÈÛì&.Ù§d“ã;€!>¾bÿqÍHºL Z`äûül?é¶ê‡€v˜ç¤¤DéI­2`5|ïn‚Ìo3Ù“¦%+¡æTúç½é÷l°šv‰å·u ·¬þ3Sy©ü]"PG6Mó/˵˜×_ÕÆ:Á‚ާÎXL Ö`S¯ØŽç8ÚÑË<¸àÝ\Ɇ_‹Õ>jEGý¹hƒ¯–ð‘j›Yp6ÿò|œ²3%Ùõ+až#/€—ikˆtg È©›÷iq­ý‘TC¡ ŸLxl°hºÐcc©él=×>Áþ¤•u÷IC˜l”Â[½%ˆ¿;~òà*ÜG!¿+UÚÈαoë³·äXU?KUÒJÀKÀm!<¢,%t~~3›æª?ÍxVÞZ|Ù‘óŽdV —²qÃSáv¨DÿVV_xoߤ;õñ:úåU«ˆ7n€„)îˆtÛšüùYôbuPRî±Ð5ÄÁkTœÃ,ý4íŸõd *¢Ck1âbA/Òe`ÁedšoV~p(†|¤ÑrõSLÛîÈ|ÀÆíÔ¾yÜyz}(„rºÜº8¶Uí/ÉÂâ$‰k±$mN“I¼ŽS ç*x'¥¹þm¾ä< #u?ÁÍ:Y8v WTi­‘Ï)Ü«jIsM= Þç¾Æng!ÄE:ÇÅšÁú€)ÿÞì{ãHýõ/xµ$NÙZ{2sûŸ½eÏ\PI‹é›K1¦šÊªÆ,„’Õ‰ ?h·çkã]‚03Í#÷­Øîðµ ðjM=?mv5ÀÝ Ô‘Ñ4á{Ή{ÍPò^?nƒÜ5‡eÁ²$Òålû›¢ñ3”2b< ™d.μŠ2ŽùIô†‡LÙIÝ"~[” & K9W¢þ†¤‚ç¥sbˆ8´ˆ¹1`îUð¨)ž8­N–þ!,Ær@±Àâæ¨âô¥¾hêéì’Ù»¡…3]µGpÞ2ûsÃ¦Š©†7­(Œ2]d{ÇñÊæ­ÃöG®ÎQáÞCÆÄÞ$x`ó•MÄ–ëO“:L2xCõß05ÐJQ“ÄãÅŠb”4¹€ – êImƒ°ýàuåÄÒ[m¥4¶|FðßÃO{ ÃTþÞÜX¨ŠRÞÆ2oAZ ïÏ5¢ß:258]޾‰: âþ‡;±¾rNÚ6œK_ sC2Bä—ãÝiˆ»ÕcÎ%Õ\SmRBä} ¦z|lñ·Ùla…óÓe ¯¨ª´åeÍÔ­·gW½ÇJ·[.8ò:‡°"DÔ®2ß1üY+¤Ž‹¼»8¿FLƒr1J7ÐäÉ8±#äí„,Rg¯ÈËkâtÖZOÂÆßg— '˜Î¼.t: d˜ïJ '½õ šJ•”ÃQK6z" =‹”fÿlIFÂ!®áE\›žÒ-˜¿Ã¯XI¿h3¹?õ¦QÌŽqáŽB xÐ#†ªž€ÕŠOX _È=5Wr¦•8KãëB€rÑœ4q,Ù±é¾îr8ëIïéôR<Æ{O~g¿JE±-M}ï¥3bÖ6ŠŽSlÄE‹Ÿ-,“ñvˆcB"6ÃJ3$F•Âr÷â 4•V²`®C:IXblŠXdgèQÖ¶J&)ùLô}“Pcæ+"W=F+IÑ2Îì;:cè|˃Fôô|ưCôçA}8lDªh›ä¨Ä‰ °È™ŒÅ׋CfC²úOùšn„ý{xïçyC8VRxHšÃt¤Ðñ ßÖÄ#î?\º¨®¾ÿYà}6Ÿ«¶G@EÙOä¿;Ú ¶ƒ LHæ8‘Ž0Ã&…Q-:›rö²•YxÁãxÔX8`ÿaý`,ñ¶NÌ6„ ÄUŒf[ͪLÍÔT™fú¥ ñ9Ànfh 7\|üZTc²Ž`b£J-ˆ6tkÄxO±ýªL§¥WÕó™2WÈè޳øƒkµå¶mÁë…O Ä,bà“‡¡]äíU½Ç8Ú3­c‰1™~G7n?ˆÜŠØ|÷¸—ÚãKLÿŒ Õp5vÅÿ3mÏê8Ç^¸øÓ9ferM.Ìàö1g–‘Ê4ŠÀ¬DgÑ¢{Êÿ¨sáêƒõpóäŸ"ßäWhÛ§4Õ2X_oˆs‡×— ê´ÅÛÃ!I¾ç#Ç _§­6«Û!z¥ËšTØô“.]FmtÍ-Fð*5ŽDÖêuVê0hÃ&j1…G-¥Q­øÙå ´Ñ±=`:^ÑY …“ãEˆÏðng爼“?á&šúÈžÚ™k“i799uDYûÈû–R¦YøyþNrñ ­4w)˜ cÖv¥õ‰Jt ¢¬t«°\9 ¾#hKì_sI¾$¢LÁ@·ãõ‚Š ¿q»ŸßY÷H·2—˜ý+a¹¡ ðïÜBÀxÍ(6¶~vÃùÞ;Øìñ "ð½ÿ;ú-*êÝ{ɾ­…:Xi”¤FXî­üèiíðHúâÊÆéú%°åÞƒÓª«]nÝ¢¥H‡êHøú@h]aUN4¹zßÇÔ üKto‘ξápÈ™µó9»íXz›"²øããÂïq¿ª8™è‚½cÊ •ž[w×-qW¦QZ9!™Ñ?á>.Ÿ_C,ȸ4lþïj»»È1¥m;…ذ¢®íbPþÃt>‡Ò;` )ø6ûÁ/ò˜\–%0HêzRÔ™±e7)îJhÿçE¿Q†,‰³ ©vù±lØÎ2áá·N)Pºô’8ª¾ªÃÕú[| Æ7Xó·™gÞIqmý`-XÄNl89»œ‡!ÿ)_ý¶8ì잟4¦*ˤ¯ Éo¤‰n«Âƒ¾§”tœç‚àOliƪ‚"Éj„o‘-au²Á­3ô”'߬¢eÁÐiœÉ\•¥QWºTõ[ø LYŸ#ôœV--*0©>Í›3bk(:õ4é\þðc;{B0…EÍÏí}v£t%Ý­Ö'Ý`SÚƒŽf”Ý£#d‡ùPÇãE]5LeHÀÅ"$´H°V—™nK¹[ÞiXtú¸ÑVƒâFÊÈ#¶t{åÆwi’á5ç_H®6Ø©Åè —måÛ‹¹GÏ $µƒº]}~&{ö‘7ç[êÿuº0îjDÂÈî< ›8Õ^É­¯$» dLkí÷útðÕâ¡P¼O™Â£¢"*5ž¸UÞ0˜H›…ry˜Ä¡˜‘ùÃVÑÎðSõDÎr´wˆZ¾ûGEXç*_5—Ú7Ÿ WË5DXÞ÷Ý5Bc@ÅdÌ*ÝK)˜©4Á®¶`— ¬$†¢ªß±Òe„D&ê:ß^E|‡Îâ_;ÕR£VÝÇÛ0¥E_aç^¶ÿ¬nÈk÷Z¿¥[0ó»÷±/?X\_^ •áJ\^˜:å$PÀÁjþ –ë°Ùà ¦0ª/³ýX9Áü½b -0n}Ù;ꊠ#jÿÏôdÚ‰¬Òìžæ§Ä=W58uÅI+´‹ÓÁšÊyWb~è땲‹'„'‰ñÝýÛ¹InÅ!£u¦%NKô |Ú¹á42íc©áF¦—L k£¦¡íø )ÊÑ'Rj Þ³¡Â,R3÷F”³^ƒ¯µ"˜¡êŒÏ7Ê'}ÛÉQN~µßbõ¨VcyZ7½ò=D¬„2`úec{_É Â±ŽÞXJÌnãíé†,<Á˜ý,èNš”>b{ž phœôhÞ×)GÉ`͈Y¨Á&Á_*ô\ù¶œð¶'5Mň;àáðÅ,ž3V{L“^ÛÕ%Û¹3·Þד§‹Û‡ÅžaË¥‘Œ! úk,+ö3äÖ1+¯¿(™)Uà냒© $‰ØóüãÔ{ „†¥IØ´'…æÄÉ] iá„‹× `=Ù庆ò€¿(I䟹° „û—žº²Æ‹R;Ø|¨/ãŠY’jmY3¨Hzl7æÈ« QCpTQ¢€¯¨(¦™ê™ÕN"‘9ËÏãqÖ´¹Jþ+pçyj3&/4³æµÌ$L‚ïí\”‹Š(ú|sÉí–•Â] Á"BHf.«ïqÖœßXâb:f ȶÿ#bºjª¹út×ø®S˜{q¡tô c‡OJš.Vá=ìÄîcLTçtsج$û¬aÏŠ²¨ùoÅï”ít3yJïbo©lÕf–ƒ ¦.ÚY#Ôœ·î¨´#j1é´¸fºÏ¦³ñö´³™ìŽÒl¢|;Çï[¾/(‘a$‘Ú;*!£Ú\ Í^Cëý¼uŠ•ÐoÚävóV›„,NGøn ¥ôS‚û_ŠÖi:ÉäYÈN&¶¼¶Wãƒh5‚n˜Ý,n/\^7Mv‹.ðˆ‹ 2É Z‚2ÞÓÈo–‘0mž óïTLII¶ÀãtÍEXTDœ q(áÝ¿¢Tù?œ`)CÃ?[-Ú]óçñU´®œ“Ú êVþsgÒdê»Fp©Êåõ ŒrhÔ”^æ$⡆³o”·™åk_lsUPâüa/¢„b…¾SÃÍ››ºþŒ¼ Kä•I š }8 Öu !liH.Eƒˆ0ªª9e`N©ìúî± ]»ú‘ô’:-ÎpEzn¶m<±–Í×Á<Œ€Ó£UZ„‡H¡eî`·„²7Чw¾l ®Và”0_ý]Dô’=RÁ-RuÙ9´‘—_¾sÔo b=Hx5 f¹PIN« KèWh·¯À§:ÿÄ™‘U; ˜¸ž=NˆÑr¾íL¤P¹=‹i ¸Ç}‹`tó2s¶‚zUÎú$mÔwk8„)ŽOŠW+¢ã¨¼â9ðYL¼M. º-—rØTËÄ¥n¬Ú&þåa„zfjÖ$Íÿä^$+<ƒ†Àº•y5ENÎ3#*ge¨j&)èhØ~[¡…M’'+‚TÇ̇M»zTLÑ·FW׬B¹´¼=‚tŒÔ¥î‰ Ì›åúj°ÆKØ‹§WÑ?îÅ,ðàTȯ°ý¸@&3k=1/U¶V#pçÈ$õxX6>s’6jOôµ¬oçÚ÷»µéÑ6˜`ö}Õ5O•°Õz,Á¼¦~D ?tÉ‘•»]ƈ–”[jü;C #œåxU_˜~ÎiMD±.¶“”ðs˜‚7¥Qk96ÜÞ=Ìž½ 77øô²LŒ&Ç«7ûŠâ•¸5c%nè_Ò~FŸ窾*fív¡,îõ.ºê;"-Ë!·¡  X¾Ñ@k6[ëÛ,QÌT,h¬œ~£«øþoÁ&ÆÂš÷Y¡û”R[%ÛYÿÂg vÚ½Kê$ÛNToµE( :-jVˆ,_M«þe2C ïþÀ¤jÑ#É–<1w\Ë­*F˜èÌéÀ©Ov™ˆRåÌ©“u•Ç”fíѦ…&ü,—UÌ2x¨s¥¬ãÕ:k)çðqÙaê0#VÄh‘éYH}ê_jÄ* ÝËõœ}£Ü* yÙÔ'çöÒŽ•ƒËÂZ†)@öÐìc£—}²'¢¸-ŠÍãwÉ5컲¥ A¢á“gýz Ì@g4~^5ûnÔg=á)úJúðωfµpQ+êv¤Œ¿îŽÙÂß‹Ôõ[:˜°ˆƒ%KYÉ ˜å¯Ip’œ$*çhptT+Mé³Bp¾š€9ðÐðÇ‚9Áç$©Š–d…Vâa%fÏýE¿©ýK‰)oÅÄÕ5hý´+ßmsõªp}!E©Wõ¹ð…Àÿìp8a­’˜ù\ÒÌó;1Ý©²Tã !5¤r²· uæýhþH£wcÇww‚o\–ÂÈ}ln Ácæs›Ÿ‡#¼ `!d¶ò~ã/uSBѪNßk"Ûcf¹âF˜ãÛ:ýQ4eö+ÞÿuÇ*:elŵ¿n`2êa.ÿxÃð«6'÷qìöÂo]€’`lÿ~½^ê2Wˆ/šPÓ½—IˆŒBÛ;hÁ£ûV:¢Ý9E‹ë0å=œÐÍ:ì±¶ù£ƒ)Ù Ê7˜‰W¾£gý´ºõž–è pÜf×J µL^àc¦çÏâã†6z#á[F‘Í]ÀŠs¨2ø_½¯š9¾pµfN_-›»ÃfóüGÎ6WدºÖS²HX-¿ûµ  Ì…J6â³ÄHBUs«™1wÓN qLöÐHY†¶Hô¤ŸË$m8P=‘}$ƸÂFl$’‚e^@]ž‹b?Š@„'x¹d <Ë{¥ÂÒs Y™G$¢^žd¯Ûü“¾#°õÖå®ñŸšUPÍOü©›Â_Ž]º [„œÚÇ^·Ú½®j°º•U­;J+¾·T>p€>GÂ[2¦˜0Hø-OÍéLÉû‰>»T´Žäy$¡ ù¼\¥2õòM_†NG3íêÜݰŠEwœÈ6u‹2‚,Ò0•àòe ÁŽë)¿#±\$”ÞH¨½8Ú°‡{iTËͦm¨’YÕup²FµašÜUç^C4€]ªö2k‡Z;¿‘Ê’z¡Êä /˜Ò¸âbWs;ã0¦(üM’c'ñÄüµw–z¤Ô[‘ã}Yiu$¶Š?×€Åqµ»ÖR,‹ãŽ9€ÙÁñÂŒ*çW˜ÂͧékØL¦ € Ý=à†®=àm`´Ü é˜ ´¤ñe¥ñ¼М†ï2jQ›Ñÿßÿd™q³@9c5’žžÃ@8FðRÓGƒT{Ð9&\ V 2fµd¥ê˜‰G|`œ®©æÆ!xPµÌP8³,7« áIg;ÉÄný¿¸çÓù‹Ô ì†*<1×E݇|×~Ôú8½EÐ\­:—´Ùbõ^(ÉÛïÙVjܽxa¼+cs-šîQ³ÛŃà/ÎïrªöÏwÕ^Dù>·½þÄ=è‘îÀ0:?—*8§°4%”i?~³^¯Ð¸¶–ÅЊÛVIhÔùÙÏ‚¨¸ThG‡`Ñ5çAfç!"à÷?„ß2³ìbAh–ÔzÅ*™×åÊÚ[Á]ûŧ$ÖtÉMUå@QhWT=qqQP¤Â…¨ÄH¼ªbqEòÞÏÙ>G¥:†•}¦d¹PÏ1V¼«+£2LÞ¥ït¿&–_Ž #ó“ŒJ¯#*µó$®7wyÕ·Bó_iPµU­‚dÔtEý3Jw¸Eè°ÊE‡x©1Ö}°>I ÀKY}ýôí§œ¯ô‚q~o`@­ÑywçXø¡ˆlà~¹ÀÃXCïä–Cm›¿W`¸ 3é>n•¼ïÁcwßméÿÙJ‡k4P„ ‚øIvƒ¯K?›éC‹‡uêñ´Š·bçÂvæ>p*÷})ó&ÇâÎpa9餵ë'¯.|’ò¿ kdµ *àDŸ§Â±F›Œ!¬³¸Bþ´¶bØQ1]äT/]LŽì4E}ÑtaqL€ 2ÏŠŸØ”Öh_„”…5×UZ.`áò§´b§l¤ öH8#½[ªø'øýE'n.1ÿRñÇ>IT vÁF… ݈^ɯÁ7´X‰*yÑèªÇÞ¡ “éÓ ,aÂÔP̃àíUÏ1i‰îßÕãòÝÁÔKp„NSQ>¸ŽÒÖbͯ'&-ÃJêY’ eÊwy¿o&+±×³6rW~HnÄßb[f£ÿИ¢ÂG/3IŠ+3¢öËŸAÕjj? 6q‡c‹å¾‘X ŽF£S=d8Wªàœf%)z]ÄÁ¿$!eØ»l6™)ROÎ{«ës5¸žÉ-#­)@sØrEuQ;ãÁ' NŠÇ‡e˜©Ñò½¥D¡ kNÙÛ¸‹x‰hQí>ÉqS»)ñt ûGáORŸÚ>rÖ‘ìÑò«7(\¬Å1$Tkœw ªÄ‹ˆß|F¤Å+91zÖ{€]/\oFS’—¤I¸2 ìNГ˜-fâò¹bò°1³¬-c?á¿ÀøHó¶2@¯ºôõ }'HƒŠAÔÆu0g®ÞéX3ûí8Ðç0š¹C Py¼1ï’pÇøÉŒ×¥€R´x–åÙË^älŠ¿!ûÎŒù<Ú~%LSß‚1^‡ÄSis‚® ÞÚ?‡Lhà~¶‹6ú¦ÕiׯIdai!ÿÑ9‘‹UÏ-xA¾®:Rô%Ù|AAÌ¥÷ªîâãëûªÍÆ«˜~+è°%–ÊŠ%/©Ñ¦‰œvÆ0ùß-s0Q`©!É_èß§5“¯¤Gc«å&ùo&Æna[ijGxüúpD<̤ýùÿhƒkçD!ñâºT×&¥"KØŠÛµ¨b1RªjŸ(¦<ð.“ŽÖ…šh”¿ÁJðÚÅGñ$Lèü»)ô]>9`hsÖz±ÍwÒ“>×à#%ìËjàåüž!ÖÐf˜çãQbV±-Ú(jà—U4\¤|Üú)yDæ PˆfêM=zvŽàlml£"»@Mºy²6à¼WÍNþFeuðöÜ'Ö]–y¯‚IÄØScϹãÄêATI°ombØ0oæ\=Ú‚òóè„ýŸ\_‘JU”-˜šº"!¸ˆ¹¤G˲-Ù®ÞÝ)[´­¤^…¸û¢Ç5¹­euìŸá8KŸR¥JñÈqƒÙ®©z™H¯>i¯+èãpqc`ì£-ÿM·¬Æßí¤}Tš·î`&í&jÙ)Yû«!šê9¿Ç.–FÜ{G U‡àÞ„ˆŸ¸S“Õ›rgÝ4ÊÙó=vñïVfI”œÔ¡ •gJaˆ–3  ôAc7š\„ƒ'ð½‹JT)m†×ÿØiUÆÃZŽÔ$Ð5iÝv2ãg3(S‚z CôFØW†^PFš]ÞU¬¦h6©¨ÿÍÞfªEµ Ö9aHB|Žºý°æ¹•ô<ÿ¥¾IXl pªØmQƒbx/g¬þ’ÒHZF4Ïj¡–_þc ”O–Šÿ—`M&vÜGBü¬ÞÜÆù?6Ô³¥ŸÚJ¼‹é3cídu±¿ý®´Áã˱Aä-@ìðUY)ª ¹¸@ŸyÓWÚOÆ?%P Ê/g0ô"Á¦Ô´æ¿ï¯9VúwhT7^ɯ`QÓ14E®ö.Vâ }ºþ“æ¯Ä,—ëÏû”­›Ñö-mU øE(\î{o‹¥P§sz£4NØkŬ׆›³Ã(›DîI:À“s@>“3°ˆk$âï5Ü+5ã\ f-«°è¬^™9’ÊáRpáu?¢•/ êC`~}–@®ìVÃð!/%Åo~œ…ëò˜ À¨”Bß„v ›sÊÛ:XÂ8ìÇY¦-gëE(»Èl@ö¬0ˆmã%I$[.û#—”M\‘ªNò‰µ0TnK £lAßÕ×b‡eNšG!F_¨ø·MùìÏ4F_r–Ñcg!Ü|¬3òEÊÝCëÕƒ9É:,2úÝÄÛP7bæa%~*Zf»Fú1õàÞ}0æTâ§c|œ™ŒÆ”]ö`þºPÖu²Ã•’ v-‚nhÇíø;­.+ bqýÛ…ÀËfLöŸŠ<–/*’܉úû·t2%Þö¬bð¥°ÿ¬²u-. uåH ªà“Õ,=|Ótn=øbÚ3Ïçž žÜzEžò4|B–º‹ Ýò'Rü—-î;?›iÂcµ¡§Œú‘ˆØ£Rì#‡y¶9XáDÅÊ[AMW´¨JžfÕCSøoóŒæk-VÞ +! ú}º/˜mí†/ðP¶ë‘Q^o\ef×É=¢ýfNæ.Þƒ‚æP]žo@çøs]lÀlõ1~«>²KÄydEṴ́;Q¡°7ðBðc=s€m%ëTç_ºÂýé(%)m£IÞ‘\D­tLã<€Âb»çøšD„+£ }«XWÞøÐ,û=¯§ÆÚšsØNôļ¬ëÆ£#±TÑÜ7çåš_Ò"Wí6߯ e;j³qZé¥>(ùƒ~tBS8$HÞýfóѲS…ør±1õôÁPØjš*{¢K |sÙÑ€PÝ\…^ ùÉX•xžA5Ìä—b´$=]¶7)/­IÑ® •UCAFÏF–€ËéßyÃñÚCÖ\0… KéOíü~PQ~—M¸.ûÉ=RwÈÑ ®@QsU·»ûöWxËÀø½Ü—´)䯉ò-Sœ×ÎNñbþk©-Æ/îŽìµÕРöc›ñ ýnŒ2‡Á‘Mê ½(aÁ_5.isO©×Šiå£ÁpfÿNexv µcòr'_ºæ­P1¶ÿ­¯2šYçÖÖŽŽ«åY³­§n$œÙ­vئ­Ò=ÍÝ[ð™Ä)Y_Sù€&C ÑöêJÔ÷»>[)!ŽÐ `ýdU¬2Þ”T>0ø.ܨ®V‹Ùãâ.Pæìå.fáÃ’çND˽a`ƒy‘q0øZÔP éþ“­%¤ße¥÷hGe_BU¬#ŒÖþÀGØwWTÝ R]ºó6û|o‹wã¹/*ÊpDx¯Ú´ð€BíÜ·ü>t•ç- %30®Z‹Å‰ó[²bhYÃ:“Iïm… w3×Òe9vŸ[Úic?‡.Ò,:@üÆä¦øî»€à­¥ón¢)ì·,êãˆ)ÖÁãŽi©ÒJ (ˆ¸öô·Jž9xÖ`‰´=û’= ²“!:ƒ«†¯Ú‡áÛF£`x£¡€Wº '‹5€”Ê Î h)‚ÔêJ´oÏj€¢Š÷ò?ÙÿNk™è-%À–”}Mæ÷ Ÿ'Ì×îMÂ=]ÍÙ. Æ+]ÈUbjºèÅÝH:åacÇÜ]VC$º«09rÆ#=Yï—¦#Ѱƒ¤jR×å]ÌßÙàËõ'H¯Dpiçâþà.œ%‚X<~< ‘­óàD°÷‰\r_³ƒ&‘Îd«-8åš©ï‚ämDVy”¼å„¯°­–½-ã}çJEì ·Z#’Tûqùê¥À]\’vÏá6÷J¿ï€¼NDíyb›ÎOõ KÀ«ýïb\¥JNm¢µëé÷ªzrH™;Övî+¸<6wÍ…šEb( +˜”‡ÞÒÖ"ÂR!“±Ný°ÇV.. ô'7µßÕ]ÑÚº nÿBŠüA=”ûƒcybøûDÿ6ÕòÊ,Ã(Ï£2Q”ôvÙª8 !"P!ÎÜü^µUØt†\)©_úÖæœXÔIA.3BÓ³{3ÏȲCâ#.ˆÎ¶gjÏE¼,V†ËøH쀑Å7p  e)4,ªžðý®”T’ŽˆK‰>æT&4R\ñ¡ùm[.g^ÄÎÿñ†k[Ò õ;ˆXÄí†$J~%ÁJÄ` f‘‹Þj;z`‰,¸¾?ò§ôÌ-ë_.»¯[aâ7ÌsH+–úÉ¡êSá$‚*‹P}d^±@氓뤗6ÅØž¾ò^êÎ:Ó/.Þù7p¸©¥ to8”Cì=ž«>¹ Fÿ…xæ÷§ÒÑèzB׬$Y7ú£›ÔíÈ>Í(Ý~Á3Œpç¡»¸T¥³Š–F+µUüÿÙ¶Á^%,¶õ$aá`¶ƒž~”÷WEë é¼MwäÒmtŽ’™ÇcðUË ûÂËÙé¶æcIf±¶ðe@º8ä°„”EŠN3 ]³|²õœ!šðEâðn‚ù<¨£È½9$!¯›‘ ®ö‘¹#Ì£ nŽv½ol#8'zJÛ²©•KdP¢²Cƒš‘›ü£"s…ô-öX…2´.ç ²Ý£$d—‚¥æáå/‡£Ëê¸#w2‡ó(ûJ‰îL(Àu¹zx·òX×å¦ÒÞ󘵰ä8êáVW&ÃôÿäI‰FËõw̃C,î¯)³[ø†ùƒs ˜ >z‚^ËêþˆÄÄCÖv͉˜m¦²Š×m½ŠI¼ÌZì¯7ï}1éýkjÑÍ»ø—)2KšÏ}‚±öðýeéüÂ4r÷bÖĨ%>BÌ>Þýu¿g#zs××xY1aµ_û|@ɵèà'øÕÎ?üÄ4öܶY1%0;ÅÛQ›oýOXâOye!Ù€êW‘"XZ²‚ hÜ|Xê|°a Dª¦‡æ¾Óð˜‡LW-IUŒ ÜS¡ÃZÜœèôAŒ>ƒ=ÅßË _·ê<}›ÚžÖÏ/Åå®,ðí/ÔûÅIƒPÿÌ¥sÄújdim-À^šú¡˜EÚ¨XÇŽ†Âà´Ó4°Þ¨Š3„Ûªôt)²~쌾êS¸¥šÛ³ª@½¸_:¢Õ»F6æìtƶÛä‚ðqˆPɯ©‹ê‘U èlôCQ‹\½°|Hi?c0@à€ÇŽ4 œ¿‰æh•~ãti‘UÀ¤ÑäGó÷ÆJŠæ!,Ì’ƒu\™QfŽTZ@Å’¥Í·îf(k²:úôœee!ö[01<5U"=ºÿ"Ô|åÔQ"RT¼ÜhB˜ß Òô*ÿŸ~wQuïºãœÊYVA1´¸³Cuï’H†3Íå –>­Z¡ò[~© ý%àÈðOô9þ– ‰§Ò〴ÿ‡Œe#ð~rä 3 =©/#^‘ –ÖçÐø»#¯ÔAóHð¶Zê™`êäÔ`nj /ùñÚ¿~†V‘yi=æ® º6BSs¾"³Qшf¬!Å[J?P5c@Ç ìT¤ãÈríñ'æë³8Ä•µÓÉG•”"…â°‹Y¾p óa4Ü˨—å¡¡&Øfv¬ˆ©Ö7ղͪ)îeúv°pUàyRÑ ø¯5;Òì_˜ärLÈ醙$NåÈ‘D@u¬— ̺Èògf æÒÄ€e‰¹Tu_X=2Ï+~YýÍ| ;xb*2Q2—ÃeFÇz ¼-bC7‡ä÷ÕÌ®9âËš–™“)@7´@vlÒ*T¦²¸Ä;1gw+ÛI#“d±0Æ/DÙÞ‡.«¬ çi9™G¦B‰Þ0Ø@k”åXt;õéoóir)·¨ Я e/ÖQÇç4Ð)\øŠ ¿Æ2Ý«ˆ&6ÕåÏÔ£õ]!)•õ(M õªT+¶œ¡5$q…›¤¼æù ­`ìÕ05šÔ{±“„¢Ÿ»cê L4<»×¸U©ŒÜŸÝ ÝŸßí9¿Uˆ;Âì×D©Oí¦†gotèºcÿÝyb&'^ÔÀÓò=S·w[;?}{’ ßnœQ¥é}p|–£)Ï{Üñ€åÊ5þV΀zwð'ˆ}ZAþÇ[ ñ“5dø4@KøKaÎPÅøh¬ñ}}øÀgâ£WÀc‹A¯TÚ5NÞø•AUn£“ö´ãøf|lûk2U@`1Ç0/Öÿ» :@¿4ÀºÀ`ç¯ï èƒý17šïK_ݯm¸Š ÷/ûl¸†ÈÎRËL.:P¸’ñÀ ·]&ƒÒó/Š‘ Gx-°Î"¡øÃ³¯¿§FÜÓQZ(X÷}oH ´ÁûgÙÔm§TñIƒµÈËmðnE¯—õõ Ê8ÿYˆCðvKU;¶|áN·¾Õ€Œù¿%PøOí+$¾ª ¤Ix녕ȱ+Q&ÀSŽ“÷3õûîÆÔ³Ý¦<ªž²«ª"~Ífø°Ïqâ×\"*c¢Ü k:Ȇù’ókÕaÁ¸â¹©ã¹E¨K¬càãç"!kNU)¶Ž€×R¦íC¹Íúä%§ò9w[æŒxÚZ.ü“+ 5'zO¸©“B4‚]›¹ì€}²ÜÐÀûdÞ$õ…iå{bh’Œt¢:ØseRå.ª0v0ýäyo¯µ¡JƒŠýIùkÏçÇßåH­ÑÍ®FUöɸ@lU>.eº3EqŒ¾+ÿú_gäí`=ðÍ?~ßµe«öý¿~ %Ørö™ú1䲑+™4Át×Ï‘-T ÓÒX“–/Í£9ªƒ¦ê [{*A#qLÁúð\º¾=Ý[é¯b"¶_ñë7s¬¶Ì‘9 {¾«ˆÀl"ñL^q¬Å¶ÑÐ(…èFþf÷‘¿‘HIâ\Òí‘kpèˆW±öŠù÷Äa,ˆ%Úɤ° ¬î/Zd.+9é…c0Ôð–xzÄ:ÉSEp­37Æì¯D…¥¨ÃOˆ5¢y÷®àÔÅ!7šÚLì´W"8Ö®÷Ì·*æ{H€ø ²Tâ+Œ£ 8‹”·š´©qÅ<ô¾Ðá²À† ¸nòëy%@ªò®¾=)—$Ê;q<çO|>°¶ãrˆRo`"[}ÔyŽt·cÃÑWkûv~œ3L2Ƀº—çKfó£'y§ìwjÄ9a‰”LUÆîyå¿är¼­M×þlˆôðh]£Hé}Œî%O!$ñ‘L*,ùÐÃ&ûLÈ6GËÖ›fHfcc~ŸëШt°NƒY(°îÍÞµëHòÏÈK‹]½ÈÔMäWͱ‰Ÿ™×Ný–Ûh Rà`´.0§ö¡¨ÑËtï,‰”3ºÇ·Ñ¯×eÍ~Õ]àî6r!+™wav…SEÂRÖáµZNF!¬rѹüü¯±VJP×€oèµ0RU3-ÞMOÚ0béâhÇHRf4Ûø® õG GZ;‘¯sÙè 3‚Ot–«ï‘æÜ4tª aòX3_J\ª~Ûá>¼¼Ž©RS"âogè·q"s"þØ„³PÈ`Ú?übŠ ‚ÊO-Á? ''¬fqç;Äp¼…&¡òÀLqü0•±›j„zcðr÷=…’eЂ’p(DüÅ*î¤áº¥¬Œæg¡óhˆføÈiBV¯<»”U»Uh@ ^)Š…kF㟺D×ZJï…cÓ7:÷OãðŒkEÁtb';w!B±°²šfÌLºú>/Cêó-ÙVÒ¬2Øû 00g=Òáè ³ô?•³æ8|Ä›¡3I'¼¶"f+?=Ñ^!Qq}Àdš´Î͆«r˜ŸPK&YðêÒøÛ5Ø#áùo–ÎûÝô?@YqhßÉѸn@ÈÝK8î®/| —qt°Ú`ò!t:ÌvýíôÂŒ¯'  áïãÆHËâ;R,˜îÀ{ôâ$Àöd¬]»ÿåÇIíd¥¶YðÉüN -íM‹†LòU¢ÐϬ!â!ùÜhqÆ|ã2ÖsÊÕ^¹iŽ“…Üûhq^Yï~jêùëæÊñ ØûE}æýøFJ:‚`‹£Æ2¯IžÚ×U€A i'¢oÀX+Iàß¾›´›'5lÊ9<8øGdɧ¿:IåFÔ7( @{õÔ:ƒzo¡õ ùS&¢´‘<•°â¹šË£9AJ­pô·{1W(gv—?„ ,¦G–C»Øv½¦ƒ䤤QK*ÎÆWíÀ¤Ï;ì¤NÜø@ˆã4ñ5ZoÚY ×À÷ÇkÈdp—ÊQ^Ìk‹+ÔîD*†1[dÔt1³ÈL‘ ¡®Ex€ÖëDSRêÈöôÔf «8ûfgÝ•ÊP_n9m$cwË|ˆ¦ù '¿ê¸ÉÁiÿ+dÐðkë|rËŸxçP…æ³MŠí ¸P{S¯V—%hð]ˆÙ˜Sÿä ÈHÁDÇq@Ô~›ÞÉ‘)ÿž!‘t-ÂøØZè mñŒüN·ü‚@ºvAf¿£çU94Mw*èªOßõGÝjHÕö#”¾çjÔ\(ÿÚòÇöC<‰¤œD3’ŽFùƒ¦à÷Mê¨Ä7_Šõ]lÀIó‹ ¬Ó^æÂû$ƒ ˜×`5ò¬¾÷–¸G ñk•4˜»öD©•ǵI(9ÊÔ€ ÊÚ$b¼Q©â`ýÌå…³uyÙÎùö°~€Ü=k´x˜sðíVÚH¢yÉæA%ܤ@³5QW0Šƒ¬ÆÅÀ¼=ÄZ!´¦ÿá Ð!ÙhÔMé0q“:Ó:ZÐH‹°kPm"“sÕ6¿cÎ!óâ­sˆkY7”*êɸ§¥¼‰›»šS¸YRxH(Y.ˆ| ;¤_1‰*±^Ü2Ê†ÅÆQv* |â3޾Q^À%"˜Â‹n³ÒStq îÝÙÏj µÉñ  ˆp§”ò1Eê {,XÉjõŒ3e€Uë=ç¦ëØÞQ€ö]]£ð?ï`-ém%¯œF‚ߺ×ÀB,;)˜·Œ¬1gIzvá`Æ:Ë~¾ÐedqÞ$ÜhÂþÝ$Jâì¹ìƒN0¼”îö‰1Üva €úÉ?àй½9š¾í…¶l9Õ ¥B½~œ˜Ößóf^دhK‰pÔQÌúDK|%Ti¹¿ŸÖµÐœÖ·òr qˆ…œWì¨bßlvÞ0Ô*Ï„QÙÆO5Ò³§›¯4ˆÆþ Åæ×<•ß$Çøj³¤z ôdèPÑ3özÆÅ=‰Ö}ŒJ·!Èõa©‡MÔéy:µãŒ”|WÉp†¡!{]ËdaDæ ÚðFCA y›.Ä"몟ã!A¾N¨NG"jÒ«zÜÀ²¼2¤*ùUæeâ-{`ýW›_Ó¬ŠOà>ïå«. P Ö´¯ºý‹¦s‹…VÊ‘´°Røáa±¦ˆ¹FÎç÷Gûõ"vuz”.¬”[ ¤C(ô óE©;¸’ë¯üÅÈ‹F™ŽæwP:¬AT_ì!þ[|WÚŸ‘ÖÆ“Øž{µ~?Lb[fSÞóm];HYe·Íb¨°P€ERÈNUË¥bb&8“_›—Ghèî Ȇ£˜þèvг´”{<:Ò^.r‹&U@Úµ¶7î\ÑÑsh'K‰éod¶ªó·x«W VT¾ÎÏâDô&] _nê¯7Ú÷ÝÍ_‘o@ïê]?}t:Xþû(Na””“ÓžåË­ñ3G‡‡BªÌ*9™>Ê`M§G.ÝT›²DfÇ>’Hµx“½yË™Ev³íoþ@=ãhOtÈÈ2ëQ¢g¥ååÙååý[pÙqWuÎE)© Vt ø}˜ܳE<Û–Á€íª#yäƒbüÍX¬Þdï·ís-+ƒ¸áÔŒËÆù<ÓÖª­ `X;(;gYÇÈzsÅ™)mÅLdT‡x›‘k…»ËϾ­u´­:B*;45¸uSesƒ)c€µ\:Cñœ°E‰¾ù"H2¶ dü×ÿŽö,yHvi:á%öæÏúõ7OnÚY¾Ê·Kân³ÄÜ%œÅ#H¤wz¾k /ì¤-vs/Ù,MUü*WLó½Øy–½ÝîbµÂ©À3‹buoá ÖAsÞlŸm« íêù*%]3n5Eoñ€tºw²¶­µ¤·£k3y•ÿ;UhlìÜåcäá'$oö­&hu¿L…ÌË!ìÃV|{”vì~~§kâ/ÝÄ“Qp¯ÊE.Bp£[~žuòÔ’’~ôcOgÕOÑ{ˆ›£"ôÔ¼ .n½©ì³ìਕ¶?‘ßä¨X1wæÀBÝQ½+—’€B1,Ú[tÙ‡Î^’<°Ÿw éúÌÝì6ó¿ä†Åxb<Ù7z33óêZX˜Ñ¼.í]7|Î8h¢æ^§³XàU){»[x ß]â8^ïS´¢ÃC¶á¼DÐÑäÚ¾0¬R¬×3½ƒ@ÿ> žz¼Rªña¾ö{Áø±©Z?†,w¡,˜$߉¿‰U+é\]›7vžh«Ðxà­üÑEî‘÷HF¡·ºÀHÝ|jÚŽDéÀÙûRú¢ ZZ&á} i"­؇P·>Bwàã]è‘!A†Ð¸ ¬øç7ð¹DD* ‚¶Ù‘´)h¡¨ØÒÉ 2³þN0:–ÉÑâÚG±]-]ñîûøøú‰žµ+¿–åk7c Çö‚Ä®>yðòÐek842_øÇø3¦ÅÔÁl0B&‘î ±¿Ú€çßh„Ž˜,ÐE>8̨jíMÒ:D$Ý ,Ï«€Š„aL7èg¼‚í49Ák3#N­ŽÅ¶Ú‘Åï4B5QmÑ ßý·Àj³íìîð˜;õL0pM¸€ÌÏ ýø:Â[U%Ò«ñ¢–èñ„†ÍYµÓê¨áø"çþùŠŽ–Q:iüð…&â^¡nÚ¸[š1΄ìŤŠãL41º‚/ Û} 5¯öÏò'%]·ðpS (6¿’lKå-À;]'"¥g$;S^Þ¦ñaÜŽ»œtuÇÖ.v^DžÎß³›ì˜S¶ùe\¿ž 予&/ü® ÓùATtýeu ÜDIئÉÜ9£]ó3pí>.\Á¹©_Á=õ×¶¤¦óËL ΛT˜Ç˜h)öÔ_I Ã$ôÅ ëÿÙùê¥Ç5t²<â­½¬‹¾51´z–Êîì†Ù¶AóSRé‚ãI숃¶ƒ4’%¬×ˆw¸äÔ{µ@'¿EôÀNuƒqM$ñPKÔ]Yï¥7Ü~º=Ÿhž=Šç3GŽZ.»µ¶|ËŸÊGùømT/oůäÖÔXiTª6¢Iˆ_¶¼¼çWŽ‹mWu¯YM=‚ĺÓ‰Îß$·jL²ˆd }äÞ#£ÞÚ©Ã%´ Wöçúä8åc;8qšÚ“Q“Ï_[8‰¹F@Šhü¥ d¡:)Dè2 äCÓ: :òïÏ¥mÇ&¯vƒ-µUõIíÍ>ñf̼–s»5¯ÐY$ðA…G}Ìj] ‡Ã»±PÖÓb[õ5¢õöF±’0z%ìÏfùuìïÜô V&¸WËè bpi&AºF~Î Ì_iBøƒží’ÜŠß»¤O:]ñªµl¿ÅýgœC­ -I”×pÇåÚzií°}´Õ„f0 ì¯àþô-’œÁyþð:» —¨ýª‡àëKT©€Ç€7È]¤“b€Ø›…©¦ˆ†@»:Õ‰„zú‚p€-ž+{ìËÈ·’2`ØZ,·-’¯€¼€LˆÞýHbé–°RØuvá{J`Â5Í´8îèFiÒPp)§]e/)J•zšf›|_vj1áø¸“yaà‘2se] Zúœ‰Lçì¹BB§ÌsÜŽ Ã1Ït {°#²ÂÒ’Ú@=8³-z ±ê÷P2æo‰âÍNîkU¹os~°z~b×þE[d‘PB”µGÁR÷Ù¥ƒå B£¦W2½†ÉiÈ]!w“’‹ ?( „o¸$ˆnÊ0Ql#îÄ.·~5!º…˜k(ÿØÂljUƒC>`þE’·ô "È×ÐI²\sÞh´csîÀp‚„CÁ»(ÃF¨)¶êH•è°G78øªÑO(©g±H•5ƳÉþ '‘Æqgo‡ÙŸûR¹¯“‹3¼þñ…Ÿv–Ó< ¡>»<î@jS×Ѡ;Eå3€ÞúTk_´ÞÉÜðм&]D‘ÏVÃyÝ®ºr¤VªÝ:±`ÞÔ’§øzèaÒl­ÜÖQÜ¢/.¯N §éí2ú¨CNøàñ4ÿÿ3VCbÁ?¡¨Ï9¥ ¬µj^Ê™„ºN´”S‡,`ØiwqJ©.¥bR£9ó Y¼_%\÷£Ó£oÌÕÌ<‘^5n[äèkO™Ï ­³ë,í·8ÔUÃŒÄ`X˜´¹¤9»\Ì#ÄÕß…Ÿã^OhlÛ#Mmåò¾°‘SLî¦j¾#•2š–w½ Cn7Ê‘|l{>Þú¢]8ibù©iî“EßQºMS+°7J#ô0x‰œ‚,TÆ÷9 ¿Ç@è‹I¿.øÆvÓô4®–O»Ê¡îÃâòµï0 ‹YZrelsurv/data/ebmt1wide.rda0000644000176200001440000004456014741433256015260 0ustar liggesusersý7zXZi"Þ6!ÏXÌæŒæI3])ThänRÊ 3ÅT¬ñ‰ÉhnaD¯ò‚80 ¼t:Méâh"a<°˜SH5‰â›Š'Øÿï‰4ÜÊ{pŒ>éô_±7´„³ÁÔV1ÃD‚² ìŸê¸ãçÏÞàuIÎÄ–è¾\Q&}&tQ™¢„…tæÁlû5~¨<¢`Ätãe*Ü-;/›A×îÌÍ¥y“^?¸BA^§£ñÞÎ8àduÙu¼ÛAÀr·¨cºMAýS—-õv÷´4*¾E?·…Ïe+êUï›L:»ÈìÛ”ý®°ÄC4¨5à ´b`K–¨´Ê‘MQ¡Ä4¼ù¨\TœVÔ‡+û­äºÐuaT# ÑÈUÛÒjÐéºø¿Î;mù`®¤úa²ñ}€ÚGlQ$ÕåßI—!(M}²ò‰y˜|3füÀò}Ën¯¿T¾ËB܈=šæÎôLÍ'¾Xpœy/µÙ&”y+Ll|wŒc4xרJós§t«ü“‚Ã,3¡Áζê/ýuÊÓÚáÙ;[%ç…ùC"ÕÖǘ«M'Ø=>tlBj®8ç›TJòœsßÒ+‘Ô›*Џªeî¼Ë«ª(L«‡Û“mÆIKTQã—éá¯ñ¢æ †ðÀ`q¢•Ô‡ {`SåÒ>e¼;°ë[ƒ|-½ñQ±—ä=x)ßïþ…pÄ-}ò‡µïÜ›;|w)71Ø5-,:ÕÈ)éñ ¿T”‘bÿ•ÎÜ,Ѱl´T•Çõ¨ÉÇ…àÊçîÒÖÜÀ³bšzfÿÌ7tÓË%7 ¾¢D´7ÙH,%1âÒŽÓS ð6H»Æ+ö-ú¹$öŽ^‹Šñ̯àÀÏ´[bc3F$ð€oy»[Ð…ŒÝÇÄá|sé„å6ŸçŒ­ýGü|834Ö?ãZ±ýé+p!ƒ Z·ªiªù4ˆC(Ü»øïn†D ZË[@ fD‘™CZ+G÷Qêžt#öv÷kišñÏ|(xª!ö»XÂËwaMªØu¹ÙÇjU¿éÄaW}äˆù”X˜îCúOªIùúŒ –MDjq_iZ%âÉÐ ,Å>ú¹»ƒYüx¿Gž„Ÿúc-Ñc7é{ØœHMÅ7.y*7öOòÅK¿"s1„}ýùÆÌ°Bº8»!q@w1#­J¡„…3Ü™êFÌSê{TÅ ­™‹ ñƒDÕ7àc°´þ\ dyŽà ¸ƒiõ  @~ß0‘pýøŽâFÆày¶æ ÐrÂîØøRŸ6)«,lí·áTÝf™âkþ6YàsCI¡x5þ¿ãäï—©­¤Sç°Rù…œ7xJqHaå !=>õFXzQéà‚ÈΛ—Çü$ ¡Dÿs\(³LckÆÎâòQýAŠðð»Þo‡±¯å¿¶²Pß^s¶ÊK:a²­ÌÉñS›”‘c3ü¼7ðökh‡*Ïb­bÉò>ì˜áÿåÙu1§™I-¢£SÑœ)øi—`em¼2Y—ØŽ‚ù]†Y˜:GÍÈâNu9©[XÚ‘­—nÉ÷ç3OÃV³)›ómXÚ’½hùD‚pÜË1}4íôƒÉ8  Y»8ª©(“§çÔâ»›ÅÍðî’C<†½J£_AOwÎlˆmö#Ò°¦l¬ËÝí56;cƾ…ÂäâüÔb|9Ì.ËÕÎq w#ëFZ§®äõûP‚ò| Ã,çÙ6ªα þ9Û‘@ï¹[a Īۓpˆ<øBbGð^V½×YZ&¤,—’>©›3!šŒÇMÓç>Pûª]¾IëAø×ÙügT(Aç8yrÀSnßí½ËüîŸ{Ëé¤Ê”«‡²̶PÊ7"´Gn ÁOìáíÅjn8ômL½F€þ” jùýÍç4(0z·ï6&Wô/“0Ž—Ùðl›úœRžÇrAHa ³‹ÂjÏÎr}âj;É(áÓÑ¡ƒ‚5]Ž)tŽñi¹Q•’ µlA!iíMuXÒ·j«Y¬ªŸ*G:úø°;ô/ÛÈ=vNClýµÐ~ _\ܾ£?šB5ËûtºŠQÒµkMyКêS¿›ùý8ÂèîžÅŒádÛ™XJydÃä ÄÄY”†ÑgÊÙ›{‰ÐËÜÅ´»jë¡]ŸÃµÅ¦ºÝ1Sék“‹ÀúðBº×à<ô `¦¿‡i•Ëñ!ÜFÞkHþœ¶:;™l`ñù´\4#=¤2}‚Á©ñ›´s~%¡ŸÛ½rDOÖ2æ:g|Õ .{ÈÒû(–7}}vñ$¢„h†¹£Ëò¤%"á4IL;ãቒ2zçÓÈ=ÏÙ˜]ç¾)usµ½WBwÄN̦}ÃËq亂¶)<÷ ÷íxèüƘú}<³Šêa£ˆYö¼@﵋ë”ÅôˆX¨ûXp_áp³%8X¿É:¢}ãÀÌ¡³õ,ç¿eâCgní9³°™ùOÀ.>Öäa]‹ ÂO‹¿®Ù>v~áäãLTÉ}UÀ±ÁÆÙôÝ[P4àYôn:‡–âïåcdù.¸0¬ç¡ÕÂ;~Ó™­¬ +îÍÏ_¤¶b¾ÕÜÜ2W­#® ÿANóç/gq,Ñç–÷óWE]ö*ƒ!^nÝaQ¥lµáCÛ£Tµ(XlÒÆÐµûƒŒ¾\õIP¢-k5«|ºfËö˜lEmqŸžEb—kTY‡Ï‹tª³¸Ÿ¿…ÀÕ‰m 1™ÄgÓGU ´Žt:¨D?¸?ïkǽB2ôzêŽ1‡ú¶9‘ ’‡¾IÀK×CyH0c®²"YýóoˆLñ/îQ’·ûÕЗ¬}þæo)ûš‡ËZ £KŸÓ!TÜÐïÂ'3è¼Ñf¨âÏ(¨J²|ÓL•òŸ­ ‚kªY°ß!·:ÿ„r6åù¢)!ˆTá¥×<߇ÞÙùËø½6jw——ß®¸6îC“ÈÈõ2 u8ãm[ Djý¥Zôœ‹ú6Õ‚ódƒM÷Å–=Çé¹Â²OσaÓ LS½ÿË—–,H¢Y^ô6:€ÉÔ¡ÃÙì»ÿaM päm´¬~Êà¼hÔLj/=^šìÙ3€ÚZávoR,¨Ì ø’¯„&¦ñŒÆFîg/S¡Œ9º‘‹ÂÐIR§b1ý1(g„¼Ò: ÎÑäR“¹ªã¶ hQPž™)@ªfq}ªÿŠóº3õ((í~­å-à H›4;ìÆ˜ ý7ó?;ŠÊåâ!Ž¡ó/ñt! Pâ %A Y'ƒ=p‚à)rèSÉ"§(" <: ÿ¶ã¬DHsÂ&m^:¾£/®ù]šƒâX´r=ï“iËcç^ê±q9<ùòÃð¤`ò‡ÀdU<µqyŸmwZÜö4“Ÿ|Û &*Ïr¦Ò¢®T¸‰Á2¨á<ÑKíÒ–ly.©ÕjiÓæ Ëu:S•ÓÒ$bÕh»„¡Ìj±Æù.‰+›+R%ȤiŽˆVi=)Ø´xa‹§ú&áÌ•x[Ê-þ÷•‚4ùÛy» $&N+“7Ê®P4Ãá>…ÁW¿/±ÿÕŒ÷n]ThžÏk¹˜ªOîì:BÆ” 5Z"þýÒóÖ¢ï’.âÏcëäÙpõM‚Ø㽕ýdˆˆôÀ*¢Æ‘ p­>×#4[éÁÜ$d?ÀÁ@Ðä+ÎÙâ?Í%ê%!—~V÷Dÿ= 0SDko‰\¸X/í¤T,Ã/CçU“ùcÚT S¢i%¾ÀŸ¬$ÍÿÐa×WæäÁŸÒóÌÉ;‹dQLv*?·Kp‰œBOð½qÒèÌK`6µ{Ÿ zŒR–[·£¨úÐÑ»#kð_({8,„IQ Û©¾Ñ°¿š„SÜ#x¼¤n"T1›³{¢ œKÅ?ßmNÞŠ"ós}œ)mhajÛkk0~tFE.‡&C ¶ì#Þïñ'ïëçbÄâ2þÑÛ{º•ŠÏCKgä)\Lò>ùèÔûŽÿŒ¶{¸sËõÏA”ßT‘,+cÂd]]ËPqmGNÒ\«‘wòa–èÊÜör #¡”:¬{{|t¿¡)@ ÉïoŸ;Hú§E”K[}yw{¾¨`6­†ulv ;Dн’OÁ3¥¢Biì}VJXJ¾dïtû+ò.{ûï?…OL…O¶ÑeUƒ¬èïË U{KÝÕr–̦ÆRsÙÛþìñ(ïšC¯îšþ9)À‡( Pñ¥—¥-šM2¡£ñµfC[ðN j$mÓM둽¦E‹Sv+ –†N­Æ`Ãñ]Ûn{èB¯È‘…Z‡k7Ы«VL(VÁköÉøuÈ$ÕEú®~l'Œvªe:»ÉvÒ¼0ÕpUø©:ÞHx«ÐÓ7á_‹mJ¯‰œ'>³Ò) ž¹<½óÛ‚ƃ„°Ú/ê¡•‰/ñæ˜ò”Y»ìªðïxÀ˪Üs¤ŽÉÇwÈÈo.xà.ß±”®„^ˆ,ˆ}>¼uQñ:Ô ꢩöl™v•ýw*äŒrߣ˜A¹9 ZnK„ÉÊ~håu™mÙ=Ö|…¹›¯f¿"ŸE'H±gGÅ3UžÞõN-I±~Ú$úáBäƒö>bˆ$Ÿ‹ÝÀ°ù´8]_;ñÅÛ€K`ÊSÃÛ ž|°cÆÒõ$%êMÐPt;‚l&Cº“@=,+´Î,L*e¸÷9|6 Ÿút\œk!Ìk£3”—a^­Ž•Snšù’d"EH¬]nЉFÊz‘AQÖ´FÈXHÜÜÉpO9­Š•´åûþæÑûÊÌ…G/’Ë_&‡Ú£ƒE‹Š¬…Hs´=¨M…ýHç?2ˆ¾f ¥˜¦’ô_örh{¼Ï¨õzȶ6p³{±^îJWü Y×ߨò…±gŠOz§È*H)z”Žjÿ_U ¸-–ö™!”„:üª{Ñè"rCÁ¹É¶qwŒr#NÜ2_„5aŒúŸj–ÙÈÍIkò‡¾’ACïsSèIZkMãäᦷ„„}ù\upå×õÚ1^ýŽÎçþ§=Q¢l.ô1¸ãÏŸÜ%gzß3DwDc'fTÉï;LUOê­YÐ ĉWu½ŒPt2/êßÓ0ÌÒÐþßL07N¶ß{ŒÝnÀº¬ì*æ²¥QZÐaI=ª†dƥˬÿÞ®0 CD)ÄÆ…(™e~S•†Üý™hX˜}á…¿¿))‹"XnAû¦@ ¾rüe0Fë.‰D+ª¢ŤTØýód ýÝ9Ûë)¦p#ïøÅÄ¿a÷m†ú—N»é…]‹,6Œ÷w¾ŽE§1î«1 ¹.5&Ö3÷Æ2ÅÜ1M,›œÿ„fM­ïþúí󓟀ж†#‡þ¹H°§¢è k&U”1JÌ£ù+p(lÓïÆðÑ<%oŸhô‹VO_˜ú9٪ш«3ÇÀNÁ‰Hê5‰A„^ÆìiëqTí.'†ó¦ÍÓgz@ØÂo® ÉëæïY•8¸ï3uÿ³4¾·35h¾nó"Ñz5CÞáîeœ¾âÞÈÊÏnÕup\þ+»ïâfçá•×ßkV…Ú ÿ,gÎsIn?š­T¡’‰¦8XÕôíì 5ñvŠòÆ«á+"|@®;;©° VYÔs´xjü:¢Û íÈZ¿Téïñ+àî&Ô?ʪF²/i»„ôûzê+ñƒµ-)/ùnÚ•2î÷·S‘qWr~—b#$"tp÷ Þ¿µ#5\|n͸˜Û‚å©#‰1{8CO`àê@ê¡H—y‰oëuÇûP úªÅ ¬°áùâ"ŽkÚæ%жùPè1Œ$Ñužç]Ÿ†ùßãÑßÅWq.yàf¯“K ûx^Ü«ËÈ2T è¦!®ù¬Òââö^ÅH&#CÜÖ *yù’E*.Ë ›ëhx÷¾Ä ˆ&‰e$²È¨Øtùæc{ÊÛ/âC-ŸÔí-±ÏóÁëy Ÿ*oRDÊ-i^Ë"ÅcË¥üŒ ѽ8ÖöR˜XÆYÂqµÉâÆn8jÄrñϹÙ£3tŸØ_éÂ_̓Ee:ìBX Õú:p×{­xZàÈCèF!¸Ò"¾ùIpðú¹G·Â¡¨]üDúL÷^ÞWBªŠûG9ÖUÔvîçÝPÂŽÀŒë´_ÕÛG_gïhÑšI‰Ý@îO7ÇBÙG+±)tåâeÏ,”¡›:ÚÕ¶Ãóp;á5ÔÄZ8ÏR½ý=£·Ä¥Õ´ÌðíŠu?'p«ººôÙ.¯9FÑ HîþÔFÒ2ø££rqBÞ³Qî/ÅŽë„P "Æôœžðn':y¦˜qnf¶\Üe—]î#-³Kßl$Ö®gW”Pò†dã©777Û@/s«–-Ïþ2v '¼îë±ÌêÎôÛ$GNŠË¤Ž&„GJž»jœVˆ0ŒÒßE'ÿ±*Ÿw¿šÎú†KnÝæ˜ÎÝïlŠŸ?ü{ϦQ«éPg“m¢¢,| ’á&A„º‹˜‘ê("gàÒ–'´wä÷Ëdopç—ÊzÚØ5–*Í Çv‰´­|CàqUE_Î ^q|)êhéi:ô„à|—abŸ’nt-¦Y³:±+€bà&bØ0Šêcg'½ÎÐ- ûS§ƒ…O ¸X˜ñê ‘DŠl$¶Xpôcú,á$ÙÄ'¯IYº‚ÙkÑîlu Æ1Ó¦;êmQŒiüq¼wmñ˜“ÓCf­q±ƒp<åºéšì}ÊÙ™–Ÿö1w)ó“eÊÅ`ž/NÓ›‹ýø–C¦¢O%ýr,5§¨ŽFO£;È<ðÆIÕOJfæ!>(i¹ŒöáÛßÐ…l¦›M^*ã}]Ù·Žÿ¥‰…î-}{ÁÍ••U\Â"7(T{ç=.‘¹¹‚áÞ`°*pÒÏÇ/w—?äª# s¾™ m¯ÑkíT¥œ•vDoαT^H7\¨Då°€Fx3†ÐV8  ÈA2ötá©åôÈh8"$Àíl÷ăF`¯Ý©+o²…Wÿ Ï,ÍÌ““óÇ4å;¢:jÖúR¦Ëe•̨) òL,(‹í¨Ü'.Xjt1`oqÂiï™ rœˆW2†È(p4m!‰ø¢ç¡ì(œo_Œ 5‘¼_®`¤ ‡‹») ÷>ÀçHêÊ!®|hª ,A¦cy˜—o©b5èmåÛ¸ô6L2U3>¡”z$ÎCÊ/é(çôõ*­”NQÖpŠ,-_p„˜–k0dò¿æ”fÈOÙ+y)ŒDUìÊ‚¯„Ú>}S#ñ¸{*¤x{nÐd[ qx(ískJÔÒºö…‘3øïv¾@3/ð n Ž]¡Ê—à¶¥¿ZŽOmQ5A¹Uï¾ùì—ŒZZÿ€ëË¥`¤5n¬õ îx/’lûâ8­ghŠˆVZë•ßtV”ºNª-ËŠ¼Uð™:²­,Â!b„ŠÍqÂøs@È1ÏppSã)ð'¹I<9êÎøˆ½–hYTèus™ù£êš5‚`Š©!Þ87íudë—Þ\73.›Äÿ×ÚÖ¥Ýþc‡g_j릯Véà½ÕÀV]Ây/Þ}¢#2Hä„…dbʧ0º¨ûb¦@Œ„~!9£aª—m„} –¾Ÿ9Я‘ ‚ÖßÕs­ÚsCß ªóÞ™ ;œmŠ õäZ®®);ÎD`ʧóÈÈþL=åϧ9Zžß“t¥Ü'cÃV[J.h˜`ã&äAíF¸Ì­=ƵŽ76 )ÕÈR`óïµ²¨ƒÈséy´ñ}È_‚/} kó¡—äÔº]qö}çŸ+»¿IϪ'¿òɘ¡Á`òŒg_Æ &{••ª)ÜFdBI¤êé”®ró˜ òý´Ç8¹Q¯zŸÔÄ¿B@%mÈHSN¡`Èœ  øw[{,1N¶áøYûöd倷“ƒ÷Ê”°PYoZæWìMÛʆÕÃVÛêw’׋`¿¹œðÕh¾ÐÄnªgˆ‘ˆ !F¸8*Ÿ –§  …ø=Z€Û¿%ÚÀmÕÀƒaj`É€e4Dà Šp9N~òÅÍ7×í q%²ÿÑ¡¸T¯c¼Ån%’ù×ë¹3¾p.çßúzæŽIxN—ÝØñð–5Uô—t³;•Ê,Õõs·®ÌÈ8¬¸O•ŸïÎÄÒ;L=§ÐbΆ…dsÌ”«Á£ãÑ{{ÙÂøhšÃ´g9fž.6Y°ÊÚöªCéXN™£?0'‚’UÏ+fˆ¬VEh¨NuÈkY8ô^L¸!üµÁ–æÓtñA­aø^ʉÞïÇ’¬îJ¥Q¯¨m—Ûª3½Sú5gdO¾‘Á«˜ŒHãʾ­ºÇôÀ}– C±ð@"Àìðó$ È"db]+ÖûF¥#úËúË—¸óâ ý;pÅ—(’ÏeQK°ûU¸éß°Îɶƒ¤pEJö=…óE®·*ºqz†R‹!3nÂ÷Ixtm¤œP¿ö{úd–#ÊÃ’‚6ô “×àßSì§Ë|é\UoÞÝ¿-Ž¥ Ÿ)²¬MÍ&oÿdf¶ÐV5æR„›† 5ÙP É)“ O&é-½ÔŒAK‹5pö0ŠýÒè!þ¨td€÷í»QFćü· õKFZ'n¾YÛЫÓ>·+€gsGp‹>áß7¬çþ÷ÑÝ/š-U å’09r\€UåC…÷©¿!œÐ!ì ú„2×Ï·›’S¹žÀ˜i({e:ÖTú¾è߯KÄæi2^§'ÏÌv°·ÞŠJoáJí)„ײJø½NzzmäéTµCéÌž†‘Ù!E(UŽ'‘ó7ùµï]}äÑø02”ᤘˆR»Z9t0k\ˆ>¬õ뜻3³½R!¼!ä¦$V2©9©ìvæåCYG°e8ñ†!ð|=‚G6¶ÏÅ÷s~Ö°MOŒÞ)מ¿¯I12%7ÔN ÉŒ?7Ž8^@b¬ß“Åqî%¬cÐUiþ~à!²÷²(Ö ï·KßòÅ’ ëÞÞ´ù—ïëŸúÕÞ;ÈíÀlok‘!ÚJ £Yõ¸Vëy •Ó‰ink; ŠŽw€#$r§–KàY#Øt Pbù°çŹ>kK²ŸLuÓ¹>&„ã|&¿Fù©@™ì…n±Z$T4W¥±Ð½aÓP Àù¬CÈ`Ôm§öjíÑŽ"gÁH>Ö\¹Rj+–ñTWƒ_!à™9TW·¬JT¬rÊ ,)ä Ïó:¼±6üLÆ4ŒîÜ ”&ñ{ ö!}1v<ÅCó3·¿ßºå•©ZzÔ÷ÏhçT;~ða-EÞñà7x-Ö‹z™€4¡Ä.ì‚rßõu“¦3U‡xÈÉ´V»Å×[´Âì9?X…Á½]nÆß(„ õ}Ή Ï z^+Y⤹÷Ý-ý¼ˆ¤fH™ÙGy-¡Râ°Ë"ueu‡üI9^üôzÀDS3víd—áf³[š `gÊü|#z5X´Eå‚N ª¼ÚZ\”#Kt|.ž¬Õá»;Ç.,3˜äÛ9ñƒ£§³ÈÕ½›WòÎ÷Ùjæaþ¸c‡:@±œõ1T£ý§4u«Á€Éi@ª1ê°?-©ï)ñ½Ôš ï!eî=q®“óM)´&HÔhxv÷B'KgÂ(˜Æ¸F0gŠü’¯úTá3·k„Ó¹ ”ù†ï¹Hád3QĬê§þrù' 1¥¯ÉØBý’ÔÓïóeùMù)È=°)³ŒÓ¯+s3ÿ¤{k3ibx|Ÿ@£9b´^ÔÒ$‚×ðóyHÇÀ¦/.*É3¡’CÏ•RRl¹Ès‘£ ô‰toü``LaQŽ6ð ÈR nýÖ©ôœ¿d½ñ1Ñ›ùWŸdRDüåaS”µ:˜= ýTÏ`Ó4«k ô.V„ÞÕ®æhE\ŸÖWÞÒGúÏ( çbc-ü?Fº’4)\n-‡pÖÎÔÌÊ,`EPÙÛâôÿd¯·þˆÌQ ¤ùìjÎN@Êàúë/â'£=ÀE²e³]=%«u³ZîóÒá4[C† Ôñû4›à¿Gü“Žüö@ès©ßŽòg¿gJuäLò¦¦¼–#ûì³; Z×øù‡ ã‡]’ÓJ½T [Êû$2ãBä$=M`ô9·ZÝÍ(܃ьs̪uýå‹Wûæ7ôöxÏ ÅlT¦–ÿÅœˆÎßg:Ñr˱Ÿ5wVë û'¬ª¾÷>2-÷þ Km4ìÖU€i“ž˜-_oÖl¼ÑÅY†v£`Ñ­ÊH‡eDn훥Äɼ&Ænaõø>ç¦t­?U~œÌögñA$ê1ÓcEKH7Îpy壿{1ÝNɰÒbï5žÌ(%â½Í.ß&̰Ž/¿‘»<úpƒn¼‹ÿ>èK…¤*óXÌ·-I-•„-õ†©õÂ_Vpd<7†Ã¸µðl+,=Fì*_Q(‰cÀ;œê“5ø:!"ªíŒM6©O³æ˜!ä×'üA³ÛµR7›/ ?X`;µêÚçÑO>Ô^¥£î¡zõ4âo »r%º”0»L/ ˆET%\ý,h`ž®4+QÉÌ(ÈôÔ'ÜêÊÓ\ކ\Ä»ýTîϪ]éJ Ì­hÑ€4>ð§iQ…QÜÍñ-…=ñ4ðÁªø0«ï4xŒ}'j©Ey;혿夯*Ê2\}®Þ!ç{qHëhm½ÌÿPäüŒÍý!eÄH€ðu_:%ók›3 V¦w©ÃÔ¯la9Ì+A×Fs Í»ìôÔð¤A×›ä¤hjƒ³á¾N.D¹¨ÎÓ=º:¬÷Óyo? ¶\ ŒƒÚ‡Ys5h¦²¶æ?°íØ”JÜãDõD×§þã p±f áN7lûM±e ©kä(–\O´¦j7 ªFÜV{¥ŠÝ‰Y!õ{]úk]ðþâœ8¤$h1å Èp¢ Yá%™ÙÃu­ƒ¼neúÅ6QA)ö&LÕ£-<Ëgùi՞°9VPG¦SM…ËÍBiÒÔ1ÄÛ{ë8}ANä¾¾ýë•ô{²¿«ø§Õ/üȪ2¾@XjÖrN¤e΀5bê{BFÜSVš rÍ+楢´yúƒ7Gç¾%t²¦£sGNFÿ+þÿÓF³ïuySéÚËŠ«Éô@«3øÛÇ/œ MÍÙ- þK‡«WaÏbaXºoºù÷yOØ-.‘ÓÄúaCCÙks#¤Ýµ'ò$±dŒ!Tó…‘Ú燢yýx÷»§Óƒ¤ç-6™:8•×Þr#™y=?˜åÚúÃرÖãYɨ+ŽÐÅGÈÕ–5Z@k¦V.(s<a¡Fyq}Jo´ø’ 2[jÓf·UR!8y:¡°™ Aä…ÅϳQ‡²iøãªùd‚ÛÀs5c„©kuœ‡ŽÐ¬£™ 2ÄÓdñã…9„¹ï,¾·ô7±€¹DRRWu*aC߈H¶ö¶7ÀÎp;´ÈO©þq£úª¿²‘ŽÍ…q‡Y¿œ ì¶`y˜o6%kêeL33ÉeöÌ8$€ ›&ÞSêjj Ù?úÆ™Ž\å/YUy·kÛÿ‹Baœ¥úBü¿I±TP院ÚQ÷UB+î%@Xµ‡ÉõS¬5a\ÑM–\Ej”p·hOCþ¬¬•-¢ÇUÉZ¾ TÑq ­VE>jí5}Bû蘇2ÿ¸ÁMÜ]“vk­tß㤃$=@²Žî@ÓZÈ‚9š§ya&’;7I¶ ÐR©‰,ÝÝÿ³%Ô ˜“Õ=Òz8Ó¥/ ¾¾ãqÚE`J{›¡ƒ(ï„_ŸÐñ“Π°ï!qÌ‹ô…§ 8Êïj}sÛ67¸¡’ÍáÞ À–vÒ½¸°È%iæ2ÿkçc·ÏH¸m{ŠŸ›á!fð íÇ*1@×óM{(˜TïFW]©ZgAFC—ò}š$;z) 0P›òðP¢ÊmQj@Ò+å~$Q’ZØ`„!ù'€VZy®»¼„®xvíôv‘¤_ ‰Üä²YÕò˜IøÇ?óëÇΟÊùWñØ™ÿö3í—½ÙW5øø”êžG€;ÀéªVîa ýÏÅC{5zp‰SÕPÜ»qnÐÊLk=å”w&¨ø";7”Ê.îŽÀ%wsî#éd­£ªœjè.L7“ çŸïTÇAªP‡éÀÎ!y%nQñÉïë@ Û^ÒÊSòÿº 6>7dv8é.8¿‚Cy ÎEÁ®²«”Ã!°c$¬î¹–PöHm›ñT›°9¥3ÝîtcúY–“Â\Äö¤£¨Šc¹O YH /Á™w&¥ÁíhØ#aˆ"ÁXúeÌ îÓî_^ðžÀ¤øêj™×ý6ÈyÄÅVh£²É:’0ÂZÌŸ9Ú3=p‰ù«‹%TiaeR²gÙ8FÛ­´q#Ÿž^;ÁÜùÖôÛ$œgazd„‰qc‰VOÈh ˆv›†x§€$•mn©He#2Ñ3 ÇÄJ°€'Žþåš×Ž3&øBÔçCŽšîC_'ÐZ †rO‚8 OUØäl›Ø„‘ª…c¾y¾ŽIû¢{£7!“?éQذçSòBK!õ·ƒBžï»ÐáH|ö¼v‹NPpCU&1¤0É37ar1ªiV‡ÓŒC‰rÆ|z9®ŠµÌ“ø¥ƒ}“;]°ao¹ÎåÌ@LC‘q6j‡)heô}›ºHþ ÉlZ´."Ó{"BœaäøZqæáw§í Â|Ø3¦âF i¬"”³Ë8ö'ƒæn™Ü"ѵß1@¤¥jððG}–…;„ÏñÔJðÌ[2~ùŠc߼뵦¢ø “I`·¤ÜJÐ1!¤Žæ¡dn(Z4ÚÈ~mŽBµ2s°ú#–vœhv¥µ|=ÿˆ ­G,ŸK‹¢a=ßîö~TåsGW•¡4Å ÑZ„¢”Õñ+s§NñÎÔ0­Á°@í<ð¹vpž V–Œhä|‰ë0™|_†z;XØ ;0¥Fžr½í7ÞðFp—*Nv³Á×Ѭä5—-Ê #„F…m¬j<–ù¸Î—„½ïÉ/ÔUµÖÜMcž…zxH!B¹Œ³l½ÉŠS’·qËÉ1Ú= ‡|ø(γ*jI“’)€Q”•.nWC¢ÕrDªWÌüxû¸]´¿(¯¾Cpñ§eŸ›™õ€Ñ"lˆA½¤boëk:µðN?ýž?¤æG£>ɰ(AÞvò"©Zíz5ÿ–×T¬®³ Hf5–…~¨+ÿ³u—Ö•‹ëéÑTPYäv[Læ/àfžÂʽŠà H\jZð|º¯†Ø ’ä›~=üÔ@w]› *L`fiu2>wFzTwy…îöÕ[ÛwS+Ã6ÊPªïýÔ:–‚÷ ÕÝLD’ÃqEà³­³wðQËIgO¦0eÞ`©æ+Ôj¾±îaaæ9'‚÷éð"_•ìR e`Rv£Ê¸îœÃ“i_¦-eUÖ'óŽR>q tüȲ 82é’ƒ~d.PDx"Ú0™µˆøêt7Øy<×È&ýi›óý‚»VƒýrÜ®ì¹Ô†bp˜µyÂ8ã usÍô01?w'×’]±³Ì@ö˜žV¦íN¸û¦å×Þ½÷7öà<÷¨V4Kõc“{ü«¬ ‰nƒ'`tEêt(™FöË“ÅÁi²ØdbŬºWÿƒý$|ñ\©}(xf)OÈ•aAp8­;†È•l1õ÷!Ö÷z£!\t±q ‹l¹3Š?,sc+‹F¢é•l»ZZ@öS®-ÛgV h~Í C˜¯š¢]Ü‘³þÝš±×ÛßîÉ3Ù@ŒèRæ·®uÈ ¶%ÖOQÌ` _›µw¢‚ô78a¾·–.‘y5äÀÖè˜}Àl•t~T€to:üò¿\'®»ÍQç s»û'‘~¿™g»Ãªþðoçß©Eˆ`“CRAsbØuÒVõñaÝwÜÜ“ Øø³sÞ¶3Ô¬oqÓÃÄ'ˆ âwn×FÈ'ô›uc'\¥¢äØqÓmŠRà©66™oSWð)jø×¬ÎˆpfÓ¿Äëô†Ã-‚©j|6 wE`V¼€BX¤`ÿ½¸ñ¦}Í¡\Ü êÙãhw„‡Üv‹ÚÈô$é豯êÂ@êÒh…v“¤×Ù× 9üŽïDíF³i÷eá[Bá*…@ ߯Žègõî]lü vþÿÛ†ûŠ¥Þ±Ä…{[ðâX¤ßýÄpZ8žµ0Þ»9ú ]ŽiHu³‘EðJùõoT8HñÇ5öÓͶZý1 +zYÙkC¼ ›`ä_*F‚NR¾ôDùGÿÐÝ]ÓSïrñ5ŸÜh0E÷›­bXC¨5çh:§sH—;rárØÖEoõ¸[Ôr!§Œ¦ «Ê.W±4'³™ýÂù'öºœØ'¹|T\rÿsW«tmûÚ’µ¬Ë„SCe"›ñûtfà‚œoµÜ.þ;WÁ-")üd@½u}jî É”í’˵1AqIIÔ¿…ì \æ¾wúÛZôìÒhßÒάiÄZŽÃ4ŠòܱTâNxµk¾ôëh+Ϻö¶ìiÕ`i·ù"ú ÿ„eZ—lŸ#¹Z©d9¹ÃÑ Ï˜5a²¶¾ác³Ý6¶¤‘eP:ßýmg (|Ü(œ&–™Ìû¹±°PÚ¡¶ÆI¥@C :üŽ;Âi!­žm^FdoùÙêr„€vøë†,[§Á³¾ªõ²]ªF©MÊ»[qÁÍ…X´¡.˘n‡Ìu°8›ÃIÓÏE»©Ø@ç÷™³å³Ž,e‹>Ù­ÖÕ…,û p¶¼@â˜o%¬5ÛKþµ,KÀò’v„4_Y(GbêQÊ ç[UÕÇ9}ØÌ¤¢%ù%s%/s+€H_œ4c" gì>>hz3ú/ê45«a¾„Y‹‹Ml‡O) ÓŠPz@H QvxI˜ &þq÷c\7‹»b+¥3Ã÷‚{¨¡û3ß„¹@ֻͻ6+ŸâÑJ@lv;àÉ;yË:°Q ¦ÞšÊ€ÂU³—ó®nzí¢~±Ñ âô??–ZÚ6Î vâî9xæKvøG?ØÀb¶7NÿŒÉ‰dÒÄXËbÉ´½q؉. ÒÍö²$ÙÇÍ ä-nÎË3~ÿ9býº“L?u ŒšGõò¨L©3Ý^˜NÏA¥ l ¼¼d-s¢’¯¬îSäÚy Ê,&jÈ«´Ä˜k*z`Bö•·Ú.! Q 1ïaÏ(© E×äíÿesã¤ë[g:̻҃HA,ÎÆË|U•ËÜ |œÚÖ´“G¶â¶}ÇÙª×LŸLòÈ{ PÐÆÊÍ#õßTí©ŠÐ»¦ÍßHWÃù©OäHÓãx#ÉÖ0Ž&³|à ÓÞ² -ŠŸèˆv,‘AÌS¼^|x ™ŸíO„ÌpkR%Öå~ênñŽ(ñá!™KU‘/=Ü^âÓPß8\ĬÊ]O¬¦Lþ Ê (ÂðQùð{%5›í=T¯k!ôÅíˆ@éÏ?"!úc#Ñv ±¬þµú'Z"0 ÕF»põq,ê€yU_ûèB¯¡ž|Ù¤-)‰û<Ôcqr|®¤w´Ä‹îã‚èŽøËBþ ìãJ—õÀ™Ü$7Gp ZH_‚ã¹} àÿè–€òÿå'Úô¬ ñ»¤0²“pº¢µlÄóså¡çˆi_yaÓŒè3T7¢ÝÈ@ä`†ŠÁ¾¯Ã‚ˆÈžÇ:Lªôœ¬JX8áÖ¦vÆGÿ·ÛÃ…XƒLX‹.ò8Ìì!Úö]¬‹rC%@cºTc v³Tæ•9Ì'\—£Yt—n™»>F‡Jg^žE7rÙpI²¨Æ‡×*fÓÓ:Ú¾eݲ;Y6uͬä妴ô²q½©Œ}H€áCÓ¿ºì«òèê k)ÖÞßKŽõû  ©ã³mc-ýµu©0ÚÛ7ÔK??­d/!‹¢]ËYUTú ¾’D;òx—ž5ùG¥¡.SxÂZᢇ?l.€ý[í©Ô"1"¿gd*ÙNÜöøÅØ6a½í»w²¾w=‘©C à螔Ѽªí½±d¦ Ñ'b³”–mtït=×3$nH©ùk^?–¬Ð]œGŠ”Ó{š±9c(5!éõé^ÈÿQj>UFÞæ/; ¼ÄàýI ” AUçÆ$€D`Ðêã<žÆ&Y1 ­uÃ…Ôï$¼5£ƒ²Å†fK Ї½é1Ü;~…æÙ&v; fœR ¿ƒè"ev ’Z‹¤L°˜Ø ¢Úl*×s¯.CíXœz‚??DP—Lg»â*hýMs ]z4±w¦oY2C…´ï«Ù2¹Wïûõ=cŽ ‚¯|mÜ@èæFÈ× îâ¿!få8u¹ÇÏÖ4öÒö]ì­/««K¾s>' Ž›%˜÷¾˜b"ðwÜÑ}¯j¨YÅ“­D;Š˜…ÕŽ«ƒÉ5^Áͬ$´ÎÕº™³ÄØÅ·›7é,ŠŽ$W…Wf:8Poð ±åæuª¼7*]¹½eE£" «GرÌA┾ŒŸš])U#O¿c“a&>–G·Äz¥¦ÓdÓgÏ¡÷Ç¢øw¼U’ЬИ…·Å•çÖln(ŽÝ–žý„jÈ€ZÅlbiÄNCIž¯(êÀÏ‚3ÚŸ2>~í\XÆ–Ì~‘l 4–n¤A–Á ãì kË‹.ãþÂiNØB沩‰éR—qOs.QÒR+(KvÀ’o!Ùñ!ÚÓ"ЀĆ9j@تÈ, BìÚtC?{Cž¹Ù1ù-ÜWÖÿd²Äãìëtíþøà1ô]ºBo#L®³tèZüZêÍr’ ½à ‡DÙÁ™r¶¨Õ4ç0ȼóW_¿‰2w}â´`£@ÎBb¹™ó7´ 9kÉJ«“ zG?™!“»$ݼSÅN?娳8kä&Ý5£ =Ž*—1,AÈ^ÁmÓ{v*7–ù~2Nœ! Ovþü[â¬Qô;3xk²#›ôXß°âËU^+aJiP0›þßI3¡ž¾ÄN?,—QgžÒ@Ê·pçÕ[Së¢SÚTæ«ü%Ù†‰’ºvVfP] àd&6q˜Ãj–ýª'lªáª8LÅ›ÇÔûUǹ…{ГÛZ]Eî•rçŠ%söx†ûœÍyB,²„«9$åy¬ŸúšØlß\X B‰Ä`xP[02T6ìq2‡*'n²ƒFÕ^¶Õ«ÛÀËßaí¥é¯x0Š ë¤0]òbˆ¼ùq‘feg&y@Öq—*â OHÀçô– Úc^)++ĵ©ˆòe?MnmN"퉂²V @ÌŠ8c‡ÿxTc6(1!H;Çák”¦al’T,SþhÓÈRÌß";HÛ¨z´~¦ª%5Jº}TÌZÝ’>¦Uì©6¹£ ³ž¬ü6îd›ÌòÏëI³} Lñ´ƒŒŽTéø€D…S íÌÜŒÄ3œú%B`Sq½ˆ+æÎ¹¼ˆFþû¼O[ ZÜœryg8—¥ê(óÙùÊXHŸLgáÝEù[¤«Vrdf]F‘ˆI(¨ÏÒñk“ÓçÀþ¹?øÈcLR-‘ºªþÕÙŠ.fÒàØ#ªÝV߯1è“j¤ÚY8y×/61߯FS‰Sâoƒú+Wìz{:™g·Md‚„|ØtK =¦>ê³ËVãDÜÛ@mƒ i¦ÚÙ¼é 1ö]Á˜Ù`ÂH™G•ÔŽóä_¬ ÉHZÌäøjÖMŠ·Útˆ_r)jèäv¼§¨Ÿ›’z.íÞ€ðxÜÇñ c\FÞäƒM¼)ðŒ¯G9˜¯×¸#ܾ'Ú–ÉÂ>Ö}›ÉX›ÿ[`Ìö¤V]BÈ7ö7~"óH"úd+QLKw#0=À ‚5ÃuÚˆVlIðI!5ŸTï RKÿ¯µPµ0=n<Ô‚Ž­³®ËW‹Ò:ÚÛÂHËé/ìÏW¸‘jMnÖ ÝßxÉ£!ðÜe÷½wÝ^S3ä³hds_}ù9ð¤Ùøû^QÛ}4ïH—Ù…,`…@?²8¤-+|Æ~®pÑë†Þ6)%Ž Lå©Nù\ݱQ2 Ãö¶†¤à’ hÎ5ê?†‚K±°4õ •VHëù%!³k|­z>­^HÁuµ?ÙñÕà†¦Í÷n¼¬u0€ë±z]ûvïTe2ùm—úv‡O¼›ûçÌ(R¿²ý؉·êdûLÀ÷.õ©ÙG ø|qPwPªóp—©gƇ†¿D|œ…ÀP/Éð/³zr¼{rx-íéfú°"Y'•#`9ÎÈ eí3˜´ª LÆuJ¨ç-RËÙVñh´¹ >|L£Êø¬±âÀ²˜êO¦ô©´ÚCæå!*Ÿ¦hàKç€å\ã`2ÿU@ tþep˜ìŠûÁ ¸s>Qƒ§ìaÌ¿¡vôE#@¥/æ5•úNדN­¬¤{Ebß¼“§‡ ˆù^¤…9# LøôÍ”ÎÊàR[€yçÔ¦Oå²#*n)‡üÞÞFêÉt5®)¥ÛÌùóTÇC®· pqŸœ2žé»{ý;¤$[ÿ·=“B]V¿Øä4C#9žÂ9szWÒsxT—úE®HÏß5 u~ú4ò„V%r'¢$²f'Û³÷ƒÅ|†LC~RI·åNâ*fT=‘Ÿb1hÉ»¦ya‚`ìwùú’~¹úþüªÐdtæ¦| .gMK …xo|¥Št€+ÅVo§¨Ey¥80n»@ð·5…‹‚j¤Ÿ]èÑAyÕÛ]ª¾œ l5°´” £»?·–·Œ¦‚†"L¬‚òh1«àºïó˜ Ž †(½cl)Ë}Þuœ.ƪïLF˜\™›‘VmÈðø.úK$ Æ/‡5 õ{}-ý2Ã*eVÒáàXÝ&ð2ÐAüË'‡ºñVÃP$Fï¶ãñÞ@÷«ˆ*› ’6¼”¯  K%ïÜã(ð¦rLÍVFõé*¥£_\„0µz¥ÜžÚÎ¥ƒ­G»$zÀ…%tØÃå–|í¥Cò¬'Æ(¸ï²r` ?÷r?, ÎýàñRV`€e¤ÿ­õä­šsXðê]³ƒ¸ŸÅõæ 7E}aZ•¡¹ØïеXYåXþñ)(mŠ€Ùìñ‹[TjÞ.èjuðöJhv=:‚JØd­—êîå»oÊC@X_ÓøL‹ÅAGái·ÞOäÄ¿LõкX[ðçqóY¸[³ÌPJNÚ¤_«ŽG;Òžý/­L$e©ºO»`ÉÐ'Æ8俱F;?Þ‘P¬|F[TYX0Ú™KàbZ EäP’@‡4¨z­ˆLùKèÿy¸žcèÃ]bu¼&°ìŸr#ï(?¢TøZ+¾s–ì‡ûÐ’y$ÿÖä¨i–ΔDj´îo8+]ÉRy¯N=÷¬AUì®RElܰ§ó ‹Ó%Õ1Wj.]šÑýª)nÔYsÅòøä=:½Â$íqÐw™žVÌÿ›d™ ÝLÚÈ‹Áu3Ô0ís]½ž"´“H𮦇IÀu$ä†ðeâZºg£ú'(`8 &4‰Ô÷ul9€†«“HËÄÙ„¯~§ÛpŸµd&‡íïWÚ/)Õ˜@7€–e•Ù5=W¸s*¶m–.Ë Õ·5û4Õ‹óómÌ]ºÖcEAq%®Ä,W¼»zh±[_ņ'ãKÖjŠÔË`n:à%z¦Q}Æs rùЮo¿BÊå ÃÄLæ„èvgqL™‰ã^`ÅH âÒvÖ/”¸ØîTË«).¸=¬Ñn‚L©TdÈÕ²j­ÞÌöˆý^¥¹& >i¹˜*¾£“¯²-ù±ßeü= ®ø‰%ˆÙ1ø®Ü>Y?”Áž)À‘oËZCoñÁhõS|VËì†T—Œ«M¾d´@RlFõòëm%è‹lC³ÏU>½¼ÈÑä?–¹{º®Lä³~¼KI:þÅQ¿§,t°¬QÑ“F×åqM&ž ÉáK;d÷ÖžŽxWòÞªH¡á~ãŒq/® Óü£ìN:û=†3=Àª‘¦mßZ{~µ±A½ï lcå","³J6 óÖ}%,‹m\´-ÈŒáÆW˘ˆk¢ÂÔ»ìºvb®wÉ?fçÓV‰‰˜;ßßÅÑZU“0–…¥ûV•Ÿá âíºH …?{®·¸bS$÷~,fÝòÝmùÑÁZ7L#Oíæ9v%.Â)ˆIÂÀÑãá´£}RUÍKYu=¨ ©wr8wt>[&zÏ^Wä~L$€Ï½ãün¢-~z¤bÛ…¥¹Ë¨\I—¶^/µ±Ñv®ªâÕÚYµûxÈ4,Âp2딽멗AúóDi¼–6Çl‹ s›ˆTÔ!ÈÛËýÓ`}` o1aƒVú)55+´³gwƯÚjïq`Iµ:kqç^gæ39ºÔáI¢­ÿ qÊZ.Õ¾£ehŠ[‰ÞÐ]ñ l]>⌼§¬ØÔ¦Ì·‹µ¶kØ3þ׫"~ÿg U–’¡T»„˜?;ÐG&…² ¤‹Ëo\}Vÿ äO€4ÿ®'G_6‡ìBÛÕ3%3}9òh±nÁÂüH íÝÔj„$iŠ N­ÝÈÆrÍfÍn˜ÔÛ‰F£rümüÎZ·-;/±\ÙåP—3˜ãÜ· d•ãÛö tóqû´Ô¹t 2É$š’t(¡~×yJØŽÁSeüíÉ.)‘Oñ>:W%õ6ºuÚÝ( ªøîʨH2µ÷ÄóW'¡XËÝì….Þ£÷ƒØØwf골µ€p¥o‰6rc=,æ¶æGk0)•00 ‹YZrelsurv/src/0000755000176200001440000000000014746172543012560 5ustar liggesusersrelsurv/src/netfastpinter.c0000644000176200001440000002054213551065110015575 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function (for PP method and Ederer II method) - sums over individuals at each time ** ** This version converted to .Call syntax for memory savings ** ** Input: ** ** ** efac[edim] 1=is a factor, 0=continuous (time based) (edim is the number of variables in population mortality tables, usually 3 (age,sex,year), efac tells if they change in time, usually 1,0,1 (age and year change, sex does not)) ** edims[edim] the dimension vector of the population mortality table; edim is its length (for example 111, 2, 40 : 111 ages, 2 sexes, 40 years) ** ecut[sum(edims)] the starting point (label) for each dimension, if factor variable, then NULL. ** for example, for age: 0.00, 365.24, 730.48, 1095.72, 1460.96 ... ** expect the actual population mortality table (values - hazards per day) ** ** subject data ** ** x[edim, n] where each subject indexes into the population mortality table at time 0, n= number of subjects: a matrix - one row per individual - his value of age, sex and year at time of diagnosis ** y[n] the time at risk (follow-up time) for each subject ** status[n] the status for each subject: 0 (censored) or 1 (death) ** ** Output ** ** dnisi: sum(dNi/Spi) at each follow-up time ** yisi: sum(Yi/Spi) at each follow-up time ** yidlisi: sum(YidLambdapi/Spi) at each follow-up time ** dnisisq: sum(dNi/Spi^2) at each follow-up time - needed for the variance ** yi: sum(Yi) at each follow-up time - number at risk at that time ** dni: sum(dNi) at each follow-up time - number of events at that time ** yidli: sum(YidLambdapi/Spi) at each follow-up time ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netfastpinter( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si, *sitt; double **ecut, *etemp; double hazard, hazspi; /*cum hazard over an interval, also weigthed hazard */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2,yidlisitt2,yidlisiw2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*yidlisitt,*yidlisiw; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yisitt = REAL(yisitt2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yidlisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yidlisitt = REAL(yidlisitt2); PROTECT(yidlisiw2 = allocVector(REALSXP, ntime)); /*add w*/ yidlisiw = REAL(yidlisiw2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk /* ** initialize */ for (k=0; k0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); hazspi+= et2* expect[indx]/(si[i]*exp(-hazard)); //add the integrated part if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include #include using namespace Rcpp; #ifdef RCPP_USE_GLOBAL_ROSTREAM Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // Yt List Yt(DataFrame data, NumericVector times); RcppExport SEXP _relsurv_Yt(SEXP dataSEXP, SEXP timesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< DataFrame >::type data(dataSEXP); Rcpp::traits::input_parameter< NumericVector >::type times(timesSEXP); rcpp_result_gen = Rcpp::wrap(Yt(data, times)); return rcpp_result_gen; END_RCPP } // dNt List dNt(DataFrame data, NumericVector times); RcppExport SEXP _relsurv_dNt(SEXP dataSEXP, SEXP timesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< DataFrame >::type data(dataSEXP); Rcpp::traits::input_parameter< NumericVector >::type times(timesSEXP); rcpp_result_gen = Rcpp::wrap(dNt(data, times)); return rcpp_result_gen; END_RCPP } // prepareX NumericMatrix prepareX(IntegerVector Yt, NumericMatrix xt); RcppExport SEXP _relsurv_prepareX(SEXP YtSEXP, SEXP xtSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< IntegerVector >::type Yt(YtSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type xt(xtSEXP); rcpp_result_gen = Rcpp::wrap(prepareX(Yt, xt)); return rcpp_result_gen; END_RCPP } // fitOLS arma::colvec fitOLS(arma::mat mX, arma::vec dNt, IntegerVector Yt); RcppExport SEXP _relsurv_fitOLS(SEXP mXSEXP, SEXP dNtSEXP, SEXP YtSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< arma::mat >::type mX(mXSEXP); Rcpp::traits::input_parameter< arma::vec >::type dNt(dNtSEXP); Rcpp::traits::input_parameter< IntegerVector >::type Yt(YtSEXP); rcpp_result_gen = Rcpp::wrap(fitOLS(mX, dNt, Yt)); return rcpp_result_gen; END_RCPP } // fitOLS2 List fitOLS2(arma::mat mX, arma::vec dNt, IntegerVector Yt); RcppExport SEXP _relsurv_fitOLS2(SEXP mXSEXP, SEXP dNtSEXP, SEXP YtSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< arma::mat >::type mX(mXSEXP); Rcpp::traits::input_parameter< arma::vec >::type dNt(dNtSEXP); Rcpp::traits::input_parameter< IntegerVector >::type Yt(YtSEXP); rcpp_result_gen = Rcpp::wrap(fitOLS2(mX, dNt, Yt)); return rcpp_result_gen; END_RCPP } // fitOLSconst List fitOLSconst(arma::mat mX, arma::mat mZ, arma::vec dNt, IntegerVector Yt); RcppExport SEXP _relsurv_fitOLSconst(SEXP mXSEXP, SEXP mZSEXP, SEXP dNtSEXP, SEXP YtSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< arma::mat >::type mX(mXSEXP); Rcpp::traits::input_parameter< arma::mat >::type mZ(mZSEXP); Rcpp::traits::input_parameter< arma::vec >::type dNt(dNtSEXP); Rcpp::traits::input_parameter< IntegerVector >::type Yt(YtSEXP); rcpp_result_gen = Rcpp::wrap(fitOLSconst(mX, mZ, dNt, Yt)); return rcpp_result_gen; END_RCPP } // rcpp_unlist NumericVector rcpp_unlist(List listObject); RcppExport SEXP _relsurv_rcpp_unlist(SEXP listObjectSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< List >::type listObject(listObjectSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_unlist(listObject)); return rcpp_result_gen; END_RCPP } // build_array3 NumericVector build_array3(NumericVector x, IntegerVector dimensions); RcppExport SEXP _relsurv_build_array3(SEXP xSEXP, SEXP dimensionsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< IntegerVector >::type dimensions(dimensionsSEXP); rcpp_result_gen = Rcpp::wrap(build_array3(x, dimensions)); return rcpp_result_gen; END_RCPP } RcppExport SEXP cmpfast(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); RcppExport SEXP expc(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); RcppExport SEXP netfastpinter(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); RcppExport SEXP netfastpinter2(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); RcppExport SEXP netwei(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); RcppExport SEXP netweiDM(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"_relsurv_Yt", (DL_FUNC) &_relsurv_Yt, 2}, {"_relsurv_dNt", (DL_FUNC) &_relsurv_dNt, 2}, {"_relsurv_prepareX", (DL_FUNC) &_relsurv_prepareX, 2}, {"_relsurv_fitOLS", (DL_FUNC) &_relsurv_fitOLS, 3}, {"_relsurv_fitOLS2", (DL_FUNC) &_relsurv_fitOLS2, 3}, {"_relsurv_fitOLSconst", (DL_FUNC) &_relsurv_fitOLSconst, 4}, {"_relsurv_rcpp_unlist", (DL_FUNC) &_relsurv_rcpp_unlist, 1}, {"_relsurv_build_array3", (DL_FUNC) &_relsurv_build_array3, 2}, {"cmpfast", (DL_FUNC) &cmpfast, 9}, {"expc", (DL_FUNC) &expc, 6}, {"netfastpinter", (DL_FUNC) &netfastpinter, 9}, {"netfastpinter2", (DL_FUNC) &netfastpinter2, 10}, {"netwei", (DL_FUNC) &netwei, 8}, {"netweiDM", (DL_FUNC) &netweiDM, 9}, {NULL, NULL, 0} }; RcppExport void R_init_relsurv(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } relsurv/src/netfastp.c0000644000176200001440000001614114162605335014543 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function (for PP method and Ederer II method) - sums over individuals at each time ** ** This version converted to .Call syntax for memory savings ** ** Input: ** ** ** efac[edim] 1=is a factor, 0=continuous (time based) (edim is the number of variables in population mortality tables, usually 3 (age,sex,year), efac tells if they change in time, usually 1,0,1 (age and year change, sex does not)) ** edims[edim] the dimension vector of the population mortality table; edim is its length (for example 111, 2, 40 : 111 ages, 2 sexes, 40 years) ** ecut[sum(edims)] the starting point (label) for each dimension, if factor variable, then NULL. ** for example, for age: 0.00, 365.24, 730.48, 1095.72, 1460.96 ... ** expect the actual population mortality table (values - hazards per day) ** ** subject data ** ** x[edim, n] where each subject indexes into the population mortality table at time 0, n= number of subjects: a matrix - one row per individual - his value of age, sex and year at time of diagnosis ** y[n] the time at risk (follow-up time) for each subject ** status[n] the status for each subject: 0 (censored) or 1 (death) ** ** Output ** ** dnisi: sum(dNi/Spi) at each follow-up time ** yisi: sum(Yi/Spi) at each follow-up time ** yidlisi: sum(YidLambdapi/Spi) at each follow-up time ** dnisisq: sum(dNi/Spi^2) at each follow-up time - needed for the variance ** yi: sum(Yi) at each follow-up time - number at risk at that time ** dni: sum(dNi) at each follow-up time - number of events at that time ** yidli: sum(YidLambdapi/Spi) at each follow-up time ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netfastp( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk /* ** initialize */ for (k=0; k0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netwei( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,sidli2,dnisisq2,yisisq2,sis2,yisidli2,yisis2,yidsi2,sit2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*sidli,*dnisisq,*yisisq,*sis,*yisidli,*yisis,*yidsi,*sit; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - to je zdaj pointer, vrednosti klicem s s[i]*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(sidli2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ sidli = REAL(sidli2); PROTECT(yisisq2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisisq = REAL(yisisq2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); PROTECT(sis2 = allocVector(REALSXP, ntime)); /* sum of Si at each time*/ sis = REAL(sis2); PROTECT(yisidli2 = allocVector(REALSXP, ntime)); /* sum of Si*dLambdai*Yi at each time*/ yisidli = REAL(yisidli2); PROTECT(yisis2 = allocVector(REALSXP, ntime)); /* sum of Si*Yi at each time*/ yisis = REAL(yisis2); PROTECT(sit2 = allocVector(REALSXP, n)); /* Si for each individual*/ sit = REAL(sit2); PROTECT(yidsi2 = allocVector(REALSXP, ntime)); /* sum of dSi*Yi at each time*/ yidsi = REAL(yidsi2); /*initialize Si values*/ for (i=0; i0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); //sit[i]+=1/expect[indx]*(si[i]* exp(-hazard)- si[i]* exp(-hazard + et2*expect[indx])); if(expect[indx]==0) expect[indx]=0.000000001; if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k= times[j]){ yidsi[j]+=exp(-hazard); yidli[j]+=hazard; yisidli[j]+=hazard*si[i]; yi[j]+=1; yisi[j]+=1/si[i]; yisisq[j]+=1/(si[i]*si[i]); yisis[j]+=si[i]; yidlisi[j]+=hazard/si[i]; if(y[i]==times[j]){ dnisi[j]+=status[i]/si[i]; dni[j]+=status[i]; dnisisq[j]+=status[i]/(si[i]*si[i]); } } } time += thiscell; } /* ** package the output */ PROTECT(rlist = allocVector(VECSXP, 14)); SET_VECTOR_ELT(rlist,0, yidli2); SET_VECTOR_ELT(rlist,1, yidsi2); SET_VECTOR_ELT(rlist,2, dnisi2); SET_VECTOR_ELT(rlist,3, yisi2); SET_VECTOR_ELT(rlist,4, yidlisi2); SET_VECTOR_ELT(rlist,5, sidli2); SET_VECTOR_ELT(rlist,6, yi2); SET_VECTOR_ELT(rlist,7, dnisisq2); SET_VECTOR_ELT(rlist,8, yisisq2); SET_VECTOR_ELT(rlist,9, dni2); SET_VECTOR_ELT(rlist,10, sis2); SET_VECTOR_ELT(rlist,11, yisidli2); SET_VECTOR_ELT(rlist,12, yisis2); SET_VECTOR_ELT(rlist,13, sit2); PROTECT(rlistnames= allocVector(STRSXP, 14)); SET_STRING_ELT(rlistnames, 0, mkChar("yidli")); SET_STRING_ELT(rlistnames, 1, mkChar("yidsi")); SET_STRING_ELT(rlistnames, 2, mkChar("dnisi")); SET_STRING_ELT(rlistnames, 3, mkChar("yisi")); SET_STRING_ELT(rlistnames, 4, mkChar("yidlisi")); SET_STRING_ELT(rlistnames, 5, mkChar("sidli")); SET_STRING_ELT(rlistnames, 6, mkChar("yi")); SET_STRING_ELT(rlistnames, 7, mkChar("dnisisq")); SET_STRING_ELT(rlistnames, 8, mkChar("yisisq")); SET_STRING_ELT(rlistnames, 9, mkChar("dni")); SET_STRING_ELT(rlistnames, 10, mkChar("sis")); SET_STRING_ELT(rlistnames, 11, mkChar("yisidli")); SET_STRING_ELT(rlistnames, 12, mkChar("yisis")); SET_STRING_ELT(rlistnames, 13, mkChar("sit")); setAttrib(rlist, R_NamesSymbol, rlistnames); unprotect(16); /*kolk mora bit tu stevilka?? kolikor jih je +2??*/ return(rlist); } relsurv/src/Makevars.win0000644000176200001440000000110314741435136015036 0ustar liggesusers ## With R 3.1.0 or later, you can uncomment the following line to tell R to ## enable compilation with C++11 (where available) ## ## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider ## availability of the package we do not yet enforce this here. It is however ## recommended for client packages to set it. ## ## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP ## support within Armadillo prefers / requires it PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) relsurv/src/netweiDM.c0000644000176200001440000002115114055413722014426 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function - sums over individuals at each time ** The output table depends only on factors, not on continuous. ** This version converted to .Call syntax for memory savings ** ** Input: ** ** expected table, a multi-way array ** efac[edim] 1=is a factor, 0=continuous (time based) ** edims[edim] the dimension vector of the table; edim is its length ** ecut[sum(edims)] the starting point (label) for each dimension. ** if it is a factor dim, will be 1:edims[i] ** expect the actual table of expected rates ** ** subject data ** ** x[edim, n] where each subject indexes into the expected table ** at time 0, n= number of subjects ** y[n] the time at risk for each subject ** status[n] the status for each subject ** ** control over output ** ** times[ntime] the list of output times ** ** Output ** ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netweiDM( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2, SEXP ys2, SEXP status2, SEXP times2) { int i,j,k; int n, edim, ntime; double **x; double *data2, *si, *si2; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y, *ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,sidli2,sidliD2,dnisisq2,yisisq2,sis2,sisD2,yisidli2,yisis2,yidsi2,sit2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*sidli,*sidliD,*dnisisq,*yisisq,*sis,*sisD,*yisidli,*yisis,*yidsi,*sit; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - to je zdaj pointer, vrednosti klicem s s[i]*/ si2 = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - to je zdaj pointer, vrednosti klicem s s[i]*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(sidli2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ sidli = REAL(sidli2); PROTECT(sidliD2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ sidliD = REAL(sidliD2); PROTECT(yisisq2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisisq = REAL(yisisq2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); PROTECT(sis2 = allocVector(REALSXP, ntime)); /* sum of Si at each time*/ sis = REAL(sis2); PROTECT(sisD2 = allocVector(REALSXP, ntime)); /* sum of Si at each time*/ sisD = REAL(sisD2); PROTECT(yisidli2 = allocVector(REALSXP, ntime)); /* sum of Si*dLambdai*Yi at each time*/ yisidli = REAL(yisidli2); PROTECT(yisis2 = allocVector(REALSXP, ntime)); /* sum of Si*Yi at each time*/ yisis = REAL(yisis2); PROTECT(sit2 = allocVector(REALSXP, n)); /* Si for each individual*/ sit = REAL(sit2); PROTECT(yidsi2 = allocVector(REALSXP, ntime)); /* sum of dSi*Yi at each time*/ yidsi = REAL(yidsi2); /*initialize Si values*/ for (i=0; i0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); //sit[i]+=1/expect[indx]*(si[i]* exp(-hazard)- si[i]* exp(-hazard + et2*expect[indx])); if(expect[indx]==0) expect[indx]=0.000000001; if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k= times[j]){ if(ys[i]==times[j]){ si2[i]=1; } if(ys[i]= times[j]){ yidsi[j]+=exp(-hazard); yidli[j]+=hazard; yisidli[j]+=hazard*si[i]; yi[j]+=1; yisi[j]+=1/si[i]; yisisq[j]+=1/(si[i]*si[i]); yisis[j]+=si[i]; yidlisi[j]+=hazard/si[i]; if(y[i]==times[j]){ dnisi[j]+=status[i]/si[i]; dni[j]+=status[i]; dnisisq[j]+=status[i]/(si[i]*si[i]); } } } time += thiscell; } /* ** package the output */ PROTECT(rlist = allocVector(VECSXP, 16)); SET_VECTOR_ELT(rlist,0, yidli2); SET_VECTOR_ELT(rlist,1, yidsi2); SET_VECTOR_ELT(rlist,2, dnisi2); SET_VECTOR_ELT(rlist,3, yisi2); SET_VECTOR_ELT(rlist,4, yidlisi2); SET_VECTOR_ELT(rlist,5, sidli2); SET_VECTOR_ELT(rlist,6, yi2); SET_VECTOR_ELT(rlist,7, dnisisq2); SET_VECTOR_ELT(rlist,8, yisisq2); SET_VECTOR_ELT(rlist,9, dni2); SET_VECTOR_ELT(rlist,10, sis2); SET_VECTOR_ELT(rlist,11, yisidli2); SET_VECTOR_ELT(rlist,12, yisis2); SET_VECTOR_ELT(rlist,13, sit2); SET_VECTOR_ELT(rlist,14, sidliD2); SET_VECTOR_ELT(rlist,15, sisD2); PROTECT(rlistnames= allocVector(STRSXP, 16)); SET_STRING_ELT(rlistnames, 0, mkChar("yidli")); SET_STRING_ELT(rlistnames, 1, mkChar("yidsi")); SET_STRING_ELT(rlistnames, 2, mkChar("dnisi")); SET_STRING_ELT(rlistnames, 3, mkChar("yisi")); SET_STRING_ELT(rlistnames, 4, mkChar("yidlisi")); SET_STRING_ELT(rlistnames, 5, mkChar("sidli")); SET_STRING_ELT(rlistnames, 6, mkChar("yi")); SET_STRING_ELT(rlistnames, 7, mkChar("dnisisq")); SET_STRING_ELT(rlistnames, 8, mkChar("yisisq")); SET_STRING_ELT(rlistnames, 9, mkChar("dni")); SET_STRING_ELT(rlistnames, 10, mkChar("sis")); SET_STRING_ELT(rlistnames, 11, mkChar("yisidli")); SET_STRING_ELT(rlistnames, 12, mkChar("yisis")); SET_STRING_ELT(rlistnames, 13, mkChar("sit")); SET_STRING_ELT(rlistnames, 14, mkChar("sidliD")); SET_STRING_ELT(rlistnames, 15, mkChar("sisD")); setAttrib(rlist, R_NamesSymbol, rlistnames); unprotect(18); /*kolk mora bit tu stevilka?? kolikor jih je +2??*/ return(rlist); } relsurv/src/cmpfast.c0000644000176200001440000002573414162347017014364 0ustar liggesusers/* ** calculation of various quantities needed for the rs.surv function (for PP method and Ederer II method) - sums over individuals at each time ** ** This version converted to .Call syntax for memory savings ** ** Input: ** ** ** efac[edim] 1=is a factor, 0=continuous (time based) (edim is the number of variables in population mortality tables, usually 3 (age,sex,year), efac tells if they change in time, usually 1,0,1 (age and year change, sex does not)) ** edims[edim] the dimension vector of the population mortality table; edim is its length (for example 111, 2, 40 : 111 ages, 2 sexes, 40 years) ** ecut[sum(edims)] the starting point (label) for each dimension, if factor variable, then NULL. ** for example, for age: 0.00, 365.24, 730.48, 1095.72, 1460.96 ... ** expect the actual population mortality table (values - hazards per day) ** ** subject data ** ** x[edim, n] where each subject indexes into the population mortality table at time 0, n= number of subjects: a matrix - one row per individual - his value of age, sex and year at time of diagnosis ** y[n] the time at risk (follow-up time) for each subject ** status[n] the status for each subject: 0 (censored) or 1 (death) ** ** Output ** ** dnisi: sum(dNi/Spi) at each follow-up time ** yisi: sum(Yi/Spi) at each follow-up time ** yidlisi: sum(YidLambdapi/Spi) at each follow-up time ** dnisisq: sum(dNi/Spi^2) at each follow-up time - needed for the variance ** yi: sum(Yi) at each follow-up time - number at risk at that time ** dni: sum(dNi) at each follow-up time - number of events at that time ** yidli: sum(YidLambdapi/Spi) at each follow-up time ** */ #include #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP cmpfast( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2) { int i,j,k,kt; int n, edim, ntime; double **x; double *data2, *si, *sitt; double *dLambdap, *dLambdae, *dLambdao, *sigma, *sigmap, *sigmae, *So, *Soprej; double **ecut, *etemp; double hazard, hazspi; /*cum hazard over an interval, also weigthed hazard */ double thiscell, etime, time, et2; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2, cumince2,cumincp2,ve2,vp2,areae2,areap2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*cumince, *cumincp, *ve, *vp, *areae, *areap; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */ dLambdap = (double *)ALLOC(ntime, sizeof(double)); dLambdae = (double *)ALLOC(ntime, sizeof(double)); dLambdao = (double *)ALLOC(ntime, sizeof(double)); sigma = (double *)ALLOC(ntime, sizeof(double)); sigmap = (double *)ALLOC(ntime, sizeof(double)); sigmae = (double *)ALLOC(ntime, sizeof(double)); So = (double *)ALLOC(ntime, sizeof(double)); Soprej = (double *)ALLOC(ntime, sizeof(double)); /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yisitt = REAL(yisitt2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); PROTECT(cumince2 = allocVector(REALSXP, ntime)); /*add cumince*/ cumince = REAL(cumince2); PROTECT(cumincp2 = allocVector(REALSXP, ntime)); /*add cumincp*/ cumincp = REAL(cumincp2); PROTECT(ve2 = allocVector(REALSXP, ntime)); /*add ve*/ ve = REAL(ve2); PROTECT(vp2 = allocVector(REALSXP, ntime)); /*add vp*/ vp = REAL(vp2); PROTECT(areae2 = allocVector(REALSXP, ntime)); /*add areae*/ areae = REAL(areae2); PROTECT(areap2 = allocVector(REALSXP, ntime)); /*add areap*/ areap = REAL(areap2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk /* ** initialize */ for (k=0; k0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); hazspi+= et2* expect[indx]/(si[i]*exp(-hazard)); //add the integrated part if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k0){ So[j]=So[j-1]*(1-dLambdao[j]); Soprej[j]=So[j-1]; } else { So[j]=1-dLambdao[j]; } if(j>0){ cumince[j]=cumince[j-1] + Soprej[j]*dLambdae[j]; cumincp[j]=cumincp[j-1] + Soprej[j]*dLambdap[j]; } else{ cumince[j]=Soprej[j]*dLambdae[j]; cumincp[j]=Soprej[j]*dLambdap[j]; } for (kt=0; kt<=j; kt++) { // ve[j]+= (cumince[j] - cumince[kt])*(cumince[j] - cumince[kt])*sigma[kt] + So[kt]*sigmae[kt]*(So[kt]-2*(cumince[j]-cumince[kt])); // vp[j]+= (cumincp[j] - cumincp[kt])*(cumincp[j] - cumincp[kt])*sigma[kt] + So[kt]*sigmap[kt]*(So[kt]-2*(cumincp[j]-cumincp[kt])); ve[j]+= So[kt]*So[kt]*(1-(cumince[j] - cumince[kt])/So[kt])*(1-(cumince[j] - cumince[kt])/So[kt])*sigma[kt]; vp[j]+= (cumincp[j] - cumincp[kt])*(cumincp[j] - cumincp[kt])*sigma[kt]; } areae[j] = thiscell*cumince[j]; areap[j] = thiscell*cumincp[j]; time += thiscell; }// loop through times for (j=0; j #include "survprotomoj.h" /* using thernau's habit: name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP netfastpinter2( SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2,SEXP ys2, SEXP status2, SEXP times2, SEXP myprec2) { int i,j,k,jfine; int n, edim, ntime, nprec; double **x; double *data2, *si, *sitt; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double thiscell, time, et2, fyisi, /* fyisi and fyidlisi are the values in the finer division of the interval, ftime is the tiny time in those intervals */ fyidlisi, fyidlisi2, fyisi2, ftime, fthiscell, fint, sisum, sisumtt, lambdapi, lambdapi2, timestart; int indx, indx2; double wt; int *efac, *edims, *status; double *expect, *y,*ys, *times, *myprec; SEXP rlist, rlistnames; /*my declarations*/ SEXP yidli2, dnisi2,yisi2,yidlisi2,yi2,dni2,dnisisq2,yisitt2,yidlisitt2,yidlisiw2; double *yidli, *dnisi,*yisi,*yidlisi,*yi,*dni,*dnisisq, *yisitt,*yidlisitt,*yidlisiw; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ ys = REAL(ys2); status = INTEGER(status2); /* status */ times = REAL(times2); ntime = LENGTH(times2); /*length of times for reportint */ myprec = REAL(myprec2); //nprec = LENGTH(myprec); /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); si = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - this is a pointer, the values are called using s[i]*/ sitt = (double *)ALLOC(n, sizeof(double)); /*Si at the beg. of the interval for each individual */ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(yidli2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ yidli = REAL(yidli2); PROTECT(dnisi2 = allocVector(REALSXP, ntime)); /*sum dNi/Si for each time* - length=length(times2)*/ dnisi = REAL(dnisi2); PROTECT(yisi2 = allocVector(REALSXP, ntime)); /*sum Yi/Si for each time* - length=length(times2)*/ yisi = REAL(yisi2); PROTECT(yisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yisitt = REAL(yisitt2); PROTECT(yidlisi2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ yidlisi = REAL(yidlisi2); PROTECT(yidlisitt2 = allocVector(REALSXP, ntime)); /*add tt*/ yidlisitt = REAL(yidlisitt2); PROTECT(yidlisiw2 = allocVector(REALSXP, ntime)); /*add w*/ yidlisiw = REAL(yidlisiw2); PROTECT(yi2 = allocVector(REALSXP, ntime)); /* sum yi at each time*/ yi = REAL(yi2); PROTECT(dni2 = allocVector(REALSXP, ntime)); /*sum Yi dLambdai for each time* - length=length(times2)*/ dni = REAL(dni2); PROTECT(dnisisq2 = allocVector(REALSXP, ntime)); /*sum yi/Si dLambdai for each time* - length=length(times2)*/ dnisisq = REAL(dnisisq2); /*initialize Si values*/ for (i=0; i= times[j]){ // if still at risk - this is the same throughout the time intervals - the crude fine intervals are at event and censoring times. Spi must be calculated also for those entering later (period...) /* ** initialize */ for (k=0; k0) {*/ //this loop is needed if changes can happen between the interval points. et2 = pystep2(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, fthiscell, 1); lambdapi = expect[indx]; lambdapi2 = expect[indx2]; if(ys[i] using namespace arma; // use the Armadillo library for matrix computations using namespace Rcpp; // [[Rcpp::export]] List Yt(DataFrame data, NumericVector times) { // Obtain an at-risk list which is of length length(times). // Every element is a vector of length nrow(data). int n = times.size(); int m = data.nrows(); List mat_list(n); for (int i = 0; i < n; i++) { double t = times[i]; IntegerVector mat(m); NumericVector tstart = data["start"]; NumericVector tstop = data["Y"]; for (int j = 0; j < m; j++) { if (t <= tstop[j] && tstart[j] < t) mat[j] = 1; else mat[j] = 0; } mat_list[i] = mat; } return mat_list; } // [[Rcpp::export]] List dNt(DataFrame data, NumericVector times) { // Obtain the dNt list which is of length length(times). // Every element is a vector of length nrow(data). int nrow = data.nrows(); int ncol = times.size(); // Initialize dNt matrix with zeros List dNt(ncol); NumericVector dY = data["Y"]; NumericVector dstat = data["stat"]; for (int i = 0; i < ncol; i++) { NumericVector dNt_tmp(nrow); for (int j = 0; j < nrow; j++) { // Check if data$Y is equal to times if (dY[j] == times[i] && dstat[j] == 1) { dNt_tmp[j] = 1; } else{ dNt_tmp[j] = 0; } } dNt[i] = dNt_tmp; } return dNt; } // [[Rcpp::export]] NumericMatrix prepareX(IntegerVector Yt, NumericMatrix xt) { // Prepare a (n x p+1) matrix for (Intercept, X). Used for estimating beta. int nrow = Yt.size(); int ncol = xt.ncol()+1; NumericMatrix xt_tmp(nrow, ncol); for (int i = 0; i < nrow; i++) { xt_tmp(i, 0) = Yt(i); for (int j = 1; j < ncol; j++) { xt_tmp(i, j) = Yt(i) * xt(i, j-1); } } return xt_tmp; } // [[Rcpp::export]] arma::colvec fitOLS(arma::mat mX, arma::vec dNt, IntegerVector Yt) { // Run OLS, doesn't save Xminus in the output. int no_cov = mX.n_cols; int no_at_risk = sum(Yt); arma::vec vBeta = arma::vec(no_cov); // compute the OLS estimator if(no_at_risk >= no_cov){ arma::mat mXtX = mX.t()*mX; double rcf = rcond(mXtX); if(rcf != 0){ vBeta = solve(mXtX, mX.t()*dNt); // arma::colvec vBeta = solve(mX, dNt); } } return vBeta; } // // [[Rcpp::export]] // arma::mat matrixProduct(arma::mat mX, int no_cov) { // // arma::mat mat_prod = arma::mat(no_cov, no_cov); // arma::vec v1=mX.col(0); // arma::vec v2=mX.col(0); // // for (int i = 0; i < no_cov; ++i) { // v1 = mX.col(i); // for (int j = i; j < no_cov; ++j) { // v2 = mX.col(j); // // // mat_prod(i, j) = dot(mX.col(i), mX.col(j)); // mat_prod(i, j) = dot(v1, v2); // mat_prod(j, i) = mat_prod(i, j); // } // } // return mat_prod; // } // // // [[Rcpp::export]] // arma::mat matrixProduct2(arma::mat mX) { // arma::mat mat_prod=mX.t()*mX; // return mat_prod; // } // [[Rcpp::export]] List fitOLS2(arma::mat mX, arma::vec dNt, IntegerVector Yt) { // Run OLS, save Xminus in the output. int no_cov = mX.n_cols; int sample_size = mX.n_rows; int no_at_risk = sum(Yt); arma::vec vBeta = arma::vec(no_cov); arma::mat Xminus = arma::mat(no_cov, sample_size); List out(2); out[0] = vBeta; out[1] = Xminus; // compute the OLS estimator if(no_at_risk >= no_cov){ arma::mat mXtX = mX.t()*mX; double rcf = rcond(mXtX); if(rcf != 0){ Xminus = arma::inv(mXtX)*mX.t(); vBeta = Xminus*dNt; out[0] = vBeta; out[1] = Xminus; } } return out; } // [[Rcpp::export]] List fitOLSconst(arma::mat mX, arma::mat mZ, arma::vec dNt, IntegerVector Yt) { // Run estimation with constant effects. int no_cov = mX.n_cols; int no_cov_Z = mZ.n_cols; int sample_size = mX.n_rows; int no_at_risk = sum(Yt); // arma::vec vBeta = arma::vec(no_cov); arma::mat Xminus = arma::mat(no_cov, sample_size); arma::mat H = arma::mat(no_cov, no_cov); arma::mat Identity = arma::mat(sample_size, sample_size, fill::eye); arma::mat prvaKomponenta = arma::mat(no_cov_Z, no_cov_Z); arma::mat drugaKomponenta = arma::mat(no_cov_Z, 1); List out(3); out[0] = prvaKomponenta; out[1] = drugaKomponenta; out[2] = Xminus; // compute the OLS estimator if(no_at_risk >= no_cov){ arma::mat mXtX = mX.t()*mX; double rcf = rcond(mXtX); if(rcf != 0){ Xminus = arma::inv(mXtX)*mX.t(); H = Identity-mX*Xminus; prvaKomponenta = mZ.t()*H*mZ; drugaKomponenta = mZ.t()*H*dNt; // vBeta = Xminus*dNt; out[0] = prvaKomponenta; out[1] = drugaKomponenta; out[2] = Xminus; } } return out; } // Rcpp implementation of unlist-like functionality // [[Rcpp::export]] NumericVector rcpp_unlist(List listObject) { int total_length = 0; int sajz = listObject.size(); for (int i = 0; i < sajz; ++i) { total_length += as(listObject[i]).size(); } NumericVector result(total_length); int pos = 0; for (int i = 0; i < sajz; ++i) { NumericVector current = as(listObject[i]); for (int j = 0; j < current.size(); ++j) { result[pos] = current[j]; ++pos; } } return result; } // // [[Rcpp::export]] // arma::cube build_array(arma::vec x, arma::vec dimensions) { // // TALE VARIANTA DELA SAMO ZA 3D objekte. // // // Initialize empty cube (Order: slices, columns, rows) // arma::cube Cube1(dimensions[0], dimensions[1], dimensions[2]); // // // Fill cube by values of vector x // std::copy(x.begin(), x.end(), Cube1.begin()); // // return Cube1; // } // [[Rcpp::export]] NumericVector build_array3(NumericVector x, IntegerVector dimensions) { // int dimenzije = dimensions.n_elem; x.attr("dim") = dimensions; return x; } // // [[Rcpp::export]] // NumericMatrix matrix_subset(arma::mat x, // arma::uvec wrow, // arma::uvec wcol // ) { // // Take subset of matrix. // // // y must be an integer between 0 and columns - 1 // // Allows for repeated draws from same columns. // x = x.cols( wcol ); // x = x.rows( wrow ); // // NumericMatrix x2 = wrap(x); // // NumericMatrix x2 = arma::conv_to::from(wrap(x)); // return x2; // } // declare expc: extern "C" SEXP expc(SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2); // // [[Rcpp::export]] // List dLambdaP(NumericMatrix data, NumericVector all_times, NumericVector event_times, // NumericVector ratetable, List atts) { // // // Parameters for expc: // LogicalVector fk = as(atts["factor"]) != 1; // int nfk = fk.length(); // List cuts = atts["cutpoints"]; // // IntegerVector atts_type = as(atts["type"]); // int ltype = atts_type.length(); // IntegerVector rfac(ltype); // for (int i = 0; i < ltype; ++i) { // if (atts_type[i] == 1){ // rfac[i] = 1; // } // } // // IntegerVector adim = as(atts["dim"]); // NumericVector acuts = as(rcpp_unlist(cuts)); // // // Yt: // List Yt_all = Yt(data, all_times); // // int ltimes = all_times.size(); // int nr = data.nrow(); // // // Prepare ratetable: // NumericVector ratetable2 = build_array3(ratetable, adim); // // NumericMatrix outcome(nr, ltimes); // // // Prepare objects: // double tstart; // double tstop; // int sY; // int lY; // int jj; // IntegerVector Yt_all_i; // IntegerVector choose_cols = seq(3, nfk + 2); // arma::mat data_armamat = as(data); // // // Go through all times: // for (int i = 0; i < ltimes; ++i) { // if (i == 0) { // if (all_times[i] == 0) continue; // else tstart = 0; // } else { // tstart = all_times[i - 1]; // } // // tstop = all_times[i]; // // // Yt at i-th time: // Yt_all_i = Yt_all[i]; // // At-risk size: // sY = sum(Yt_all_i); // // Sample size: // lY = Yt_all_i.length(); // // Find those that are at-risk (which): // IntegerVector at_risk(sY); // // jj = 0; // for (int k = 0; k < lY; ++k) { // if (Yt_all_i[k]==1) { // at_risk[jj] = k; // jj = jj + 1; // } // } // // // Convert objects: // arma::uvec roows = arma::conv_to::from(as(wrap(at_risk))); // arma::uvec cools = arma::conv_to::from(as(wrap(choose_cols))); // // // Find data subset: // NumericMatrix data_tmp = matrix_subset(data_armamat, roows, cools); // // NumericMatrix data_tmp(sY, nfk); // // NumericVector tstart_vec = rep(tstart, sY); // // Increase age and year by tstart: // for (int j = 0; j < nfk; ++j) { // if(fk[j]==true){ // for(int ji = 0; ji < nfk; ++ji){ // data_tmp(ji, j) += tstart_vec[ji]; // } // } // } // // // Prepare times vector: // NumericVector times(sY, tstop - tstart); // // // Run expc: // List pop_survs0 = as(expc(wrap(rfac), wrap(adim), wrap(acuts), wrap(ratetable2), wrap(data_tmp), wrap(times))); // NumericVector pop_survs = pop_survs0["surv"]; // // NumericVector pop_survs = as(at_risk); // // // Save hazards: // for(int ji = 0; ji < sY; ++ji){ // int at_risk_ji = at_risk[ji]; // outcome(at_risk_ji, i) = -log(pop_survs[ji]); // } // } // // // Cumulative hazards: // for (int i = 0; i < nr; ++i) { // for (int j = 1; j < ltimes; ++j) { // outcome(i, j) += outcome(i, j - 1); // } // } // // // // Hazards at event times only: // // List outcome_l(event_times.size()); // // int j = 0; // // for (int i = 0; i < ltimes; ++i) { // // if (std::find(event_times.begin(), event_times.end(), all_times[i]) != event_times.end()) { // // outcome_l[j] = outcome(_, i); // // ++j; // // } // // } // // // Hazards at event times only: // List outcome_l(all_times.size()); // for (int i = 0; i < ltimes; ++i) { // outcome_l[i] = outcome(_, i); // } // // return outcome_l; // } // // [[Rcpp::export]] // List calculateBetas(DataFrame data, NumericMatrix xt, NumericVector event_times, int var_estimator) { // // List calculateBetas(DataFrame data, NumericMatrix xt, NumericVector event_times) { // // Run OLS at all event times. // // int ncol = event_times.size(); // // List Yt_val = Yt(data, event_times); // List dNt_val = dNt(data, event_times); // // List betas_list(ncol); // // NumericMatrix betas_list(ncol, nrow+1); // // int sample_size = xt.nrow(); // int number_covs = xt.ncol(); // arma::mat diag_dNt = arma::mat(sample_size, sample_size); // arma::mat beta_var = arma::mat(number_covs, number_covs); // List betas_var_list(ncol); // // for (int i = 0; i < ncol; i++) { // // NumericMatrix xx1 = prepareX(Yt_val[i], xt); // // arma::mat xx2 = as(xx1); // arma::vec dNti = as(dNt_val[i]); // // // arma::vec betas = fitOLS(xx2, dNti, Yt_val[i]); // List betas = fitOLS2(xx2, dNti, Yt_val[i]); // // // betas_list[i] = betas; // betas_list[i] = betas[0]; // // if(var_estimator == 1){ // diag_dNt.diag() = dNti; // } // if(var_estimator == 2){ // arma::vec betas0_vec = betas[0]; // arma::mat betas0(betas0_vec); // betas0.reshape(betas0_vec.size(), 1); // // diag_dNt.diag() = xx2*betas0; // } // // arma::mat betas1 = betas[1]; // betas_var_list[i] = betas1*diag_dNt*betas1.t(); // } // // List out(2); // out[0] = betas_list; // out[1] = betas_var_list; // // // return betas_list; // return out; // } // // [[Rcpp::export]] // List calculateBetasRelsurv(DataFrame data, NumericMatrix xt, NumericVector event_times, NumericVector all_times, // NumericVector ratetable, List atts, NumericMatrix data_mat) { // // Run OLS at all event times. // // int ncol = event_times.size(); // // List Yt_val = Yt(data, event_times); // List dNt_val = dNt(data, event_times); // List dLambdaP_val = dLambdaP(data_mat, all_times, event_times, ratetable, atts); // // List betas_list(ncol); // // arma::vec dL(data.nrows()); // // for (int i = 0; i < ncol; i++) { // // NumericMatrix xx1 = prepareX(Yt_val[i], xt); // // arma::mat xx2 = as(xx1); // arma::vec dNti = as(dNt_val[i]); // arma::vec dLambdaPi = as(dLambdaP_val[i]); // // if(i>0){ // dL = as(dLambdaP_val[i-1]); // } // // arma::vec betas = fitOLS(xx2, dNti-dLambdaPi+dL, Yt_val[i]); // // betas_list[i] = betas; // } // // return betas_list; // } // // [[Rcpp::export]] // List calculateBetasRelsurv2(DataFrame data, NumericMatrix xt, NumericVector event_times, NumericVector all_times, // NumericVector ratetable, List atts, NumericMatrix data_mat) { // // Run OLS at all times. // // int ncol = all_times.size(); // // List Yt_val = Yt(data, all_times); // List dNt_val = dNt(data, all_times); // List dLambdaP_val = dLambdaP(data_mat, all_times, event_times, ratetable, atts); // // List betas_list(ncol); // // arma::vec dL(data.nrows()); // // for (int i = 0; i < ncol; i++) { // // NumericMatrix xx1 = prepareX(Yt_val[i], xt); // // arma::mat xx2 = as(xx1); // arma::vec dNti = as(dNt_val[i]); // arma::vec dLambdaPi = as(dLambdaP_val[i]); // // if(i>0){ // dL = as(dLambdaP_val[i-1]); // } // // arma::vec betas = fitOLS(xx2, dNti-dLambdaPi+dL, Yt_val[i]); // // arma::vec betas_null = fitOLS(xx2, dNti, Yt_val[i]); // // // // double dPi = sum(dLambdaPi-dL); // // IntegerVector Yti_vec = Yt_val[i]; // // double Yti = sum(Yti_vec); // // // // if(Yti>0){ // // if(betas[0] != 0){ // // betas[0] = betas_null[0] - dPi*365.241/Yti; // // } // // } // // betas_list[i] = betas; // } // // return betas_list; // } // // [[Rcpp::export]] // List calculateBetasRelsurv22(DataFrame data, NumericMatrix xt, NumericVector event_times, NumericVector all_times, // NumericVector ratetable, List atts, NumericMatrix data_mat, int var_estimator) { // // Run OLS at all times. // // int ncol = all_times.size(); // // List Yt_val = Yt(data, all_times); // List dNt_val = dNt(data, all_times); // List dLambdaP_val = dLambdaP(data_mat, all_times, event_times, ratetable, atts); // // List betas_list(ncol); // arma::vec dL(data.nrows()); // // int sample_size = xt.nrow(); // int number_covs = xt.ncol(); // arma::mat diag_dNt = arma::mat(sample_size, sample_size); // arma::mat beta_var = arma::mat(number_covs, number_covs); // List betas_var_list(ncol); // // for (int i = 0; i < ncol; i++) { // // NumericMatrix xx1 = prepareX(Yt_val[i], xt); // // arma::mat xx2 = as(xx1); // arma::vec dNti = as(dNt_val[i]); // arma::vec dLambdaPi = as(dLambdaP_val[i]); // // if(i>0){ // dL = as(dLambdaP_val[i-1]); // } // // // arma::vec betas = fitOLS(xx2, dNti-dLambdaPi+dL, Yt_val[i]); // List betas = fitOLS2(xx2, dNti-dLambdaPi+dL, Yt_val[i]); // // // betas_list[i] = betas; // betas_list[i] = betas[0]; // // if(var_estimator == 1){ // diag_dNt.diag() = dNti-dLambdaPi+dL; // } // if(var_estimator == 2){ // arma::vec betas0_vec = betas[0]; // arma::mat betas0(betas0_vec); // betas0.reshape(betas0_vec.size(), 1); // diag_dNt.diag() = xx2*betas0; // } // arma::mat betas1 = betas[1]; // betas_var_list[i] = betas1*diag_dNt*betas1.t(); // // } // // List out(2); // out[0] = betas_list; // out[1] = betas_var_list; // // return betas_list; // return out; // } relsurv/src/dmatrix.c0000644000176200001440000000062713551065110014361 0ustar liggesusers/* $Id: dmatrix.c 11357 2009-09-04 15:22:46Z therneau $ ** ** set up ragged arrays, with #of columns and #of rows */ #include "survprotomoj.h" double **dmatrix(double *array, int ncol, int nrow) { register int i; register double **pointer; pointer = (double **) ALLOC(nrow, sizeof(double *)); for (i=0; i=2: special handling for "years" dim of US rate tables ** dims[nc] the extent of each category ** cuts[nc,dims+1] ragged array, containing the start for each interval ** step the amount of time remaining for the subject. ** edge if =0, then the cuts contain +1 obs, and we are strict ** about out-of-range cells. If it is a 1, then the ** table is assummed to extend infinitly at the edges. ** ** Output ** *index linear index into the array ** if *index == -1, then the returned amount of time is "off table"; ** if one of the dimensions has fac >1 -- ** *index2 second index for linear interpolation ** *wt a number between 0 and 1, amount of wt for the first index ** this will be 1 if none of the dims have fac >1 ** ** Return value amount of time in indexed cell. */ #include "survprotomoj.h" double pystep(int nc, int *index, int *index2, double *wt, double *data, int *fac, int *dims, double **cuts, double step, int edge) { int i,j; double maxtime; double shortfall; double temp; int kk, dtemp; kk=1; *index =0; *index2=0; *wt =1; shortfall =0; maxtime = step; for (i=0; i1) dtemp = 1 + (fac[i]-1)*dims[i]; else dtemp = dims[i]; for (j=0; j shortfall) { if (temp > step) shortfall = step; else shortfall = temp; } if (temp < maxtime) maxtime = temp; } else if (j==dtemp){ /*bigger than last cutpoint */ if (edge==0) { temp = cuts[i][j] - data[i]; /* time to upper limit */ if (temp <=0) shortfall = step; else if (temp < maxtime) maxtime = temp; } if (fac[i] >1) j = dims[i] -1; /*back to normal indices */ else j--; } else { temp = cuts[i][j] - data[i]; /* time to next cutpoint */ if (temp < maxtime) maxtime = temp; j--; if (fac[i] >1) { /*interpolate the year index */ *wt = 1.0 - (j%fac[i])/ (double)fac[i]; j /= fac[i]; *index2 = kk; } } *index += j*kk; } kk *= dims[i]; } *index2 += *index; if (shortfall ==0) return(maxtime); else { *index = -1; return(shortfall); } } relsurv/src/exps.c0000644000176200001440000000751313551065110013671 0ustar liggesusers/* ** Person-years calculations, leading to expected survival for a cohort. ** The output table depends only on factors, not on continuous. ** This version converted to .Call syntax for memory savings ** ** Input: ** ** expected table, a multi-way array ** efac[edim] 1=is a factor, 0=continuous (time based) ** edims[edim] the dimension vector of the table; edim is its length ** ecut[sum(edims)] the starting point (label) for each dimension. ** if it is a factor dim, will be 1:edims[i] ** expect the actual table of expected rates ** ** subject data ** ** x[edim, n] where each subject indexes into the expected table ** at time 0, n= number of subjects ** y[n] the time at risk for each subject ** status[n] the status for each subject ** ** control over output ** ** times[ntime] the list of output times ** ** Output ** ** */ #include #include "survprotomoj.h" /* my habit is to name a S object "charlie2" and the pointer ** to the contents of the object "charlie"; the latter is ** used in the computations */ SEXP expc(SEXP efac2, SEXP edims2, SEXP ecut2, SEXP expect2, SEXP x2, SEXP y2) { int i,k; int n, edim; double **x; double *data2; double **ecut, *etemp; double hazard; /*cum hazard over an interval */ double etime, et2; int indx, indx2; double wt; int *efac, *edims; double *expect, *y ; SEXP rlist, rlistnames; /*my declarations*/ SEXP si2; double *si; /* ** copies of input arguments */ efac = INTEGER(efac2); edims = INTEGER(edims2); edim = LENGTH(edims2); expect= REAL(expect2); n = LENGTH(y2); /*number of individuals */ x = dmatrix(REAL(x2), n, edim); y = REAL(y2); /*follow-up times*/ /* scratch space */ data2 = (double *)ALLOC(edim+1, sizeof(double)); /*si2 = (double *)ALLOC(n, sizeof(double)); /*Si for each individual - a je to prav???*/ /* ** Set up ecut index as a ragged array */ ecut = (double **)ALLOC(edim, sizeof(double *)); etemp = REAL(ecut2); for (i=0; i1) etemp += 1 + (efac[i]-1)*edims[i]; } /* ** Create output arrays */ PROTECT(si2 = allocVector(REALSXP, n)); /* Si for each individual*/ si = REAL(si2); /*initialize Si values*/ for (i=0; i0) { et2 = pystep(edim, &indx, &indx2, &wt, data2, efac, edims, ecut, etime, 1); if (wt <1) hazard+= et2*(wt*expect[indx] +(1-wt)*expect[indx2]); else hazard+= et2* expect[indx]; for (k=0; k=2: special handling for "years" dim of US rate tables ** dims[nc] the extent of each category ** cuts[nc,dims+1] ragged array, containing the start for each interval ** step the amount of time remaining for the subject. ** edge if =0, then the cuts contain +1 obs, and we are strict ** about out-of-range cells. If it is a 1, then the ** table is assummed to extend infinitly at the edges. ** ** Output ** *index linear index into the array ** if *index == -1, then the returned amount of time is "off table"; ** if one of the dimensions has fac >1 -- ** *index2 second index for linear interpolation ** *wt a number between 0 and 1, amount of wt for the first index ** this will be 1 if none of the dims have fac >1 ** ** Return value amount of time in indexed cell. */ #include "survprotomoj.h" double pystep2(int nc, int *index, int *index2, double *wt, double *data, int *fac, int *dims, double **cuts, double step, int edge) { int i,j; double shortfall; int kk, dtemp; kk=1; *index =0; *index2=0; *wt =1; shortfall =0; for (i=0; i= 2.42 } } \section{Changes in version 2.2-1}{ \itemize{ \item 10 Aug 2018 Corrected a bug in rformulate. R in (rtable)date format is put into rform$data, the original format of the variables is not preserved } } \section{Changes in version 2.2}{ \itemize{ \item 15 Apr 2018 Multiple changes to rformulate function (by Terry Therneau) to be in line with the new survival package requirements - several date formats are now allowed (date, Date, POSIXt) \item 7 Aug 2018 Add the rmap argument to functions rs.surv, rsmul, rsadd, rstrans, nessie, rs.period, rsdiff,cmp.rel, as is the practice in the survival package, and update the manual pages and examples. The ratetable() argument in the formula is still allowed but flagged as deprecated. \item Allow all the transrate functions to work without the dimid attribute \item New Slovene population tables included (up to 2016) } } relsurv/man/0000755000176200001440000000000014742177663012550 5ustar liggesusersrelsurv/man/rstrans.Rd0000644000176200001440000000726014742203116014517 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rstrans} \alias{rstrans} \title{Fit Cox Proportional Hazards Model in Transformed Time} \usage{ rstrans( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, init, control, rmap, ... ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, if desired, terms separated by the \code{+} operator on the right. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, such as \code{slopop}.} \item{int}{the number of follow-up years used for calculating survival(the rest is censored). If missing, it is set the the maximum observed follow-up time.} \item{na.action}{a missing-data filter function, applied to the model.frame, after any subset argument has been used. Default is \code{options()$na.action}.} \item{init}{vector of initial values of the iteration. Default initial value is zero for all variables.} \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{coxph.control} for details.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} \item{...}{other arguments will be passed to \code{coxph.control}.} } \value{ an object of class \code{coxph}. See \code{coxph.object} and \code{coxph.detail} for details. \item{y}{ an object of class \code{Surv} containing the transformed times (these times do not depend on covariates). } } \description{ The function transforms each person's time to his/her probability of dying at that time according to the ratetable. It then fits the Cox proportional hazards model with the transformed times as a response. It can also be used for calculatin the transformed times (no covariates are needed in the formula for that purpose). } \details{ NOTE: The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with by the \code{rmap} argument. For example, if age is in years in the data set but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. A side product of this function are the transformed times - stored in teh \code{y} object of the output. To get these times, covariates are of course irrelevant. } \examples{ data(slopop) data(rdata) #fit a Cox model using the transformed times #note that the variable year is given in days since 01.01.1960 and that #age must be multiplied by 365.241 in order to be expressed in days. fit <- rstrans(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241, sex=sex,year=year),ratetable=slopop,data=rdata) #check the goodness of fit rs.br(fit) } \references{ Method: Stare J., Henderson R., Pohar M. (2005) "An individual measure for relative survival." Journal of the Royal Statistical Society: Series C, \bold{54} 115--126. Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{rsmul}}, \code{\link{invtime}}, \code{\link{rsadd}}, \code{\link[survival:survexp]{survival::survexp}}. } \keyword{survival} relsurv/man/ebmt1wide.Rd0000644000176200001440000000036014534360123014677 0ustar liggesusers\name{ebmt1wide} \alias{ebmt1wide} \docType{data} \title{EBMT Data Taken From Package mstate} \description{ The ebmt1 dataset taken from package mstate transformed in long format. } \usage{data(ebmt1wide)} \keyword{datasets} relsurv/man/plot_f.Rd0000644000176200001440000000251114347333317014310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/years.R \name{plot_f} \alias{plot_f} \title{Plot the absolute risk (observed and population curve)} \usage{ plot_f( years, xlab = "Time interval", ylab = "Absolute risk", xbreak, ybreak, xlimits, ylimits, show.legend = TRUE ) } \arguments{ \item{years}{the object obtained using function \code{years}.} \item{xlab}{a title for the x axis.} \item{ylab}{a title for the y axis.} \item{xbreak}{the breaks on the x axis (this is supplied to \code{scale_x_continuous}).} \item{ybreak}{the breaks on the y axis (this is supplied to \code{scale_y_continuous}).} \item{xlimits}{define the limits on the x axis (this is supplied to \code{scale_x_continuous}).} \item{ylimits}{define the limits on the y axis (this is supplied to \code{scale_y_continuous}).} \item{show.legend}{if TRUE, the legend is shown on the graph.} } \value{ A ggplot object } \description{ Plots the estimated observed and population curve for the life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). } \details{ A ggplot2 implementation for plotting the observed and population curves. The type of curves is dependent upon the measure calculated using \code{years} function (argument \code{measure}). } \seealso{ \code{\link{years}}, \code{\link{plot_years}} } relsurv/man/colrec.Rd0000644000176200001440000000150512705412213014263 0ustar liggesusers\name{colrec} \alias{colrec} \docType{data} \title{Relative Survival Data} \description{ Survival of patients with colon and rectal cancer diagnosed in 1994-2000. } \usage{data(colrec)} \format{ A data frame with 5971 observations on the following 7 variables: \describe{ \item{sex}{sex (1=male, 2=female).} \item{age}{age (in days).} \item{diag}{date of diagnosis (in date format).} \item{time}{survival time (in days).} \item{stat}{censoring indicator (0=censoring, 1=death).} \item{stage}{cancer stage. Values 1-3, code \code{99} stands for unknown.} \item{site}{cancer site. } } } \references{ Provided by Slovene Cancer Registry. The \code{age}, \code{time} and \code{diag} variables are randomly perturbed to make the identification of patients impossible. } \keyword{datasets} relsurv/man/epa.Rd0000644000176200001440000000416014731637455013603 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{epa} \alias{epa} \title{Excess hazard function smoothing} \usage{ epa(fit, bwin, times, n.bwin = 16, left = FALSE) } \arguments{ \item{fit}{Fit from the additive relative survival model using the \code{EM} method.} \item{bwin}{The relative width of the smoothing window (default is 1).} \item{times}{The times at which the smoother is to be evaluated. If missing, it is evaluated at all event times.} \item{n.bwin}{Number of times that the window width may change.} \item{left}{If \code{FALSE} (default) smoothing is performed symmetrically, if \code{TRUE} only leftside neighbours are considered.} } \value{ A list with two components: \item{lambda}{the smoothed excess baseline hazard function} \item{times}{the times at which the smoothed excess baseline hazard is evaluated.} } \description{ An Epanechnikov kernel function based smoother for smoothing the baseline excess hazard calculated by the \code{rsadd} function with the \code{EM} method. } \details{ The function performs Epanechnikov kernel smoothing. The follow up time is divided (according to percentiles of event times) into several intervals (number of intervals defined by \code{n.bwin}) in which the width is calculated as a factor of the maximum span between event times. Boundary effects are also taken into account on both sides. } \examples{ data(slopop) data(rdata) #fit an additive model with the EM method fit <- rsadd(Surv(time,cens)~sex+age,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5,method="EM") sm <- epa(fit) plot(sm$times,sm$lambda) } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. EM algorithm: Pohar Perme M., Henderson R., Stare, J. (2009) "An approach to estimation in relative survival regression." Biostatistics, \bold{10}: 136--146. } \seealso{ \code{\link{rsadd}}, } \keyword{survival} relsurv/man/plot.cmp.rel.Rd0000644000176200001440000000641314124561334015342 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cmprel.r \name{plot.cmp.rel} \alias{plot.cmp.rel} \title{Plot the crude probability of death} \usage{ \method{plot}{cmp.rel}( x, main = " ", curvlab, ylim = c(0, 1), xlim, wh = 2, xlab = "Time (days)", ylab = "Probability", lty = 1:length(x), xscale = 1, col = 1, lwd = par("lwd"), curves, conf.int, all.times = FALSE, ... ) } \arguments{ \item{x}{a list, with each component representing one curve in the plot, output of the function \code{cmp.rel}.} \item{main}{the main title for the plot.} \item{curvlab}{Curve labels for the plot. Default is \code{names(x)}, or if that is missing, \code{1:nc}, where \code{nc} is the number of curves in \code{x}.} \item{ylim}{yaxis limits for plot.} \item{xlim}{xaxis limits for plot (default is 0 to the largest time in any of the curves).} \item{wh}{if a vector of length 2, then the upper right coordinates of the legend; otherwise the legend is placed in the upper right corner of the plot.} \item{xlab}{X axis label.} \item{ylab}{y axis label.} \item{lty}{vector of line types. Default \code{1:nc} (\code{nc} is the number of curves in \code{x}). For color displays, \code{lty=1}, \code{color=1:nc}, might be more appropriate. If \code{length(lty) -y when plotting.} } \value{ A ggplot object } \description{ Plot the years measure obtained from the \code{years} function. } \details{ A ggplot2 implementation for plotting the years measure. The type of curve is dependent upon the measure calculated using the \code{years} function (argument \code{measure}). } \seealso{ \code{\link{years}}, \code{\link{plot_f}} } relsurv/man/rsadd.Rd0000644000176200001440000001531014731637454014131 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rsadd} \alias{rsadd} \title{Fit an Additive model for Relative Survival} \usage{ rsadd( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, method = "max.lik", init, bwin, centered = FALSE, cause, control, rmap, ... ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, if desired, terms separated by the \code{+} operator on the right. \code{Surv(start,stop,event)} outcomes are also possible for time-dependent covariates and left-truncation for \code{method='EM'}. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{int}{either a single value denoting the number of follow-up years or a vector specifying the intervals (in years) in which the hazard is constant (the times that are bigger than \code{max(int)} are censored. If missing, only one interval (from time 0 to maximum observation time) is assumed. The EM method does not need the intervals, only the maximum time can be specified (all times are censored after this time point).} \item{na.action}{a missing-data filter function, applied to the model.frame, after any subset argument has been used. Default is \code{options()$na.action}.} \item{method}{\code{glm.bin} or \code{glm.poi} for a glm model, \code{EM} for the EM algorithm and \code{max.lik} for the maximum likelihood model (default).} \item{init}{vector of initial values of the iteration. Default initial value is zero for all variables.} \item{bwin}{controls the bandwidth used for smoothing in the EM algorithm. The follow-up time is divided into quartiles and \code{bwin} specifies a factor by which the maximum between events time length on each interval is multiplied. The default \code{bwin=-1} lets the function find an appropriate value. If \code{bwin=0}, no smoothing is applied.} \item{centered}{if \code{TRUE}, all the variables are centered before fitting and the baseline excess hazard is calculated accordingly. Default is \code{FALSE}.} \item{cause}{A vector of the same length as the number of cases. \code{0} for population deaths, \code{1} for disease specific deaths, \code{2} (default) for unknown. Can only be used with the \code{EM} method.} \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{glm.control} for details.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} \item{...}{other arguments will be passed to \code{glm.control}.} } \value{ An object of class \code{rsadd}. In the case of \code{method="glm.bin"} and \code{method="glm.poi"} the class also inherits from \code{glm} which inherits from the class \code{lm}. Objects of this class have methods for the functions \code{print} and \code{summary}. An object of class \code{rsadd} is a list containing at least the following components: \item{data}{the data as used in the model, along with the variables defined in the rate table} \item{ratetable}{the ratetable used.} \item{int}{the maximum time (in years) used. All the events at and after this value are censored.} \item{method}{the fitting method that was used.} \item{linear.predictors}{the vector of linear predictors, one per subject.} } \description{ The function fits an additive model to the data. The methods implemented are the maximum likelihood method, the semiparametric method, a glm model with a \code{binomial} error and a glm model with a \code{poisson} error. } \details{ NOTE: The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with by the \code{rmap} argument. For example, if age is in years in the data set but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. The maximum likelihood method and both glm methods assume a fully parametric model with a piecewise constant baseline excess hazard function. The intervals on which the baseline is assumed constant should be passed via argument \code{int}. The EM method is semiparametric, i.e. no assumptions are made for the baseline hazard and therefore no intervals need to be specified. The methods using glm are methods for grouped data. The groups are formed according to the covariate values. This should be taken into account when fitting a model. The glm method returns life tables for groups specified by the covariates in \code{groups}. The EM method output includes the smoothed baseline excess hazard \code{lambda0}, the cumulative baseline excess hazard \code{Lambda0} and \code{times} at which they are estimated. The individual probabilites of dying due to the excess risk are returned as \code{Nie}. The EM method fitting procedure requires some local smoothing of the baseline excess hazard. The default \code{bwin=-1} value lets the function find an appropriate value for the smoothing band width. While this ensures an unbiased estimate, the procedure time is much longer. As the value found by the function is independent of the covariates in the model, the value can be read from the output (\code{bwinfac}) and used for refitting different models to the same data to save time. } \examples{ data(slopop) data(rdata) #fit an additive model #note that the variable year is given in days since 01.01.1960 and that #age must be multiplied by 365.241 in order to be expressed in days. fit <- rsadd(Surv(time,cens)~sex+as.factor(agegr)+ratetable(age=age*365.241), ratetable=slopop,data=rdata,int=5) #check the goodness of fit rs.br(fit) #use the EM method and plot the smoothed baseline excess hazard fit <- rsadd(Surv(time,cens)~sex+age,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5,method="EM") sm <- epa(fit) plot(sm$times,sm$lambda,type="l") } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. EM algorithm: Pohar Perme M., Henderson R., Stare, J. (2009) "An approach to estimation in relative survival regression." Biostatistics, \bold{10}: 136--146. } \seealso{ \code{\link{rstrans}}, \code{\link{rsmul}} } \keyword{survival} relsurv/man/rs.surv.Rd0000644000176200001440000001561414731637024014456 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rs.surv} \alias{rs.surv} \title{Compute a Relative Survival Curve} \usage{ rs.surv( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action, fin.date, method = "pohar-perme", conf.type = "log", conf.int = 0.95, type = "kaplan-meier", add.times, precision = 1, rmap, weight.table = NULL, weight.names = NULL ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, if desired, terms separated by the \code{+} operator on the right. If no strata are used, \code{~1} should be specified. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{na.action}{a missing-data filter function, applied to the model.frame, after any subset argument has been used. Default is \code{options()$na.action}.} \item{fin.date}{the date of the study ending, used for calculating the potential follow-up times in the Hakulinen method. If missing, it is calculated as \code{max(year+time)}.} \item{method}{the method for calculating the relative survival. The options are \code{pohar-perme}(default), \code{ederer1}, \code{ederer2} and \code{hakulinen}.} \item{conf.type}{one of \code{plain}, \code{log} (the default), or \code{log-log}. The first option causes the standard intervals curve +- k *se(curve), where k is determined from conf.int. The log option calculates intervals based on the cumulative hazard or log(survival). The last option bases intervals on the log hazard or log(-log(survival)).} \item{conf.int}{the level for a two-sided confidence interval on the survival curve(s). Default is 0.95.} \item{type}{defines how survival estimates are to be calculated given the hazards. The default (\code{kaplan-meier}) calculates the product integral, whereas the option \code{fleming-harrington} exponentiates the negative cumulative hazard. Analogous to the usage in \code{survfit}.} \item{add.times}{specific times at which the curve should be evaluated.} \item{precision}{Precision for numerical integration. Default is 1, which means that daily intervals are taken, the value may be decreased to get a higher precision or increased to achieve a faster calculation. The calculation intervals always include at least all times of event and censoring as border points.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} \item{weight.table}{Default is NULL. If defined it is used for calculating standardized net survival. Supply a data.frame that contains the weights and group names for calculating the standardized net survival. The group column also has to be included in the data argument. For the theory see the details below.} \item{weight.names}{Default is NULL. If defined it is used for calculating standardized net survival. Supply a character vector of length two with the names of the group and weight columns in \code{weight.table}.} } \value{ a \code{survfit} object; see the help on \code{survfit.object} for details. The \code{survfit} methods are used for \code{print}, \code{summary}, \code{plot}, \code{lines}, and \code{points}. } \description{ Computes an estimate of the relative survival curve using the Ederer I, Ederer II method, Pohar-Perme method or the Hakulinen method } \details{ NOTE: The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with by the \code{rmap} argument. For example, if age is in years in the data set but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. The potential censoring times needed for the calculation of the expected survival by the Hakulinen method are calculated automatically. The times of censoring are left as they are, the times of events are replaced with \code{fin.date - year}. The calculation of the Pohar-Perme estimate is more time consuming since more data are needed from the population tables. The old version of the function, now named \code{rs.survo} can be used as a faster version for the Hakulinen and Ederer II estimate. Numerical integration is required for Pohar-Perme estimate. The integration precision is set with argument \code{precision}, which defaults to daily intervals, a default that should give enough precision for any practical purpose. Note that even though the estimate is always calculated using numerical integration, only the values at event and censoring times are reported. Hence, the function \code{plot} draws a step function in between and the function \code{summary} reports the value at the last event or censoring time before the specified time. If the output of the estimated values at other points is required, this should be specified with argument \code{add.times}. Standardized net survival can be also calculated: \eqn{SNS (t) = \sum_{j} w_j {NS}_j (t)} where \eqn{NS_j} is the net survival in the j-th group, \eqn{w_j} is the weight for the j-th group and \eqn{SNS} is the standardized net survival. \eqn{SNS} can be calculated by using the \code{weight.table} and \code{weight.names} arguments. The function also returns the corresponding standard error and confidence interval. } \examples{ data(slopop) data(rdata) #calculate the relative survival curve #note that the variable year must be given in a date format and that #age must be multiplied by 365.241 in order to be expressed in days. rs.surv(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata) # SNS: wei <- data.frame(agegr=c('<54', '54-61', '62-70', '71-95'), weight=c(0.2, 0.2, 0.3, 0.3)) rs.surv(Surv(time,cens)~1, rmap=list(age=age*365.241), ratetable=slopop, data=rdata, weight.table=wei, weight.names = c('agegr', 'weight')) } \references{ Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative Survival Analysis with the R Package relsurv". Journal of Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" Theory: Pohar Perme, M., Esteve, J., Rachet, B. (2016) "Analysing Population-Based Cancer Survival - Settling the Controversies." BMC Cancer, 16 (933), 1-8. doi:10.1186/s12885-016-2967-9. Theory: Pohar Perme, M., Stare, J., Esteve, J. (2012) "On Estimation in Relative Survival", Biometrics, 68(1), 113-120. doi:10.1111/j.1541-0420.2011.01640.x. } \seealso{ \code{survfit}, \code{survexp} } \keyword{survival} relsurv/man/predict.rsadd.Rd0000644000176200001440000000104214437574122015552 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/predict.rsadd.R \name{predict.rsadd} \alias{predict.rsadd} \title{Subject-specific prediction from rsadd} \usage{ \method{predict}{rsadd}(object, newdata, ...) } \arguments{ \item{object}{An rsadd object} \item{newdata}{A data.frame with one row (add covariate values in columns)} \item{...}{Not used for now} } \value{ A data.frame with times, excess and population hazard. } \description{ Function } \author{ Damjan Manevski \email{damjan.manevski@mf.uni-lj.si} } relsurv/man/joinrate.Rd0000644000176200001440000000346114742203116014635 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{joinrate} \alias{joinrate} \title{Join ratetables} \usage{ joinrate(tables, dim.name = "country", merge = FALSE) } \arguments{ \item{tables}{a list of ratetables. If names are given, they are included as \code{dimnames}.} \item{dim.name}{the name of the added dimension.} \item{merge}{if FALSE (default) only the intersect of all years/ages is taken. If TRUE all possible years/ages are included (NOTE: in this case hazards are extrapolated from earlier or later years/ages). This option only works for ratetables with dimensions} } \value{ An object of class \code{ratetable}. } \description{ The function joins two or more objects organized as \code{ratetable} by adding a new dimension. } \details{ This function joins two or more \code{ratetable} objects by adding a new dimension. The cutpoints of all the rate tables are compared; if merge=FALSE (default) only the common intervals are kept, otherwise if merge=TRUE all intervals are added (and hazards are extrapolated). If the intervals defined by the cutpoints are not of the same length, a warning message is displayed. Each rate table must have the same dimensions. } \examples{ #newpop <- joinrate(list(Arizona=survexp.az,Florida=survexp.fl, # Minnesota=survexp.mn),dim.name="state") } \references{ Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741-1749. } \seealso{ \code{\link[survival:ratetable]{survival::ratetable}}, \code{\link{transrate.hld}}, \code{\link{transrate.hmd}}, \code{\link{transrate}}. } \keyword{survival} relsurv/man/years.Rd0000644000176200001440000001050314731637025014150 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/years.R \name{years} \alias{years} \title{Compute one of the life years measures} \usage{ years( formula = formula(data), data, measure = c("yd", "yl2017", "yl2013"), ratetable = relsurv::slopop, rmap, var.estimator = c("none", "bootstrap", "greenwood"), B = 100, precision = 30, add.times, na.action = stats::na.omit, conf.int = 0.95, timefix = FALSE, is.boot = FALSE, first.boot = FALSE ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, \code{~1} specified on the right. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{measure}{choose which measure is used: 'yd' (life years difference; Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022), 'yl2017' (years lost/saved; Andersen 2017), 'yl2013' (years lost/saved; Andersen 2013).} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} \item{var.estimator}{Choose the estimator for the variance ('none', 'bootstrap', 'greenwood'). Default is 'none'. The 'greenwood' option is possible only for \code{measure='yd'}.} \item{B}{if \code{var.estimator} is 'bootstrap'. The number of bootstrap replications. Default is 100.} \item{precision}{precision for numerical integration of the population curve. Default is 30 (days). The value may be decreased to get a higher precision or increased to achieve a faster calculation.} \item{add.times}{specific times at which the curves should be reported.} \item{na.action}{a missing-data filter function. Default is \code{na.omit}.} \item{conf.int}{the confidence level for a two-sided confidence interval. Default is 0.95.} \item{timefix}{the timefix argument in survival::survfit.formula. Default is FALSE.} \item{is.boot}{if TRUE, the function \code{years} has been called during a bootstrap replication.} \item{first.boot}{if TRUE, this is the first bootstrap replication.} } \value{ A list containing the years measure, the observed and population curves (or the excess curve for Andersen 2013). The values are given as separate data.frames through time. Times are given in days, all areas are given in years. For \code{measure='yl2017'} values are reported only at the last time point. Functions \code{plot_f} and \code{plot_years} can be then used for plotting. } \description{ Provides an estimate for one of the following measures: years lost (Andersen, 2013), years lost/saved (Andersen, 2017), or life years difference (Manevski, Ruzic Gorenjec, Andersen, Pohar Perme, 2022). } \details{ The life years difference (\code{measure='yd'}) is taken by default. If other measures are of interest, use the \code{measure} argument. The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with the \code{rmap} argument. For example, if age is in years in the data but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. Numerical integration is performed, argument precision is set with argument \code{precision}, which defaults to 30-day intervals for intergration. For higher accuracy take a smaller value (e.g. precision=1 makes the integration on a daily basis). The observed curves are reported at event and censoring times. The population curves are reported at all times used for the numerical integration. Note that for the years lost (Andersen, 2013) measure, only the excess absolute risk is reported. } \examples{ library(relsurv) # Estimate the life years difference for the rdata dataset. mod <- years(Surv(time, cens)~1, data=rdata, measure='yd', ratetable=slopop, rmap=list(age=age*365.241), var.estimator = 'none') # Plot the absolute risk (observed and population curve): plot_f(mod) # Plot the life years difference estimate: plot_years(mod, conf.int=FALSE) } \seealso{ \code{\link{plot_f}}, \code{\link{plot_years}} } relsurv/man/expprep2.Rd0000644000176200001440000000237114742212461014571 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{expprep2} \alias{expprep2} \title{expprep2 function} \usage{ expprep2( x, y, ratetable, status, times, fast = FALSE, ys, prec, cmp = F, netweiDM = FALSE ) } \arguments{ \item{x}{matrix of demographic covariates - each individual has one line} \item{y}{follow-up time for each individual (same length as nrow(x))} \item{ratetable}{rate table used for calculation} \item{status}{status for each individual (same length as nrow(x)!), not needed if we only need Spi, status needed for rs.surv} \item{times}{times at which we wish to evaluate the quantities, not needed if we only need Spi, times needed for rs.surv} \item{fast}{for mpp method only} \item{ys}{entry times (if empty, individuals are followed from time 0)} \item{prec}{deprecated} \item{cmp}{should cmpfast.C be used} \item{netweiDM}{should new netwei script be used} } \value{ List containing the calculated hazards and probabilities using the population mortality tables. } \description{ Helper calculation function using C code. Saved also as exp_prep (unexported function). } \details{ Helper function used in rs.surv and other relsurv functions. } \seealso{ rs.surv } \keyword{survival} relsurv/man/rsaalen.Rd0000644000176200001440000000511314742177223014454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rsaalen.R \name{rsaalen} \alias{rsaalen} \title{Fit an extended additive hazards model using relative survival} \usage{ rsaalen( formula, data, variance = FALSE, var_estimator = "dN", ratetable = relsurv::slopop, rmap, split.transitions ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, if desired, terms separated by the \code{+} operator on the right.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{variance}{a logical value indicating whether the variances of the hazards should be computed. Default is FALSE.} \item{var_estimator}{Choose variance estimator, in the same way as in survaalen. The default option 'dN' uses dN(t)-dLambda_P(t) in the variance estimator, equivalent to formula 4.63 in Aalen et al. (2008). Option 'XdB' uses X*dB(t), see formula 4.64 in Aalen et al. (2008).} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object.} \item{split.transitions}{only relevant if a multi-state model is fitted. An integer vector containing the numbered transitions that should be split. Use same numbering as in the given transition matrix.} } \value{ An object of class \code{aalen.model}. } \description{ Fits the Aalen additive hazard model using relative survival. The function can be used for multi-state model data (as in the package mstate; class msdata) by supplying the start and stop times in the Surv object and adding a strata(trans) object in the formula (where trans denotes the transition in the multi-state model). } \examples{ # Survival: data(rdata) mod <- rsaalen(Surv(time, cens)~sex+age, data=rdata, ratetable=slopop, rmap=list(age=age*365.241)) head(mod$coefficients) tail(mod$coefficients) # Multi-state model: data(ebmt1wide) # Generate sex and year data (for illustrative purposes since it is not given in the data): ebmt1wide$sex <- sample(1:2, size = nrow(ebmt1wide), replace = TRUE) ebmt1wide$year <- as.Date('2010-01-01') mod <- rsaalen(Surv(Tstart, Tstop, status)~age.1+age.2+age.3+strata(trans), data=ebmt1wide, ratetable = slopop, rmap = list(age=age*365.241), split.transitions = 2:3) head(mod$coefficients$trans1) head(mod$coefficients$trans2) head(mod$coefficients$trans3) } \seealso{ \code{survaalen} } \author{ Damjan Manevski } \keyword{survival} relsurv/man/popsurv.Rd0000644000176200001440000000265614724631010014543 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/popsurv.R \name{popsurv} \alias{popsurv} \title{Calculate the expected (population) survival} \usage{ popsurv(sex, year = as.Date("1970-01-01"), age = 0, ratetable, times) } \arguments{ \item{sex}{Either character ('male'/'female'), or integer (1/2).} \item{year}{The year from which the individual is followed. Either a Date or POSIXt object. Default is as.Date('1970-01-01').} \item{age}{The age from which the individual is followed. Must be in days.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{times}{The times at which the expected (population) survival should be calculated. Must be in days.} } \value{ A vector containing the survival estimate at the supplied times. } \description{ For a given individual with sex, year, and age, calculate the expected (population) survival at the supplied time points based on the mortality tables. } \details{ The follow-up time and age must be specified in days. The calendar year can be in any date format (Date and POSIXt are allowed) } \examples{ library(relsurv) # Estimate P(T>2000 days) for a newborn: popsurv(sex='male', year=as.Date('1970-01-01'), age=0, ratetable=slopop, times=2000) # P(T>300 days) for a 50-year old: popsurv(sex='male', year=as.Date('1970-01-01'), age=50*365.241, ratetable=slopop, times=300) } \seealso{ \code{\link{expprep2}} } relsurv/man/transrate.hmd.Rd0000644000176200001440000000323714742202565015604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{transrate.hmd} \alias{transrate.hmd} \title{Reorganize Data obtained from Human Mortality Database into a Ratetable Object} \usage{ transrate.hmd(male, female) } \arguments{ \item{male}{a .txt file, containing the data on males.} \item{female}{a .txt file, containing the data on females.} } \value{ An object of class \code{ratetable}. } \description{ The function assists in reorganizing the .txt files obtained from Human Mortality Database (http://www.mortality.org) into a ratetable object. } \details{ This function works automatically with tables organised in the format provided by the Human Mortality Database. Download Life Tables for Males and Females separately from the column named 1x1 (period life tables, organized by date of death, yearly cutpoints for age as well as calendar year). If you wish to provide the data in the required format by yourself, note that the only two columns needed are calendar year (Year) and probability of death (qx). Death probabilities must be calculated up to age 110 (in yearly intervals). } \examples{ \dontrun{ auspop <- transrate.hmd("mltper_1x1.txt","fltper_1x1.txt") } } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link[survival:ratetable]{survival::ratetable}}, \code{\link{transrate.hld}}, \code{\link{joinrate}}, \code{\link{transrate}}. } \keyword{survival} relsurv/man/rsmul.Rd0000644000176200001440000000716614731637455014211 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rsmul} \alias{rsmul} \title{Fit Andersen et al Multiplicative Regression Model for Relative Survival} \usage{ rsmul( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, int, na.action, init, method = "mul", control, rmap, ... ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, if desired, terms separated by the \code{+} operator on the right. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, such as \code{slopop}.} \item{int}{the number of follow-up years used for calculating survival(the data are censored after this time-point). If missing, it is set the the maximum observed follow-up time.} \item{na.action}{a missing-data filter function, applied to the model.frame, after any subset argument has been used. Default is \code{options()$na.action}.} \item{init}{vector of initial values of the iteration. Default initial value is zero for all variables.} \item{method}{the default method \code{mul} assumes hazard to be constant on yearly intervals. Method \code{mul1} uses the ratetable to determine the time points when hazard changes. The \code{mul1} method is therefore more accurate, but at the same time can be more computationally intensive.} \item{control}{a list of parameters for controlling the fitting process. See the documentation for \code{coxph.control} for details.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} \item{...}{Other arguments will be passed to \code{coxph.control}.} } \value{ an object of class \code{coxph} with an additional item: \item{basehaz}{Cumulative baseline hazard (population values are seen as offset) at centered values of covariates.} } \description{ Fits the Andersen et al multiplicative regression model in relative survival. An extension of the coxph function using relative survival. } \details{ NOTE: The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with by the \code{rmap} argument. For example, if age is in years in the data set but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. } \examples{ data(slopop) data(rdata) #fit a multiplicative model #note that the variable year is given in days since 01.01.1960 and that #age must be multiplied by 365.241 in order to be expressed in days. fit <- rsmul(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241), ratetable=slopop,data=rdata) #check the goodness of fit rs.br(fit) } \references{ Method: Andersen, P.K., Borch-Johnsen, K., Deckert, T., Green, A., Hougaard, P., Keiding, N. and Kreiner, S. (1985) "A Cox regression model for relative mortality and its application to diabetes mellitus survival data.", Biometrics, \bold{41}: 921--932. Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{rsadd}}, \code{\link{rstrans}}. } \keyword{survival} relsurv/man/rdata.Rd0000644000176200001440000000122211203231600014072 0ustar liggesusers\name{rdata} \alias{rdata} \docType{data} \title{Survival Data} \description{ Survival data. } \usage{data(rdata)} \format{ A data frame with 1040 observations on the following 6 variables: \describe{ \item{time}{survival time (in days).} \item{cens}{censoring indicator (0=censoring, 1=death).} \item{age}{age (in years).} \item{sex}{sex (1=male, 2=female).} \item{year}{date of diagnosis (in date format).} \item{agegr}{age group.} } } \references{ Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. } \keyword{datasets} relsurv/man/rs.diff.Rd0000644000176200001440000000565314731637024014371 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rsdiff.r \name{rs.diff} \alias{rs.diff} \alias{print.rsdiff} \title{Test Net Survival Curve Differences} \usage{ rs.diff( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action, precision = 1, rmap ) } \arguments{ \item{formula}{A formula expression as for other survival models, of the form \code{Surv(time, status) ~ predictors}. Each combination of predictor values defines a subgroup. A \code{strata} term may be used to produce a stratified test. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{na.action}{a missing-data filter function, applied to the model.frame, after any subset argument has been used. Default is \code{options()$na.action}.} \item{precision}{Precision for numerical integration. Default is 1, which means that daily intervals are taken, the value may be decreased to get a higher precision or increased to achieve a faster calculation. The calculation intervals always include at least all times of event and censoring as border points.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} } \value{ a \code{rsdiff} object; can be printed with \code{print}. } \description{ Tests if there is a difference between two or more net survival curves using a log-rank type test. } \details{ NOTE: The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with by the \code{rmap} argument. For example, if age is in years in the data set but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. } \examples{ data(slopop) data(rdata) #calculate the relative survival curve #note that the variable year is given in days since 01.01.1960 and that #age must be multiplied by 365.241 in order to be expressed in days. rs.diff(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata) } \references{ Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative Survival Analysis with the R Package relsurv". Journal of Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" Theory: Graffeo, N., Castell, F., Belot, A. and Giorgi, R. (2016) "A log-rank-type test to compare net survival distributions. Biometrics. doi: 10.1111/biom.12477" Theory: Pavlic, K., Pohar Perme, M. (2017) "On comparison of net survival curves. BMC Med Res Meth. doi: 10.1186/s12874-017-0351-3" } \seealso{ \code{rs.surv}, \code{survdiff} } \keyword{survival} relsurv/man/residuals.rsadd.Rd0000644000176200001440000000324514124561334016114 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{residuals.rsadd} \alias{residuals.rsadd} \title{Calculate Residuals for a "rsadd" Fit} \usage{ \method{residuals}{rsadd}(object, type = "schoenfeld", ...) } \arguments{ \item{object}{an object inheriting from class \code{rsadd}, representing a fitted additive relative survival model. Typically this is the output from the \code{rsadd} function.} \item{type}{character string indicating the type of residual desired. Currently only Schoenfeld residuals are implemented.} \item{...}{other arguments.} } \value{ A list of the following values is returned: \item{res}{a matrix containing the residuals for each variable.} \item{varr}{the variance for each residual} \item{varr1}{the sum of \code{varr}.} \item{kvarr}{the derivative of each residual, to be used in \code{rs.zph} function.} \item{kvarr1}{the sum of \code{kvarr}.} } \description{ Calculates partial residuals for an additive relative survival model. } \examples{ data(slopop) data(rdata) fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5) sresid <- residuals.rsadd(fit) } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of fit of relative survival models." Statistics in Medicine, \bold{24}: 3911--3925. } \seealso{ \code{\link{rsadd}}. } \keyword{survival} relsurv/man/rs.surv.rsadd.Rd0000644000176200001440000000375514731637024015555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rssurvrsadd.r \name{rs.surv.rsadd} \alias{rs.surv.rsadd} \title{Compute a Relative Survival Curve from an additive relative survival model} \usage{ rs.surv.rsadd(formula, newdata) } \arguments{ \item{formula}{a \code{rsadd} object (Implemented only for models fitted with the codemax.lik (default) option.)} \item{newdata}{a data frame with the same variable names as those that appear in the \code{rsadd} formula. a predicted curve for each individual in this data frame shall be calculated} } \value{ a \code{survfit} object; see the help on \code{survfit.object} for details. The \code{survfit} methods are used for \code{print}, \code{plot}, \code{lines}, and \code{points}. } \description{ Computes the predicted relative survival function for an additive relative survival model fitted with maximum likelihood. } \details{ Does not work with factor variables - you have to form dummy variables before calling the rsadd function. } \examples{ data(slopop) data(rdata) #fit a relative survival model fit <- rsadd(Surv(time,cens)~sex+age+year,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=c(0:10,15)) #calculate the predicted curve for a male individual, aged 65, diagnosed in 1982 d <- rs.surv.rsadd(fit,newdata=data.frame(sex=1,age=65,year=as.Date("1982-01-01"))) #plot the curve (will result in a step function since the baseline is assumed piecewise constant) plot(d,xscale=365.241) #calculate the predicted survival curves for each individual in the data set d <- rs.surv.rsadd(fit,newdata=rdata) #calculate the average over all predicted survival curves p.surv <- apply(d$surv,1,mean) #plot the relative survival curve plot(d$time/365.241,p.surv,type="b",ylim=c(0,1),xlab="Time",ylab="Relative survival") } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 } \seealso{ \code{survfit}, \code{survexp} } \keyword{survival} relsurv/man/survfit.rsadd.Rd0000644000176200001440000000541714124561334015626 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/survfitrsadd.r \name{survfit.rsadd} \alias{survfit.rsadd} \title{Compute a Predicited Survival Curve} \usage{ \method{survfit}{rsadd}( formula, newdata, se.fit = TRUE, conf.int = 0.95, individual = FALSE, conf.type = c("log", "log-log", "plain", "none"), ... ) } \arguments{ \item{formula}{a rsadd object} \item{newdata}{a data frame with the same variable names as those that appear in the rsadd formula. The curve(s) produced will be representative of a cohort who's covariates correspond to the values in newdata.} \item{se.fit}{a logical value indicating whether standard errors should be computed. Default is \code{TRUE}.} \item{conf.int}{the level for a two-sided confidence interval on the survival curve(s). Default is 0.95.} \item{individual}{a logical value indicating whether the data frame represents different time epochs for only one individual (T), or whether multiple rows indicate multiple individuals (F, the default). If the former only one curve will be produced; if the latter there will be one curve per row in newdata.} \item{conf.type}{One of \code{none}, \code{plain}, \code{log} (the default), or \code{log-log}. The first option causes confidence intervals not to be generated. The second causes the standard intervals curve +- k *se(curve), where k is determined from conf.int. The log option calculates intervals based on the cumulative hazard or log(survival). The last option bases intervals on the log hazard or log(-log(survival)).} \item{...}{Currently not implemented} } \value{ a \code{survfit} object; see the help on \code{survfit.object} for details. The \code{survfit} methods are used for \code{print}, \code{plot}, \code{lines}, and \code{points}. } \description{ Computes a predicted survival curve based on the additive model estimated by rsadd function. } \details{ When predicting the survival curve, the ratetable values for future years will be equal to those of the last given year. The same ratetables will be used for fitting and predicting. To predict a relative survival curve, use \code{rs.surv.rsadd}. } \examples{ data(slopop) data(rdata) #BTW: work on a smaller dataset here to run the example faster fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata[1:500,],method="EM") survfit.rsadd(fit,newdata=data.frame(sex=1,age=60,year=17000)) } \references{ Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine,\bold{81}: 272--278. Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{survfit}, \code{survexp}, \code{\link{rs.surv}} } \keyword{survival} relsurv/man/nessie.Rd0000644000176200001440000000423514731637455014327 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{nessie} \alias{nessie} \title{Net Expected Sample Size Is Estimated} \usage{ nessie( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, times, rmap ) } \arguments{ \item{formula}{a formula object, same as in \code{rs.surv}. The right-hand side of the formula object includes the variable that defines the subgroups (a variable of type \code{factor}) by which the expected sample size is to be calculated.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{times}{Times at which the calculation should be evaluated - in years!} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details of the \code{rs.surv} function.} } \value{ A list of values. } \description{ Calculates how the sample size decreases in time due to population mortality } \details{ The function calculates the sample size we can expect at a certain time point if the patients die only due to population causes (population survival * initial sample size in a certain category), i.e. the number of individuals that remains at risk at given timepoints after the individuals who die due to population causes are removed. The result should be used as a guideline for the sensible length of follow-up interval when calculating the net survival. The first column of the output reports the number of individuals at time 0. The last column of the output reports the conditional expected (population) survival time for each subgroup. } \examples{ data(slopop) data(rdata) rdata$agegr <-cut(rdata$age,seq(40,95,by=5)) nessie(Surv(time,cens)~agegr,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,times=c(1,3,5,10,15)) } \references{ Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative Survival Analysis with the R Package relsurv". Journal of Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" } \seealso{ \code{rs.surv} } \keyword{survival} relsurv/man/summary.cmp.rel.Rd0000644000176200001440000000252414731637455016074 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cmprel.r \name{summary.cmp.rel} \alias{summary.cmp.rel} \title{Summary of the crude probability of death} \usage{ \method{summary}{cmp.rel}(object, times, scale = 365.241, area = FALSE, ...) } \arguments{ \item{object}{output of the function \code{cmp.rel}.} \item{times}{the times at which the output is required.} \item{scale}{The time scale in which the times are specified. The default value is \code{1}, i.e. days.} \item{area}{Should area under the curves at time \code{tau} be printed out? Default is \code{FALSE}.} \item{...}{Additional arguments, currently not implemented} } \value{ A list of values is returned. } \description{ Returns a list containing the estimated values at required times. } \details{ The variance is calculated using numerical integration. If the required time is not a time at which the value was estimated, the value at the last time before it is reported. The density of the time points is set by the \code{precision} argument in the \code{cmp.rel} function. } \examples{ data(slopop) data(rdata) #calculate the crude probability of death and summarize it fit <- cmp.rel(Surv(time,cens)~sex,rmap=list(age=age*365), ratetable=slopop,data=rdata,tau=3652.41) summary(fit,c(1,3),scale=365.241) } \seealso{ \code{cmp.rel} } \keyword{survival} relsurv/man/invtime.Rd0000644000176200001440000000433314731637455014513 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{invtime} \alias{invtime} \title{Inverse transforming of time in Relative Survival} \usage{ invtime( y = 0.1, age = 23011, sex = "male", year = as.Date("1986-01-01"), scale = 1, ratetable = relsurv::slopop, lower, upper ) } \arguments{ \item{y}{time in Y.} \item{age}{age of the individual. Must be in days.} \item{sex}{sex of the individual. Must be coded in the same way as in the \code{ratetable}.} \item{year}{date of diagnosis. Must be in a Date or POSIXt format.} \item{scale}{numeric value to scale the results. If \code{ratetable} is in units/day, \code{scale = 365.241} causes the output to be reported in years.} \item{ratetable}{a table of event rates, such as \code{survexp.us}.} \item{lower}{the lower bound of interval where the result is expected. This argument is optional, but, if given, can shorten the time the function needs to calculate the result.} \item{upper}{the upper bound of interval where the result is expected. See \code{lower}.} } \value{ A list of values \item{T}{the original time} \item{Y}{the transformed time}. } \description{ This function can be used when predicting in Relative Survival using the transformed time regression model (using \code{rstrans} function). It inverses the time from Y to T in relative survival using the given ratetable. The times Y can be produced with the \code{rstrans} function, in which case, this is the reverse function. This function does the transformation for one person at a time. } \details{ Works only with ratetables that are split by age, sex and year. Transforming can be computationally intensive, use lower and/or upper to guess the interval of the result and thus speed up the function. } \examples{ data(slopop) invtime(y = 0.1, age = 23011, sex = 1, year = as.Date('1986-01-01'), ratetable = slopop) } \references{ Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741-1749. } \seealso{ \code{\link{rstrans}} } \keyword{survival} relsurv/man/transrate.hld.Rd0000644000176200001440000000373214742203116015574 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{transrate.hld} \alias{transrate.hld} \title{Reorganize Data obtained from Human Life-Table Database into a Ratetable Object} \usage{ transrate.hld(file, cut.year, race) } \arguments{ \item{file}{a vector of file names which the data are to be read from. Must be in .tex format and in the same format as the files in Human Life-Table Database.} \item{cut.year}{a vector of cutpoints for years. Must be specified when the year spans in the files are not consecutive.} \item{race}{a vector of race names for the input files.} } \value{ An object of class \code{ratetable}. } \description{ The function assists in reorganizing the .txt files obtained from Human Life-Table Database (http://www.lifetable.de -> Data by Country) into a ratetable object. } \details{ This function works with any table organised in the format provided by the Human Life-Table Database, but currently only works with TypeLT 1 (i.e. age intervals of length 1). The age must always start with value 0, but can end at different values (when that happens, the last value is carried forward). The rates between the cutpoints are taken to be constant. } \examples{ \dontrun{ finpop <- transrate.hld(c("FIN_1981-85.txt","FIN_1986-90.txt","FIN_1991-95.txt")) } \dontrun{ nzpop <- transrate.hld(c("NZL_1980-82_Non-maori.txt","NZL_1985-87_Non-maori.txt", "NZL_1980-82_Maori.txt","NZL_1985-87_Maori.txt"), cut.year=c(1980,1985),race=rep(c("nonmaori","maori"),each=2)) } } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link[survival:ratetable]{survival::ratetable}}, \code{\link{transrate.hmd}}, \code{\link{joinrate}}, \code{\link{transrate}}. } \keyword{survival} relsurv/man/cmp.rel.Rd0000644000176200001440000001106314724631010014355 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cmprel.r \name{cmp.rel} \alias{cmp.rel} \alias{print.cmp.rel} \title{Compute crude probability of death} \usage{ cmp.rel( formula = formula(data), data = parent.frame(), ratetable = relsurv::slopop, na.action, tau, conf.int = 0.95, precision = 1, add.times, rmap ) } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, if desired, terms separated by the \code{+} operator on the right. If no strata are used, \code{~1} should be specified. NOTE: The follow-up time must be in days.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{ratetable}{a table of event rates, organized as a \code{ratetable} object, such as \code{slopop}.} \item{na.action}{a missing-data filter function, applied to the model.frame, after any subset argument has been used. Default is \code{options()$na.action}.} \item{tau}{the maximum follow-up time of interest, all times larger than \code{tau} shall be censored. Equals maximum observed time by default} \item{conf.int}{the level for a two-sided confidence interval on the survival curve(s). Default is 0.95.} \item{precision}{the level of precision used in the numerical integration of variance. Default is 1, which means that daily intervals are taken, the value may be decreased to get a higher precision or increased to achieve a faster calculation. The calculation intervals always include at least all times of event and censoring as border points.} \item{add.times}{specific times at which the value of estimator and its variance should be evaluated. Default is all the event and censoring times.} \item{rmap}{an optional list to be used if the variables are not organized and named in the same way as in the \code{ratetable} object. See details below.} } \value{ An object of class \code{cmp.rel}. Objects of this class have methods for the functions \code{print} and \code{plot}. The \code{summary} function can be used for printing output at required time points. An object of class \code{cmp.rel} is composed of several lists, each pertaining the cumulative hazard function for one risk and one strata. Each of the lists contains the following objects: \item{time}{the time-points at which the curves are estimated} \item{est}{the estimate} \item{var}{the variance of the estimate} \item{lower}{the lower limit of the confidence interval} \item{upper}{the upper limit of the confidence interval} \item{area}{the area under the curve calculated on the interval [0,\code{tau}]} \item{index}{indicator of event and censoring times among all the times in the output. The times added via paramater \code{add.times} are also included} \item{add.times}{the times added via parameter \code{add.times}} } \description{ Estimates the crude probability of death due to disease and due to population reasons } \details{ NOTE: The follow-up time must be specified in days. The \code{ratetable} being used may have different variable names and formats than the user's data set, this is dealt with by the \code{rmap} argument. For example, if age is in years in the data set but in days in the \code{ratetable} object, age=age*365.241 should be used. The calendar year can be in any date format (Date and POSIXt are allowed), the date formats in the \code{ratetable} and in the data may differ. Note that numerical integration is required to calculate the variance estimator. The integration precision is set with argument \code{precision}, which defaults to daily intervals, a default that should give enough precision for any practical purpose. The area under the curve is calculated on the interval [0,\code{tau}]. Function \code{summary} may be used to get the output at specific points in time. } \examples{ data(slopop) data(rdata) #calculate the crude probability of death #note that the variable year must be given in a date format and that #age must be multiplied by 365.241 in order to be expressed in days. fit <- cmp.rel(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,tau=3652.41) fit plot(fit,col=c(1,1,2,2),xscale=365.241,xlab="Time (years)") #if no strata are desired: fit <- cmp.rel(Surv(time,cens)~1,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,tau=3652.41) } \references{ Package: Pohar Perme, M., Pavlic, K. (2018) "Nonparametric Relative Survival Analysis with the R Package relsurv". Journal of Statistical Software. 87(8), 1-27, doi: "10.18637/jss.v087.i08" } \seealso{ \code{rs.surv}, \code{summary.cmp.rel} } \keyword{survival} relsurv/man/transrate.Rd0000644000176200001440000000317014742203116015022 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{transrate} \alias{transrate} \title{Reorganize Data into a Ratetable Object} \usage{ transrate(men, women, yearlim, int.length = 1) } \arguments{ \item{men}{a matrix containing the yearly (conditional) probabilities of one year survival for men. Rows represent age (increasing 1 year per line,starting with 0), the columns represent cohort years (the limits are in \code{yearlim}, the increase is in \code{int.length}.} \item{women}{a matrix containing the yearly (conditional) probabilities of one year survival for women.} \item{yearlim}{the first and last cohort year given in the tables.} \item{int.length}{the length of intervals in which cohort years are given.} } \value{ An object of class \code{ratetable}. } \description{ The function assists in reorganizing certain types of data into a ratetable object. } \details{ This function only applies for ratetables that are organized by age, sex and year. } \examples{ men <- cbind(exp(-365.241*exp(-14.5+.08*(0:100))),exp(-365*exp(-14.7+.085*(0:100)))) women <- cbind(exp(-365.241*exp(-15.5+.085*(0:100))),exp(-365*exp(-15.7+.09*(0:100)))) table <- transrate(men,women,yearlim=c(1980,1990),int.length=10) } \references{ Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link[survival:ratetable]{survival::ratetable}}. } \keyword{survival} relsurv/man/survaalen.Rd0000644000176200001440000000320214742177223015024 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/survaalen.R \name{survaalen} \alias{survaalen} \title{Fit an additive hazards model} \usage{ survaalen(formula, data, variance = FALSE, var_estimator = "dN") } \arguments{ \item{formula}{a formula object, with the response as a \code{Surv} object on the left of a \code{~} operator, and, if desired, terms separated by the \code{+} operator on the right.} \item{data}{a data.frame in which to interpret the variables named in the \code{formula}.} \item{variance}{a logical value indicating whether the variances of the hazards should be computed. Default is FALSE.} \item{var_estimator}{Choose variance estimator. The default option 'dN' uses dN(t) in the variance formula, see formula 4.63 in Aalen et al. (2008). Option 'XdB' uses X*dB(t), see formula 4.64 in Aalen et al. (2008).} } \value{ An object of class \code{aalen.model}. } \description{ Fits the Aalen additive hazard model. The function can be used for multi-state model data (as in the package mstate; class msdata) by supplying the start and stop times in the Surv object and adding a strata(trans) object in the formula (where trans denotes the transition in the multi-state model). } \examples{ # Survival: data(rdata) mod <- survaalen(Surv(time, cens)~sex+age, data=rdata) head(mod$coefficients) tail(mod$coefficients) # Multi-state model: data(ebmt1wide) mod <- survaalen(Surv(Tstart, Tstop, status)~age.1+age.2+age.3+strata(trans), data=ebmt1wide) head(mod$coefficients$trans1) head(mod$coefficients$trans2) head(mod$coefficients$trans3) } \seealso{ \code{rsaalen} } \author{ Damjan Manevski } \keyword{survival} relsurv/man/plot.rs.zph.Rd0000644000176200001440000000444314742203116015224 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{plot.rs.zph} \alias{plot.rs.zph} \title{Graphical Inspection of Proportional Hazards Assumption in Relative Survival Models} \usage{ \method{plot}{rs.zph}( x, resid = TRUE, df = 4, nsmo = 40, var, cex = 1, add = FALSE, col = 1, lty = 1, xlab, ylab, xscale = 1, ... ) } \arguments{ \item{x}{result of the \code{rs.zph} function.} \item{resid}{a logical value, if \code{TRUE} the residuals are included on the plot, as well as the smooth fit.} \item{df}{the degrees of freedom for the fitted natural spline, \code{df=2} leads to a linear fit.} \item{nsmo}{number of points used to plot the fitted spline.} \item{var}{the set of variables for which plots are desired. By default, plots are produced in turn for each variable of a model. Selection of a single variable allows other features to be added to the plot, e.g., a horizontal line at zero or a main title.} \item{cex}{a numerical value giving the amount by which plotting text and symbols should be scaled relative to the default.} \item{add}{logical, if \code{TRUE} the plot is added to an existing plot} \item{col}{a specification for the default plotting color.} \item{lty}{the line type.} \item{xlab}{x axis label.} \item{ylab}{y axis label.} \item{xscale}{units for x axis, default is 1, i.e. days.} \item{...}{Additional arguments passed to the \code{plot} function.} } \description{ Displays a graph of the scaled partial residuals, along with a smooth curve. } \examples{ data(slopop) data(rdata) fit <- rsadd(Surv(time,cens)~sex+as.factor(agegr),rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5) rszph <- rs.zph(fit) plot(rszph) } \references{ Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of fit of relative survival models." Statistics in Medicine, \bold{24}: 3911-3925. Package: Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272-278. Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741-1749, 2007. } \seealso{ \code{\link{rs.zph}}, \code{\link[survival:plot.cox.zph]{survival::plot.cox.zph}} } \keyword{survival} relsurv/man/slopop.Rd0000644000176200001440000000035510063271174014336 0ustar liggesusers\name{slopop} \alias{slopop} \docType{data} \title{Census Data Set for the Slovene Population} \description{ Census data set for the Slovene population. } \usage{data(slopop)} \examples{ data(slopop) } \keyword{datasets} relsurv/man/rs.zph.Rd0000644000176200001440000000455114742203116014247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rs.zph} \alias{rs.zph} \title{Behaviour of Covariates in Time for Relative Survival Regression Models} \usage{ rs.zph(fit, sc, transform = "identity", var.type = "sum") } \arguments{ \item{fit}{the result of fitting an additive relative survival model, using the \code{rsadd}, \code{rsmul} or \code{rstrans} function. In the case of multiplicative and transformation models the output is identical to \code{cox.zph} function, except no test is performed.} \item{sc}{partial residuals calculated by the \code{resid} function. This is used to save time if several tests are to be calculated on these residuals and can otherwise be omitted.} \item{transform}{a character string specifying how the survival times should be transformed. Possible values are \code{"km"}, \code{"rank"}, \code{"identity"} and \code{log}. The default is \code{"identity"}.} \item{var.type}{a character string specifying the variance used to scale the residuals. Possible values are \code{"each"}, which estimates the variance for each residual separately, and \code{sum}(default), which assumes the same variance for all the residuals.} } \value{ an object of class \code{rs.zph}. This function would usually be followed by a plot of the result. The plot gives an estimate of the time-dependent coefficient \code{beta(t)}. If the proportional hazards assumption is true, \code{beta(t)} will be a horizontal line. } \description{ Calculates the scaled partial residuals of a relative survival model (\code{rsadd}, \code{rsmul} or \code{rstrans}) } \examples{ data(slopop) data(rdata) fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5) rszph <- rs.zph(fit) plot(rszph) } \references{ Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of fit of relative survival models." Statistics in Medicine, \bold{24}: 3911--3925. Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, \code{\link{resid}}, \code{\link[survival:cox.zph]{survival::cox.zph}}. } \keyword{survival} relsurv/man/survsplit.Rd0000644000176200001440000000270714742203116015077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{survsplit} \alias{survsplit} \title{Split a Survival Data Set at Specified Times} \usage{ survsplit( data, cut, end, event, start, id = NULL, zero = 0, episode = NULL, interval = NULL ) } \arguments{ \item{data}{data frame.} \item{cut}{vector of timepoints to cut at.} \item{end}{character string with name of event time variable.} \item{event}{character string with name of censoring indicator.} \item{start}{character string with name of start variable (will be created if it does not exist).} \item{id}{character string with name of new id variable to create (optional).} \item{zero}{If \code{start} doesn't already exist, this is the time that the original records start. May be a vector or single value.} \item{episode}{character string with name of new episode variable (optional).} \item{interval}{this argument is used by \code{max.lik} function} } \value{ New, longer, data frame. } \description{ Given a survival data set and a set of specified cut times, the function splits each record into multiple records at each cut time. The new data set is be in \code{counting process} format, with a start time, stop time, and event status for each record. More general than \code{survSplit} as it also works with the data already in the \code{counting process} format. } \seealso{ \code{\link[survival:survSplit]{survival::survSplit}}. } \keyword{survival} relsurv/man/rs.br.Rd0000644000176200001440000000454414124561334014056 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Rcode.r \name{rs.br} \alias{rs.br} \alias{plot.rs.br} \alias{print.rs.br} \title{Test the Proportional Hazards Assumption for Relative Survival Regression Models} \usage{ rs.br(fit, sc, rho = 0, test = "max", global = TRUE) } \arguments{ \item{fit}{the result of fitting a relative survival model, using the \code{rsadd}, \code{rsmul} or \code{rstrans} function.} \item{sc}{partial residuals calculated by the \code{resid} function. This is used to save time if several tests are to be calculated on these residuals and can otherwise be omitted.} \item{rho}{a number controlling the weigths of residuals. The weights are the number of individuals at risk at each event time to the power \code{rho}. The default is \code{rho=0}, which sets all weigths to 1.} \item{test}{a character string specifying the test to be performed on Brownian bridge. Possible values are \code{"max"} (default), which tests the maximum absolute value of the bridge, and \code{cvm}, which calculates the Cramer Von Mises statistic.} \item{global}{should a global Brownian bridge test be performed, in addition to the per-variable tests} } \value{ an object of class \code{rs.br}. This function would usually be followed by both a print and a plot of the result. The plot gives a Brownian bridge for each of the variables. The horizontal lines are the 95% and 99% confidence intervals for the maximum absolute value of the Brownian bridge } \description{ Test the proportional hazards assumption for relative survival models (\code{rsadd}, \code{rsmul} or \code{rstrans}) by forming a Brownian Bridge. } \examples{ data(slopop) data(rdata) fit <- rsadd(Surv(time,cens)~sex,rmap=list(age=age*365.241), ratetable=slopop,data=rdata,int=5) rsbr <- rs.br(fit) rsbr plot(rsbr) } \references{ Goodness of fit: Stare J.,Pohar Perme M., Henderson R. (2005) "Goodness of fit of relative survival models." Statistics in Medicine, \bold{24}: 3911--3925. Package. Pohar M., Stare J. (2006) "Relative survival analysis in R." Computer Methods and Programs in Biomedicine, \bold{81}: 272--278 Relative survival: Pohar, M., Stare, J. (2007) "Making relative survival analysis relatively easy." Computers in biology and medicine, \bold{37}: 1741--1749. } \seealso{ \code{\link{rsadd}}, \code{rsmul}, \code{rstrans}, \code{\link{resid}}. } \keyword{survival} relsurv/DESCRIPTION0000644000176200001440000000215514746176252013503 0ustar liggesusersPackage: relsurv Type: Package Title: Relative Survival Version: 2.3-2 Date: 2025-01-28 Authors@R: c(person(c("Maja","Pohar","Perme"),role=c("aut"),email="maja.pohar@mf.uni-lj.si"), person(c("Damjan","Manevski"),role=c("aut", "cre"),email="damjan.manevski@mf.uni-lj.si")) Author: Maja Pohar Perme [aut], Damjan Manevski [aut, cre] Maintainer: Damjan Manevski Description: Contains functions for analysing relative survival data, including nonparametric estimators of net (marginal relative) survival, relative survival ratio, crude mortality, methods for fitting and checking additive and multiplicative regression models, transformation approach, methods for dealing with population mortality tables. Work has been described in Pohar Perme, Pavlic (2018) . Depends: R (>= 4.1.0), survival (>= 3.1) Imports: splines, ggplot2, pammtools, scales, Rcpp (>= 1.0.10) License: GPL (>= 2) LinkingTo: Rcpp, RcppArmadillo RoxygenNote: 7.3.2 LazyData: true NeedsCompilation: yes Repository: CRAN Packaged: 2025-01-28 15:19:00 UTC; dmanevski Date/Publication: 2025-01-28 15:50:02 UTC