msm/0000755000176200001440000000000012774720660011061 5ustar liggesusersmsm/inst/0000755000176200001440000000000012774212430012025 5ustar liggesusersmsm/inst/CITATION0000755000176200001440000000122712250051177013165 0ustar liggesuserscitHeader("To cite msm in publications use:") citEntry(entry = "Article", title = "Multi-State Models for Panel Data: The {msm} Package for {R}", author = personList(as.person("Christopher H. Jackson")), journal = "Journal of Statistical Software", year = "2011", volume = "38", number = "8", pages = "1--29", url = "http://www.jstatsoft.org/v38/i08/", textVersion = paste("Christopher H. Jackson (2011).", "Multi-State Models for Panel Data: The msm Package for R.", "Journal of Statistical Software, 38(8), 1-29.", "URL http://www.jstatsoft.org/v38/i08/.") ) msm/inst/NEWS0000755000176200001440000011652312774212065012543 0ustar liggesusers-*- text -*- USER-VISIBLE CHANGES (for detailed changes see ChangeLog in the source package) -------------------- Version 1.6.4 (2016-10-02) ------------- o CRAN release. Vignette source included in vignettes directory, on request of CRAN. Version 1.6.3 (2016-06-03) ------------- o r-forge release only. Fix of bug for qtnorm with vectorised arguments. Thanks to James Gibbons for the report. Version 1.6.2 (2016-03-17) ------------- o r-forge release only. Fix of bug for Pearson test with censored states. Thanks to Casimir Sofeu for the report. Version 1.6.1 (2016-03-09) ------------- o Fix of bug introduced in 1.5.2 for models with "obstrue" and "ematrix". This affected the first misclassification model presented in the PDF manual. Documented behaviour of "obstrue" clarified: with "ematrix" models, the state data are assumed to contain the true state if "obstrue" is turned on at the corresponding observation, and with "hmodel" models, the state data are generated from the HMM outcome model conditionally on the true state. o Fix of minor bugs in draic.msm and output printing. Version 1.6 (2015-11-17) ------------ o CRAN release. Includes the changes from versions 1.5.1 - 1.5.3, plus also: o Analytic derivatives for HMMs with multiple outcomes. o Bug fix for printing model output when only one transition rate is affected by covariates. Thanks to Jordi Blanch for the report. Version 1.5.3 (2015-09-14) ------------- o More underflow correction for probabilities of hidden states in viterbi.msm. Thanks to Hannah Linder for the report. o "death" argument in msm() is deprecated and renamed to "deathexact". o censor.states now defaults to all transient states if not supplied, instead of complaining, even if there is no absorbing state. Thanks to Jonathan Williams for the report. Version 1.5.2 (2015-02-17) ------------- o HMMs can now have multiple observations at each time generated from different distributions. See new function hmmMV(). o obstrue can now contain the actual true state, instead of an indicator. This allows the information from HMM outcomes generated conditionally on this state to be included in the model. Version 1.5.1 (2015-01-15) ------------- o R-forge only release. o HMMs can now have multiple observations at each time from the same distribution. The "state" in the "formula" argument of msm() is supplied as a matrix. o Up-to-date version of the vignette included in the package. Version 1.5 (2015-01-05) ----------- o CRAN release. Includes the changes from versions 1.4.1 - 1.4.3. Version 1.4.3 (2014-12-12) ------------- o R-forge only release. o Phase type models now allow an extra hidden Markov model on top. Version 1.4.2 (2014-12-11) ------------- o R-forge only release. o viterbi.msm now returns the "posterior" probability of each hidden state at each time, given the full data. o Bug fixes to misclassification models where some states were misclassified as other states with probability 1, for both ematrix and hmmCat specifications. Thanks to Li Su. Version 1.4.1 (2014-12-10) ------------- o R-forge only release. o Experimental facility for two-phase semi-Markov models. o Memory leaks in C code fixed. Thanks to Brian Ripley. o Don't print CIs for fixed parameters. o Documented that factors are allowed as the state variable as long as their levels are called "1", "2",... o Bug fixes for covariates on initial state occupancy probabilities with structural zeros. Thanks to Jeffrey Eaton and Tara Mangal. o Bug fixes for drlcv.msm. Thanks to Howard Thom. o Give warning that polynomial contrasts aren't supported. o Three and four-state versions of the BOS data provided. Version 1.4 (2014-07-04) ------------ o CRAN release. Includes the major changes from versions 1.3.2 and 1.3.3 below, previously only released on R-forge, plus: o Default confidence interval method for pnext.msm changed to "normal", since delta method may not respect probability <1 constraint. Version 1.3.3 (2014-06-23) -------------- o R-forge only release. o C interface changed from .C to .Call, giving a slight speed improvement. o Probabilities of passage, see ppass.msm. Version 1.3.2 (2014-06-19) -------------- o R-forge only release. o The new compact format for printing results from fitted models is now the default. The underlying numbers can be accessed from the functions msm.form.qoutput or msm.form.eoutput, or from the object returned by the print function, in the same tidy matrix form. The old print method is still available as "printold.msm". o Analytic derivatives available for most hidden Markov models and models with censored states (excluding unknown initial state probabilities, constraints on misclassification / categorical outcome probabilities and their covariates, and truncated or measurement error distributions). This should speed up optimisation with the BFGS or CG methods. The corresponding Fisher information matrix is also available for misclassification (categorical/identity outcome) and censored state models. o The BFGS optimisation method is now the default, rather than Nelder-Mead. o The internal code that deals with reading the data and passing it to models has been rewritten to use formulae, model frames and model matrices more efficiently. As a result the "data" component of msm objects now has a different structure. The data can be extracted with the new model.frame() and model.matrix() methods for msm objects. Also see help(recreate.olddata) for a utility to get the old (undocumented) format back, but this will not be supported in the long term. o New methods (draic.msm, drlcv.msm) for comparing models with differently-aggregated states. Thanks to Howard Thom. o Parallel processing supported for bootstrapping and bootstrap confidence intervals (ci="boot"), if the "doParallel" package is installed. o If msm is called with hessian=FALSE, then the Fisher (expected) information is used to obtain standard errors and CIs, though this is only available for non-hidden and misclassification models. This may be preferable if the observed Hessian is very intensive to approximate. o Optimisation code tidied, making it easier to add new methods. As an example, the "bobyqa" algorithm, a fast derivative-free method, is now supported if the "minqa" package is installed. o Give informative warning for initial outcomes in HMMs which are impossible for given initial state probabilites and outcome models. o Internal centering of "timeperiod" covariates around their means for inhomogeneous models specified with "pci" is now done consistently with other covariates, by omitting subjects' last observations before calculating the mean, since they don't contribute to the likelihood. Therefore for these models, the initial values (with "covariates centered around their means in the data") and outputs for covariates="mean", have a very slightly different meaning from previous versions. o When calculating the likelihood for hidden Markov or censoring models, P matrices are not recalculated when the same one occurs more than once. This may speed up some models. o Test suite tidied up and converted to use "testthat" package. o Data consistency check added to crudeinits.msm(). o Bug fix for misclassification models with constraints on baseline misclassification probabilities and fixed parameters. o Bug fix for bootstrap CIs with efpt.msm o Miscellaneous minor bug fixes, see Changelog. Version 1.3.1 (2014-04-04) -------------- o R-forge only release. o Time-dependent covariates supported in totlos.msm. o New function envisits.msm() for expected number of visits to each state over a period, calculated as a corollary of totlos.msm(). o New utility "msm2Surv" to export data from msm format to counting process format for use with the survival and mstate packages. This assumes the exact transition times of the process are known. o More informative messages from model fits which have not converged. In particular, a warning is now given when the optimiser iteration limit was reached without convergence, which previously happened silently. o Miscellaneous minor bug fixes, see Changelog. Version 1.3 (2014-01-15) ------------- o CRAN release. Includes the changes below from R-forge versions 1.2.1 up to 1.2.7, plus: o Fix of bug introduced in 1.2.3 which broke models with non-standard state ordering. o Datasets now lazy loaded so data() not required. o New "start" argument to efpt.msm, allowing averaging over a set of starting states. Version 1.2.7 (2013-10-07) ------------- o R-forge only release o Fix of bug for logLik.msm with by.subject=TRUE. Version 1.2.6 (2013-09-13) ------------- o R-forge only release o Row numbers reported in error message about different states at the same time corrected to account for missing data. Thanks to Lucy Leigh for the report. o An informative error is now shown if trying to use gen.inits with a hidden Markov model, and it is now documented that this is not supported. Version 1.2.5 (2013-07-30) ------------- o R-forge only release o Analytic formula for totlos.msm implemented, which is vastly more efficient than the numerical integration used previously. Debugging outputs left in 1.2.3 also removed. o Matrix exponentials, in MatrixExp and non-analytic likelihood calculations, are now calculated using expm from the expm package by default. As a result msm now depends on the expm package. Version 1.2.4 (2013-07-23) ------------- o R-forge only release o Range constraints can now be given for HMM outcome parameters, through a new argument "hranges" to msm. This may improve HMM identifiability. Version 1.2.3 (2013-06-06) ------------- o R-forge only release o New interface for easily specifiying different covariates for each transition intensity, through a named list in the "covariates" argument to msm. Previously this required "fixedpars". o Major restructuring of the internal code, mainly so that parameters are adjusted for covariates in R rather than C. There should be no differences visible to the user. o Initial state occupancy probabilities are estimated on the multivariate logit scale, not univariate, and confidence intervals are calculated using a simulation-based method (with 10000 simulations, so there will be a small Monte Carlo error). o When centering covariates around their means for the default likelihood calculation, the means used are now after dropping missing values and subjects with one observation, not before. Thanks to Howard Thom for the report. o Relatedly, the covariate values for subjects' last observations are not included in this mean, since they don't contribute to the likelihood, so interpretation of initial values for the qmatrix, and outputs for covariates="mean", will now be very slightly different. o Bug fix in totlos.msm: calculations were wrong for fromt > 0. o Memory bug in Viterbi, which could crash R, fixed. Version 1.2.2 (2013-05-21) ------------- o R-forge only release o Can now examine subject-specific -2 log likelihoods at the maximum likelihood estimates, via logLik.msm(). o The state can now be a factor with levels (1:nstates), as well as numeric. Previously supplying a factor state led to unpredictable behaviour and potential crashes. Version 1.2.1 (2013-05-16) ------------- o R-forge only release o A matrix of fixed patient-specific initial state distributions can now be supplied as "initprobs" in hidden Markov models. Version 1.2 (2013-05-14) ----------- o Implemented accurate p-value for the Pearson-type test from Titman (Lifetime Data Analysis, 2009). Non-hidden Markov models for pure panel data only. o A Fisher scoring algorithm can now be used to maximise the likelihood for panel data without censored / hidden states. Thanks to Andrew Titman for help with this. o New function efpt.msm for expected first passage times for time-homogeneous models. o prevalence.msm now produces expected values by integrating model predictions over the covariate histories observed in the data, if 'covariates="population"' is supplied. This is the default, but the old behaviour is available by supplying fixed covariates in the "covariates" argument. o In prevalence.msm and plot.prevalence.msm, subjects reaching the absorbing state can be removed from the risk set after they have reached an optional censoring time. Thanks to Andrew Titman. o Newly user-accessible function simfitted.msm for simulating from a model defined by the estimates from a model fitted in msm. o Subjects with only one observation are dropped from the data stored in fitted model objects. This gives more accurate numbers at risk in prevalence.msm. o Arguments can be passed through summary.msm to prevalence.msm. o pmatrix.piecewise.msm allows time-homogeneous models with change point vector "times" of length 0. o Fixes for bugs in the the Pearson test introduced in 0.9.5. o Misclassification models where some off-diagonal misclassification probabilities are 1 are now handled properly. Thanks to Howard Thom for uncovering this. o Bug fix for interp="midpoint" method in calculation of observed prevalences (prevalence.msm). Thanks to Erica Liu. o Bug fix for Viterbi algorithm with obstrue. Thanks to Linda Sharples. Version 1.1.4 (2012-12-10) ------------- o Minor modification of package tests to enable R CMD check to pass with the forthcoming release of mvtnorm. Version 1.1.3 (2012-09-28) ------------- o Bug fix: qmatrix.msm and ematrix.msm were returning inaccurate delta method standard errors / CIs with center=FALSE, covariates and user-supplied covariate values. Thanks to Vikki O'Neill for the report. o Use BFGS method for one-parameter optimisation unless method supplied explicitly, avoiding warning about unreliability of Nelder-Mead. Version 1.1.2 (2012-07-31) ------------- o New Student t distribution for hidden Markov model outcomes. Thanks to Darren Gillis. o Removed debugging browser which had been inadvertently left in pearson.msm. Thanks to Chyi-Hung Hsu. o Corrected equation 5 in the PDF manual for the likelihood under exact transition times. The code was unaffected. Thanks to Simon Bond. Version 1.1.1 (2012-05-11) ------------- o Fix of bug in calculation of confidence intervals using "ci=normal". Affected models were those with fixed parameters or HMMs. Users are advised to check their results with the corrected package - apologies. o If user supplies an ematrix with all misclassification probabilities zero, this degrades gracefully to a non-misclassification model. Thanks to Sharareh Taghipour for the report. o Bug fix for error messages when model inconsistent with data, and when subject IDs not adjacent. Thanks to Kelly Williams-Sieg for the report. o Bug fix in pearson.msm for models where transitions are only allowed from one state. Thanks to Gavin Chan for the report. o qtnorm fixed for p=0 or 1 and upper < lower. Thanks to Art Owen for the report. Version 1.1 (2011-09-09) ------------- o New function "pnext.msm" to compute a matrix of probabilities for the next state of the process. o New "[" method to intuitively extract a row and column of matrix-based estimates and confidence intervals, for example qmatrix.msm(x)[1,2] o Miscellaneous doc and minor bug fixes, see Changelog. Version 1.0.1 (2011-05-26) ------------- o Fix of a bug which made pmatrix.msm break for time-inhomogeneous models with non-integer time cut points "pci". Thanks to Christos Argyropoulos for the report. o Return -Inf in dtnorm when outside truncation bounds and log=TRUE. Version 1.0 (2010-11-24) ------------- o 1.0 release to accompany the forthcoming Journal of Statistical Software paper about msm. o Line types, colours and widths can be configured in plotprog.msm, plot.survfit.msm and plot.prevalence.msm. o Added warning for multiple observations at the same time on the same person with different states, which leads to zero likelihood and the dreaded "cannot be evaluated at initial values" message. o If center=FALSE, the $Qmatrices$baseline, $Ematrices$baseline and $sojourn components of msm objects are evaluated with covariate values of 0, for consistency with "logbaseline". Documentation and printed output corrected accordingly. These issues caused problems with viterbi.msm. Thanks to Kenneth Gundersen for the report. Version 0.9.7 (2010-05-18) ------------- o Bug fixes for bootstrapping with totlos, covariates on HMM outcomes and fixedpars. Thanks to Li Su for the report. Version 0.9.6 (2010-02-09) ------------- o Fix of a bug which caused occasional wrong likelihood calculations for models with "exacttimes". Thanks to Brian Tom for the report. o Fix for "NA in probability vector" error in pearson.msm. Thanks to Wen-Wen Yang for the report. Version 0.9.5 (2009-11-25) ------------- o Fix for a bug in pearson.msm triggered by a change in R version 2.10.0, which caused all expected values to be returned as zero. Thanks to Brian Tom for the report. Version 0.9.4 (2009-11-13) ------------- o Bug fix for calculation error in scoreresid.msm. Thanks to Aidan O'Keeffe for the report. o Options to MatrixExp for calculating the matrix exponential can be passed through from pmatrix.msm and pmatrix.piecewise.msm. Thanks to Peter Adamson for the suggestion. o Missing data handling bug fixes, in particular, crudeinits.msm and gen.inits no longer give errors if there are missing values in the subject, time or state variable. o Other minor bug fixes, see ChangeLog. Version 0.9.3 (2009-08-20) ------------- o Bug fix - estimates of covariate effects in matrices outputted by msm were ordered wrongly in models with "qconstraint". Thanks to Brian Tom for the report. o Bug fix - "gradient in optim evaluated to wrong length" was still affecting certain models with fixed parameters. Thanks to Aidan O'Keeffe for the report. o Fix to pearson.msm for R versions >= 2.9.1 ("replacement has 0 rows" error) Version 0.9.2 (2009-07-07) ------------- o Bug fix for models with fixed parameters fitted using optimisation methods with derivatives ("BFGS"), which failed with the error "gradient in optim evaluated to wrong length". Thanks to Isaac Dinner for the report. Version 0.9.1 (2009-06-12) ------------- o Minor update to the test suite to allow build on Fedora / Red Hat Linux. Version 0.9 (2009-06-09) ----------- o Time-inhomogeneous models fitted with the "pci" argument to msm are now fully supported in all output functions. pmatrix.msm can now compute transition probabilities over any given time interval for time-inhomogeneous models fitted with "pci". A new argument "t1" to pmatrix.msm specifies the starting time, while "t" still specifies the interval length. All functions which call on pmatrix.msm, such as plot.msm, plot.survfit.msm, prevalence.msm and totlos.msm, now account for time-inhomogeneity in models fitted using "pci". o Extractor functions are now more tolerant. If a list of covariate values is supplied, unknown covariates are ignored and covariates with unspecified values are set to zero. Factor values can be specified either by factor levels or by 0/1 contrasts. o Bug fix - score residuals were being calculated wrongly for models with covariates. o Derivatives are now used in the optimisation by default (use.deriv=TRUE) for optimisation methods such as BFGS which employ them. o Licence clarified as GPL-2 or later, to enable packaging of msm for Fedora/Red Hat Linux. Version 0.8.2 (2009-04-08) ------------- o Bug fix - extractor functions were not being calculated for models with interactions between covariates. o Sources for the PDF manual included in the source package, to enable inclusion of msm in Debian GNU/Linux. Version 0.8.1 (2008-07-25) ------------- o New option "pci" to msm, which automatically constructs a model with piecewise-constant transition intensities which change at the supplied times. o The HMM outcome model is assumed to apply to censored states in HMMs, unless obstrue = 1. o totlos.msm now calculates total length of stay for all states, not just transient states. New argument "end" added. o Bug fix in the likelihood calculation for data containing a mixture of obstype = 1 and obstype = 2. Thanks to Peter Jepsen for uncovering this. Version 0.8 (2008-03-28) ------------- o New function "pearson.msm" implementing the Pearson-type goodness-of-fit test for multi-state models fitted to panel data (Aguirre-Hernandez and Farewell, Statistics in Medicine 2002; Titman and Sharples, Statistics in Medicine 2007). Thanks to Andrew Titman for his work on this. o New function "scoreresid.msm" to compute and plot score residuals for detecting influential subjects. o New function "plotprog.msm" to plot Kaplan-Meier estimates of time to first occurrence of each state. o New function "plot.survfit.msm" to plot Kaplan-Meier estimate of survival probabilty compared with the fitted survival probability from a model. o New convenience function "lrtest.msm" for comparing a set of models with likelihood ratio tests. o logLik method returns the log-likelihood, not the minus log-likelihood, for consistency with methods in other packages. Thanks to Jay Rotella. o msm now depends on the "survival" package. o Data "heart" renamed to "cav" to avoid clashing with the dataset in the "survival" package. Version 0.7.6 (2007-12-10) ------------- o Covariates on misclassification probabilities can now be specified in simmulti.msm. Simulation bug introduced in 0.7.5 fixed. o quantile functions (qtnorm,qmenorm,qmeunif,qpexp) made more robust for small probabilities. Version 0.7.5 (2007-11-20) ------------- o The Viterbi algorithm can now be used to impute the most likely true state for censored states, as well as for HMMs o prevalence.msm now handles models with censored states correctly, using the Viterbi algorithm to determine the observed states. o Bug fix: account for extra arguments supplied to "prevalence.msm" when producing the plot of prevalences against time. Thanks to Peter Jepsen for the report. o Bug fixes involving factor covariates in bootstrapping and qratio.msm. Thanks to Peter Jepsen. o New beta outcome distribution for hidden Markov models. Version 0.7.4 (2007-10-01) ------------- o Minor changes to satisfy the package-building tools in the new R version 2.6.0. Version 0.7.3 (2007-08-15) ------------- o Confidence intervals in various output functions can now be calculated by simulating from the asymptotic normal distribution of the maximum likelihood estimates of the Q matrix and transforming. The "ci.boot" argument in these functions has been replaced by the "ci" argument, which can take values "none", "normal" and "bootstrap". This is implemented for qmatrix.msm, ematrix.msm, sojourn.msm, qratio.msm, pmatrix.msm, pmatrix.piecewise.msm, totlos.msm and prevalence.msm. Such CIs are expected to be more accurate than the delta method, but less accurate than bootstrapping. There is a similar compromise in computation time. Thanks to Andrew Titman for the suggestion. o As a result, msm now depends on the mvtnorm package. o In prevalence.msm, observed and expected prevalences can now be plotted against time. Thanks to Andrew Titman for the suggestion. o In prevalence.msm, observed states can be interpolated using the assumption that they change at the midpoints between observation times. o Matrix exponential routines now handle matrices with complex eigenvalues. Thanks to Vronique Bouchard for uncovering the bug. o Bug fix to surface.msm for HMMs. Thanks to Michael Sweeting. o Bug fix for bootstrapping - now handles models with obstype and obstrue. Thanks to Peter Jepsen for the report. Version 0.7.2 (2007-05-31) ------------- o An error in the calculation of multinomial logistic regression probabilities has been fixed. This will change the results of misclassification models where there were both a) three or more possible classifications for a particular underlying state and b) covariates on the corresponding classification probabilities. Any changes are not expected to be substantial. o Misclassification probabilities are now estimated on a different scale during the optimisation: log relative to baseline probability, instead of on a univariate logit scale. Therefore maximum likelihood estimates for misclassification models may be very slightly different from previous versions. o Confidence intervals for probabilities are now more appropriately calculated using a delta method approximation to the variance of logit(p), instead of log(p). o New argument "initcovariates" and "initcovinits" to msm, to allow covariate effects on initial state probabilities in hidden Markov models to be estimated through multinomial logistic regression. o Initial state probabilities initialised to zero are now fixed at zero during optimisation, if initprobs is being estimated ("structural zeroes"). o New argument "obstrue" to msm, to allow some observations to be observed without error in misclassification models. o Constraints on covariate effects on transition intensities are now allowed such that some effects are equal to other effects multiplied by -1. o New option "ci.boot" to prevalence.msm. This is a helper to calculate bootstrap confidence limits for the expected prevalences using "boot.msm". o rtnorm() for sampling from the truncated normal distribution now uses the efficient rejection sampling methods by Christian Robert. Version 0.7.1 (2007-04-18) ------------- o Maintainer's email address is now chris.jackson@mrc-bsu.cam.ac.uk o msm now gives a warning when the standard errors cannot be calculated due to the Hessian at the converged "solution" being non-positive-definite. This issue had been causing a lot of user confusion. o prevalence.msm can now calculate expected prevalences for models with piecewise-constant intensities, in the same manner as pmatrix.piecewise.msm. Intensities must still be common to all individuals. o Bug fix for presentation of intensity matrices in print.msm and qmatrix.msm when center = FALSE. These had been returning matrices with covariates set to zero, when they should have been set to their means. Thanks to Ross Boylan. o Covariates on transition process which are missing at an individual's last observation are not dropped, because they are not used in the analysis. Thanks to Jonathan Williams. This has the consequence that output from prevalence.msm may be different from earlier versions (0.7 or earlier) if there are missing values in the data. Users are advised to deal with missing values in their data appropriately before using msm. o Miscellaneous other bug fixes, see ChangeLog. Version 0.7 (2006-11-21) ----------- o Initial state occupancy probabilities in hidden Markov models can now be estimated. See new argument "est.initprobs" to msm. o Bootstrap resampling is implemented. This may be used to calculate confidence intervals or standard errors for quantities such as the transition probability matrix where this was previously not possible with msm, or as an alternative to Hessian-based standard errors or the delta method for other quantities. See new function boot.msm. o Bootstrap confidence intervals can be calculated directly from pmatrix.msm and totlos.msm. o Bug fix in estimation of observed prevalences at maximum observed time. Thanks to Jeremy Penn for the report. The function has also been rewritten so that the calculation of these prevalences is now much faster. o prevalence.msm is adapted sensibly to handle data where not all individuals start at a common time. o The values of categorical (factor) covariates in output functions, such as qmatrix.msm, are now specified in an intuitive way. For example, to calculate a statistic with the categorical covariate "smoke" at the level "CURRENT", just supply list(smoke="CURRENT") as the "covariates" argument to the output function. Version 0.6.4 (2006-09-21) ------------- o Bug fix to rtnorm for vector parameters. Thanks to Jean-Baptiste Denis for the report. o Bug fix to sim.msm: multiply covariates by baseline intensities in the correct order. Thanks to Stephan Lenz for the report. Version 0.6.3 (2006-06-28) ------------- o Correction to version 0.6.2 with the references reinstated in the manual. Version 0.6.2 (2006-06-23) ------------- o The likelihood for certain transient 2, 3, 4 and 5 state models is now calculated using analytic expressions for the transition probability matrix, instead of by numerically calculating the matrix exponential. This can give big speed improvements. o Various bug fixes, including support for character subject IDs. Version 0.6.1 (2006-03-26) ------------- o Bug fix release. In Viterbi algorithm, don't ignore initial state occupancy probabilities. Thanks to Melanie Wall for reporting this. For other bug fixes see the ChangeLog. Version 0.6 (2005-11-25) ------------- o New argument "use.deriv" to msm. If TRUE, then analytic derivatives are used in the algorithm to maximise the likelihood, where an appropriate algorithm is being used, such as optim's BFGS. These derivatives are also used to calculate the Hessian at the maximum. Not supported for hidden Markov models or models with censoring. This may substantially speed up convergence, especially for larger models. o The Newton-type algorithm (Dennis and Schnabel) from the R function "nlm" can also be used to maximise the likelihood, as an alternative to the algorithms in "optim". o New function "surface.msm" to plot likelihood surfaces, for example, in the region of a suspected maximum. Includes methods for the generic R functions contour(), persp() and image(), to produce each respective type of surface plot for a "msm" object. Version 0.5.2 (2005-10-11) ------------- o Bug fix in Viterbi algorithm. It didn't handle underlying Markov models with progressive and regressive states properly. Thanks to Rochelle Watkins. o Negative binomial hidden Markov output distribution added. o Miscellaneous other bug fixes, see ChangeLog. Version 0.5.1 (2005-05-25) ------------- o Bug fix in simulation functions (sim.msm, simmulti.msm). Models with time dependent covariates were not being simulated properly, the covariate changes were not fully accounted for. Thanks to Mike Sweeting for the report. o New functions dpexp, ppexp, qpexp, rpexp for the exponential distribution with piecewise-constant rates. o Bug fix. covariates with the same names as internal msm variable names, such as "subject", "time" and "state", are now allowed. o Argument "hessian" added to msm, to avoid calculating standard errors, for example when bootstrapping. o Miscellaneous internal edits and fixes, see ChangeLog. Version 0.5 (2005-03-06) ----------- o Major update. Much of the internal R and C code has been re-written. o General continuous-time hidden Markov models can now be fitted with msm, as well as misclassification models. Allowed response distributions conditionally on the hidden state include categorical, normal, Poisson, exponential and others. See the new "hmodel" argument. Misclassification models can either be fitted in the old style using an ematrix, or using a general HMM with a categorical response distribution. Covariates can be fitted to many of the new hidden response processes via generalized regressions. See "hcovariates", "hcovinits" arguments. o Per-observation observation schemes, generalising the "exacttimes" and "death" concepts. An optional new variable in the data can specify whether each observation is a snapshot of the process, an exactly-observed transition time, or a death state. Observations are allowed to be at identical times, for example, a snapshot followed instantly by an exact transition time. o Various syntax changes for cleaner moder specification. - Instead of 0/1 indicators, qmatrix and ematrix should contain the initial values for the transition intensity / misclassification matrix. These matrices can be named with names for the states of the Markov chain. - The inits argument is abolished. Initial values are estimated automatically if the new argument to msm "gen.inits = TRUE" is supplied. This uses the initial values calculated by crudeinits.msm. - misc no longer needs to be specified if an ematrix is supplied. - fixedpars=TRUE fixes all parameters, or specific parameters can be fixed as before. - crudeinits.msm takes a state ~ time formula instead of two separate state, time arguments, for consistency with the msm function. - Initial values for covariate effects on transition rates / misclassification probabilities are assumed to be zero unless otherwise specified by the new "covinits" / "misccovinits" argument. o Support for 'from-to' style data has been withdrawn. Storing data in this format is inadvisable as it destroys the longitudinal nature of the data. o Speed improvements. The algorithm for calculating the likelihood for non-hidden multi-state models has changed so that the matrix exponential of the Q matrix is only calculated once for each time difference / covariate combination. Therefore, users should see speed improvements for data where the same from-state, to-state, time difference, covariates combination appears many times. o Confidence intervals are now presented instead of standard errors for uncertainty in parameter estimates. o New method of calculating matrix exponentials when the eigenvector matrix is not invertible. It now uses the more robust method of Pade approximants with scaling and squaring, instead of power series. Faster LAPACK routines are now used for matrix inversion. o covmatch argument to msm has been abolished. To take a time-dependent covariate value from the end of the relevant transition instead of the default start, users are expected to manipulate their data accordingly before calling msm, shifting the positions of the covariate back by one within each subject. o Syntax changes for simmulti.msm. Bug fixes --------- o The likelihood is now calculated correctly for individuals with censored intermediate states, as well as censored initial and final states. Thanks to Michael Sweeting for reporting this. o hazard.scale and odds.scale were interpreted wrongly in hazard.msm and odds.msm respectively. o time-dependent covariate values now taken from the start instead of end of the transition under hidden Markov models. Version 0.41 (2005-01-28) ------------ o Censored outcomes in misclassification models are assumed to be not subject to misclassification. o A couple of bug fixes for exact transition times. Version 0.4 (2005-01-07) ----------- o Censored observations are now supported, via new "censor" and "censor.states" arguments. A censored observation is unknown, but known to be one of a particular set of states. A major update to msm is under development, for release in the first half of 2005. This will support hidden Markov models with general response distributions. Version 0.3.3 (2004-09-18) ------------- o Maintenance release with minor fixes and enhancements ready for R-2.0.0. Version 0.3.2 (2003-03-25) ------------- o More than one death state is now permitted, through the "death" argument. Death states are those whose exact entry time is known, but the state at the previous instant before death is unknown. o The "tunit" argument has been abolished. Death times are now assumed to be exact rather than known within one day. This makes more sense since for longitudinal studies, all observations are usually recorded to within one basic time unit, not just death times. o Cleanups of the manual and minor fixes, as detailed in ChangeLog. Version 0.3.1 (2003-10-14) ------------- o Bug fix. The likelihood was being wrongly calculated in cases when both the data represent exact transition times and the transition intensity matrix had repeated eigenvalues. o The "death" argument is no longer ignored when exacttimes=TRUE, as it is reasonable to have the entry time into one state accurate to within one day, and all other times exactly accurate. o More memory problems should be fixed. Version 0.3 (2003-09-29) ------------- o Two errors in the calculation of the likelihood for a multi-state model have been corrected. These bugs affect only models with reversible transition matrices, that is, models which allow progression and regression between states. o The first bug occurred when death times were known to within one time unit (death = TRUE) - the likelihood calculation did not account for reversible states. o The second bug occurred when the data represent exact transition times (exacttimes = TRUE). The likelihood calculation did not properly account for reversible states. o Baseline transition intensities, or misclassification probabilities, can now be constrained to be equal to each other, in the same manner as covariate effects. Specified by new arguments "qconstraint" or "econstraint". o The memory allocation problems of version 0.2 have been fixed. Version 0.22 (2003-06-30) -------------- o Fixed some minor bugs, as detailed in ChangeLog. o New function, pmatrix.piecewise.msm, for calculating transition probability matrices for processes with piecewise-constant intensities. Version 0.21 (2003-06-03) -------------- o Fixed a handful of minor bugs, as detailed in ChangeLog. o Minor edits and additions to the manual. o The subject ID can now be factor or character. Version 0.2 (2003-01) ------------- o A full manual in PDF format is included in the doc directory. This gives the mathematical background behind multi-state modelling, and a tutorial in the typical use of the functions in the msm package. o Many more methods for extracting summary statistics from the fitted model are included. These are generally called with the fitted model as the argument, plus an optional argument indicating the assumed covariate values. The functions include qmatrix.msm, ematrix.msm, pmatrix.msm, qratio.msm, sojourn.msm, totlos.msm, hazard.msm, odds.msm, prevalence.msm. o New function statetable.msm to calculate frequencies of transitions between pairs of states observed in the data. o New function crudeinits.msm to estimate transition intensities assuming the data represent the exact transition times of the Markov process. These can be used as initial values in the msm function for fitting the model. o prevalencemisc.msm has been removed, as its methodology was overcomplicated and confusing. The methods used in prevalence.msm have been extended naturally to deal with misclassification models. o Fix of a bug in the likelihood calculation for misclassification models (the number of non-death states was assumed to be the same as the number of states that could be misclassified, leading to failure to calculate the likelihood for models where some states are observed without error, but are not death states. ) Thanks to Martyn Plummer for reporting this. o Fix of a bug in the simulation routines (getobs.msm, called by simmulti.msm), where for models with absorbing states, the absorbing state is not retained in the simulated data. o New heart transplant example data set, as used in the manual, so that all the examples given in the manual can be run by the user. o Tidying of the help pages. Version 0.1 (2002-11) ------------- o First release. msm/inst/doc/0000755000176200001440000000000012774212430012572 5ustar liggesusersmsm/inst/doc/msm-manual.R0000644000176200001440000002350012774212430014764 0ustar liggesusers### R code from vignette source 'msm-manual.Rnw' ################################################### ### code chunk number 1: msm-manual.Rnw:41-43 ################################################### version <- gsub("Version: +", "", packageDescription("msm", lib.loc=c("../..",.libPaths()))$Version) ################################################### ### code chunk number 2: msm-manual.Rnw:48-49 ################################################### cat(version) ################################################### ### code chunk number 3: msm-manual.Rnw:52-53 ################################################### cat(format(Sys.time(), "%d %B, %Y")) ################################################### ### code chunk number 4: msm-manual.Rnw:861-862 ################################################### options(width = 60) ################################################### ### code chunk number 5: msm-manual.Rnw:897-898 ################################################### library(msm) ################################################### ### code chunk number 6: msm-manual.Rnw:957-958 ################################################### cav[1:21,] ################################################### ### code chunk number 7: msm-manual.Rnw:968-969 ################################################### statetable.msm(state, PTNUM, data=cav) ################################################### ### code chunk number 8: msm-manual.Rnw:1020-1024 ################################################### Q <- rbind ( c(0, 0.25, 0, 0.25), c(0.166, 0, 0.166, 0.166), c(0, 0.25, 0, 0.25), c(0, 0, 0, 0) ) ################################################### ### code chunk number 9: msm-manual.Rnw:1058-1060 ################################################### Q.crude <- crudeinits.msm(state ~ years, PTNUM, data=cav, qmatrix=Q) ################################################### ### code chunk number 10: msm-manual.Rnw:1084-1086 ################################################### cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4) ################################################### ### code chunk number 11: msm-manual.Rnw:1114-1115 (eval = FALSE) ################################################### ## help(optim) ################################################### ### code chunk number 12: msm-manual.Rnw:1138-1139 ################################################### cav.msm ################################################### ### code chunk number 13: msm-manual.Rnw:1178-1180 ################################################### cavsex.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4, covariates = ~ sex) ################################################### ### code chunk number 14: msm-manual.Rnw:1188-1189 ################################################### cavsex.msm ################################################### ### code chunk number 15: msm-manual.Rnw:1205-1207 ################################################### qmatrix.msm(cavsex.msm, covariates=list(sex=0)) # Male qmatrix.msm(cavsex.msm, covariates=list(sex=1)) # Female ################################################### ### code chunk number 16: msm-manual.Rnw:1219-1222 (eval = FALSE) ################################################### ## cavsex.msm <- msm( state ~ years, subject=PTNUM, data = cav, ## qmatrix = Q, deathexact = 4, ## covariates = list("1-2" = ~ sex, "1-4" = ~sex) ) ################################################### ### code chunk number 17: msm-manual.Rnw:1233-1237 (eval = FALSE) ################################################### ## cav3.msm <- msm( state ~ years, subject=PTNUM, data = cav, ## qmatrix = Q, deathexact = 4, ## covariates = ~ sex, ## constraint = list(sex=c(1,2,3,1,2,3,2)) ) ################################################### ### code chunk number 18: msm-manual.Rnw:1273-1277 (eval = FALSE) ################################################### ## cav4.msm <- msm( state ~ years, subject=PTNUM, data = cav, ## qmatrix = Q, deathexact = 4, ## control = list(trace=2, REPORT=1), ## fixedpars = c(6, 7) ) ################################################### ### code chunk number 19: msm-manual.Rnw:1316-1317 ################################################### pmatrix.msm(cav.msm, t=10) ################################################### ### code chunk number 20: msm-manual.Rnw:1346-1347 ################################################### sojourn.msm(cav.msm) ################################################### ### code chunk number 21: msm-manual.Rnw:1359-1360 ################################################### pnext.msm(cav.msm) ################################################### ### code chunk number 22: msm-manual.Rnw:1385-1386 ################################################### totlos.msm(cav.msm) ################################################### ### code chunk number 23: msm-manual.Rnw:1408-1409 ################################################### qratio.msm(cav.msm, ind1=c(2,1), ind2=c(1,2)) ################################################### ### code chunk number 24: msm-manual.Rnw:1417-1418 ################################################### hazard.msm(cavsex.msm) ################################################### ### code chunk number 25: msm-manual.Rnw:1427-1428 (eval = FALSE) ################################################### ## qmatrix.msm(cav.msm) ################################################### ### code chunk number 26: msm-manual.Rnw:1437-1438 (eval = FALSE) ################################################### ## qmatrix.msm(cavsex.msm, covariates = 0) ################################################### ### code chunk number 27: msm-manual.Rnw:1443-1444 (eval = FALSE) ################################################### ## qmatrix.msm(cavsex.msm, covariates = list(sex = 1)) ################################################### ### code chunk number 28: msm-manual.Rnw:1470-1471 ################################################### plot(cav.msm, legend.pos=c(8, 1)) ################################################### ### code chunk number 29: msm-manual.Rnw:1713-1715 ################################################### options(digits=3) prevalence.msm(cav.msm, times=seq(0,20,2)) ################################################### ### code chunk number 30: msm-manual.Rnw:1717-1718 ################################################### plot.prevalence.msm(cav.msm, mintime=0, maxtime=20) ################################################### ### code chunk number 31: msm-manual.Rnw:1852-1855 ################################################### options(digits=2) pearson.msm(cav.msm, timegroups=2, transitions=c(1,2,3,4,5,6,7,8,9,9,9,10)) ################################################### ### code chunk number 32: msm-manual.Rnw:1980-1992 ################################################### Qm <- rbind(c(0, 0.148, 0, 0.0171), c(0, 0, 0.202, 0.081), c(0, 0, 0, 0.126), c(0, 0, 0, 0)) ematrix <- rbind(c(0, 0.1, 0, 0), c(0.1, 0, 0.1, 0), c(0, 0.1, 0, 0), c(0, 0, 0, 0)) cavmisc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = Qm, ematrix = ematrix, deathexact = 4, obstrue = firstobs) cavmisc.msm ################################################### ### code chunk number 33: msm-manual.Rnw:2020-2024 ################################################### cavmiscsex.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = Qm, ematrix = ematrix, deathexact = 4, misccovariates = ~sex, obstrue=firstobs) ################################################### ### code chunk number 34: msm-manual.Rnw:2026-2027 ################################################### cavmiscsex.msm ################################################### ### code chunk number 35: msm-manual.Rnw:2047-2049 ################################################### ematrix.msm(cavmiscsex.msm, covariates=list(sex=0)) ematrix.msm(cavmiscsex.msm, covariates=list(sex=1)) ################################################### ### code chunk number 36: msm-manual.Rnw:2096-2098 ################################################### pearson.msm(cavmisc.msm, timegroups=2, transitions=c(1,2,3,4,5,6,7,8,9,9,9,10)) ################################################### ### code chunk number 37: msm-manual.Rnw:2144-2146 ################################################### vit <- viterbi.msm(cavmisc.msm) vit[vit$subject==100103,] ################################################### ### code chunk number 38: msm-manual.Rnw:2344-2345 ################################################### three.q <- rbind(c(0, exp(-6), exp(-9)), c(0, 0, exp(-6)), c(0, 0, 0)) ################################################### ### code chunk number 39: msm-manual.Rnw:2363-2375 ################################################### hmodel1 <- list(hmmNorm(mean=100, sd=16), hmmNorm(mean=54, sd=18), hmmIdent(999)) fev1.msm <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel1, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, NULL), hconstraint = list(acute = c(1,1))) fev1.msm sojourn.msm(fev1.msm) ################################################### ### code chunk number 40: msm-manual.Rnw:2642-2643 (eval = FALSE) ################################################### ## help(msm) ################################################### ### code chunk number 41: msm-manual.Rnw:2651-2652 (eval = FALSE) ################################################### ## help.start() msm/inst/doc/msm-manual.pdf0000644000176200001440000136465012774212430015353 0ustar liggesusers%PDF-1.5 % 3 0 obj << /Length 2277 /Filter /FlateDecode >> stream xڭXKϯ#F_<;wE PP1_| G{}D*Je~?>{Hut2<6*g( S0mk#X{~l'kQBƓp]*\ߪY*4BƝ ff*Nr^:0h*S J8] Z`0bծߛaLB2R)Q>6]n` qEGR$E #3h{%Ȥ;hNTiY(X=Z2.ԗ֨UiwqRuuRUo"&mF/fg*Ra?섅}Ti49mDJ mu[߅ C;WLydU?`z{_硯(l'[7ֱ|6EaZv/_ [ PE[x |cF3X?  .4Tu9MeٓQ]d86r22ON,FE NnASxT±GRī8#w)WC(<sU ٧\@>:Tc> stream xڽZYܶ~<[Hd\zP(hde1Sn# ;!kDd #.Ƚϗ7q1I$fY2F_$}%925gjw=U4(cz-x ϖ=ْ1h~λD]LJ6tIs%`SQ| p}Wv:81ko͖`y6Slq-=dcK0;5Es4Q@185=:_āsvX п6̿ W0.&alCHG>?M]j*,=HIٺxN?u飱9s [  #'&f$ ]`,sFh+8tn?{\]x`y!K}wpX,lE  xK=tUeTy&tT轴3O'L%XU )(Q0P,$/$DȆFݰTd0ǑSC=ؾQA|'uMmr'/5$~h:9HLAg&cƬs~ z?6y8ϣx.~#bUGj' 9$1gGGI)f+~Z͠}mJ~f,rJC|rA2G=x&NsA+X"Y-| LDb9*`eTB ɥS2Xa~寝1 X cH ˣҧ>mvÄ^+$bUY&ƟsՃMr;cU f\O@W\ظ}fA_;cLڒ2jʙj9' pLu&5ek,q_st!njM=0#?2 ޜ@\q"LM;w{xM3p쁡E\a+BaXV98kDm^pYuޏ[뚓&A]uh#]Y@,U(5jV@!BS x&$sWHx |Y JnJ$*9~ 3VEl #t[n[ܲ8hT# t{PG\dCD [wEs*k[1mKgp!D { s>Pt<:p3w!3oQYQ:+},;jVLOY8OFbqH9q1oAV]89+0gJdiڐH譡y?TMd(9Jk[x?WDW-Mǝ~/wj>/F^-[{C]M}(Ul'raf&o7yoY ;T*1#wYJCy5~.C'#aRǙ]6n.)|Y%YFq=9_  ۳C1T]*͹4^+vO&do4<Ϋf/t&VNP IdBF[V Br7 Xǔ@Ph *w<_͋F uGY;^RZ d DKp9Y EP/g)3>s&@;B 1@OIg7-K>h (4j68fYg{mn1 e.]x ..qfQ6)H')7"nTd:y IK7Dʱ:!d!,=ІK'&geNC*iwǻz Fc 3^``]Y&ic<κ#R>PIX&Tc|6>\ifeKC1"}9~hyiCây{IdprX-?n8şn endstream endobj 25 0 obj << /Length 779 /Filter /FlateDecode >> stream xVMo0 W̊"5`n[܆5-4͚eN4N+zHꑨ|SE{9yw! ҩ:m`՗fM5[gg݈C7#fEǭǤ _;-jɑ=XIxVʲO-Q!=$5QhK`X2hVƢX\j<vxMp2eꅋ****'>.{ ցp1WXT I[ %ӆP|WwI|{\4ǫ^kA?:{( Bܻ 6erznR;0ro<77)KM M*w8փ;0 3Bz* ұcXjk*Χ~Z+(BKjRw3}P\g*ruJ07"02 X?޻SzNZ"hcKCܕ$DMC+c\1\9q\1.'"rC#SLj#vopтd pl'%^Le{iǠT6n~0'Z.La̿4U\UFH,צ8^tZެiq̯6?z,V[r̀bq/pi+ endstream endobj 13 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/multistate.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 26 0 R /BBox [0 0 263 254] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 27 0 R >>/Font << /R8 28 0 R>> >> /Length 1020 /Filter /FlateDecode >> stream xWK'h)zG!i8HN 3+D{70_8׶̗hxun&ᶬ/yb-s4ץC_Lb:/ sDnKf~ЭtMxF3hU!;MP|T@7.fG.n(n Ь 8\9R9v4BCJkH؂b~W`#a)s"ͮ( ::p!{ӡ`RY29̫ebZ#۵2*2TphH8#LC7zQs}87܁TCCuvڕmt+(h U3:\AKB2$*(J VTgj/?tR޼t[|l/b%;tW1k5VAH{ӎ6 ަd#x-/5$mGD+;AѺ~QG[y *gvƃ"=,S@>1z'`9:Gp;{QMer,k j:}mnCdקuTx6 zh&G>)N\H.Ҹudhd3OPhw)Ou9F@k5'`p5[l6ʮuTV]IsQE񃗉; *C6Ub.$ڨakbc'O"1Z ?!JղS^f{ TFB@}#rnO$1*J_ph9Ry>Kt_ 7Iݣ1ȍsMqKS`,e+sK,05,lD: O[?fvKz2"$Xn4&}v?}ijP`x^dwm ‡\X>T̥-> S|4r\~_} |Ao_J endstream endobj 14 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/general.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 29 0 R /BBox [0 0 650 218] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 30 0 R >>/Font << /R8 31 0 R>> >> /Length 1231 /Filter /FlateDecode >> stream xXKo6WXF #=w6` "EPyP$QUgxQ }64A @JAΰ2Q5 *dk}Q!LaH15FT0R-ۜc\y͙̌ml)Ml,$j򮴚fvkl&&9MKn5mZMAY&&EYvɖaXJPn -}.1D]⫩(#<Ă/= {qk$̷>pQLj$(9\J~BSs p?aP8Yx L6O)e`dx2LOrl GlW gHFm1n.BHiM4=qr|\g[FfvX׺;Cmf]2XklՀNa [muޖ=9v[h@]46/4 eئk]hk͌!?$Ůc .MBa [muؑi''X)C:Th%LG 8y Ei&*\븀kw 6SZ[Ӡ59~ YIʣ)soʰ͔ЉاmtK>FX>^fe&*52l3eg]}6 . :2 izGSwT $2l˿4ܝԻG%E/GqiROÏ9\{dn>~WwY@?oEg;C Yx> stream xڽYK۸W-TbH$䴩nR[9"v)Bۍnql'\D<~~hޥ <̋DQgN?!#C}QԪǿ?D8ˌof/#db d 7Uk$qBwFD4>WkEQ_@ 8Izͧfr M69Ǫݻ׭W0 ,/ 2/aFd $h!l 7`jҜGú۩M l0_UDmWk9;\6}c}ES|`5dI];ҍ%NaV`zwhB@aN4\] UY"1ṳ!|a˚SwF&?f,b&aRG]6hY,V-,НmZ-qiʬ*zZTMזU {2s۶0@၎ֿO5KAIyEx)׹{jL=L]W<^踺 fz*8/5Ӎ,YEY6`#MST,X~H\xE Awtb\$xr?{Wd|ۯ# u" @?:.f@Ro=h P &z="8-dre(W{cjx&aj"!7rɒKK?Lb}W0 !r#kץ Dk: [U !QF'l÷g~Ad|csQq9GA8d}}d2Yک--;CYkMOIKIBuhb J.˨, dqk9xA&Zq;ڜJw{kGK 9LKnWW ձSWߖ`'.̏{rT2΃uiDU8\1NsUuwRTԔR)ŋymΏTRĠx|d߯ˢb f.X:Ϗ2L8I(;'Ȧ#*揮:;0:sEe=0MKقӓ IG \ aUp͏+LDh6?bNoՔ#I5z"3qU qAy86m+X&n.`z`沤~Pz "ز4B?fzbB{F uOV4:ՓjLV|O<;n ȖR'K{R,^/;cclBA3XFn3q8)ɶVˀʽ?a6h ޴%ZQ" > stream xun w?=@1X5ҭkƒZ:qU %+&9LHMs0\,A!z3 U(gI^\j5ndwPxG MB]@QL!UKC6"|ʨbO:,^}u (F0P@T1nxFM#2h`y\="+D_3S7,s.r]5v`Ns=?- ǫߣk|>';^3Sۢ[FT|?JSƇkՋ) endstream endobj 15 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/illdeath.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 40 0 R /BBox [0 0 110 103] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 41 0 R >>/Font << /R8 42 0 R>> >> /Length 596 /Filter /FlateDecode >> stream xTn0 +tLTM=)>5pm @C|Hw"A<5$ghzO{Ϋyw n{dhޮ;!8>RRlʔE`Ĕ fX^ FN*X2 -{Ε4|3GN.XLZCŒ[B].IpkaͪlS>KB׍A%A&lnOq<^H `w=Ƞ ˆkØXCDi,]Z&#@M\ƔP]Yiړ&Tz Ddy -7PTtFZ_Jx^Z?^Met  PjOFhtċ<×xwL?L Qo(G<3twwHk):C"1Wm+d9 C>Iޣ.m/g9aL|OU̐v3zI[&&G˹)| ,X$F%D֬QwnVES֗ҝR[,$vc>_ ,b endstream endobj 33 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/sampling.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 43 0 R /BBox [0 0 360 720] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R6 44 0 R >>/Font << /R14 45 0 R/R13 46 0 R/R12 47 0 R/R11 48 0 R/R10 49 0 R>> >> /Length 487 /Filter /FlateDecode >> stream xTn@+ mvflq@ ÅaDB ')} DPS8o?-<WlSvWtxM]$}ZI-J<Ɨ_W_(H4*^=Shu0>43-fۙ9d~p<ँ?2>yMXXZTGqAghJPq CVEQq`2+Eŝ5+> stream xc` endstream endobj 51 0 obj << /Filter /FlateDecode /FunctionType 0 /Domain [ 0 1] /Range [ -1 1] /BitsPerSample 8 /Size [ 256] /Length 12 >> stream xkhD endstream endobj 67 0 obj << /Length 3115 /Filter /FlateDecode >> stream x[K8ɍ9|S 0,`Ij-D<<[Emm'=bQUb=\O/Yb5׳73&1:iejf5{;o>oyq؄X_^26$Kb@ CF3"("u7АD3d(gsVmY,]UQ}M/9qԼ6+ 2^NkW TEXZ;vJb(-#V5KnV00" Pd29ƏfD;DHh"`迣F(uD AT/`65Ѭe@)L.epۺ PvhL K^oT@%=W;Gg *3bnBEU= wEtG,74|UDžiEl|jKFj3^! ѴaXЕ ^f})+Ԛ^#О7V:n@3%X;&Uv}˦]>pVm+-˅TzX+IG5`$cc ʽoYíFO\ꇈڔ$JJЉ"KNPcʢi MhhJE`bB@F$-e ď*6 6ԏyGIlۙaa[lF2t.+xS+RB2j|ʪ宪_~.7aweZ( @~Y62ur_9Y:CbI*]C:o=84ekL<n$rlη ~oOF$L5SfT Lv:ӓ>@1;Ql7n4ח KU{`~lռ ۢnw4vp`U#jV)'!LJ+-YAU{{i~4Pw^360U s,y3&Ta* uz`|[\ii{cO,BxR7ŰҹhB Z0]vnp-ݲ@!q*/hT4=U st"haᗱ4Pt"iF' ϵb {.<x12xy=T|<8aAp:(X31;7& }ARP.8\h3ś/;1Ha]a;TZ/޾.GAJqnr.ߎqtq8l >'<:#2JvJud#V7ڜ)9$ܑ(%(ǰHvRP'Eq> stream xVM0+8L0ŗs`3 ֚r]'ΈuUby_1FOH1AM c@*}1PX \w3q! FTYFjr97.S6+eȲc~nʦOM?SLxTy9O>,O[^zH!E;0`lHr,"BPΌ0З\ it[WgOwݨ^`zش>Lh 5@B:^(m{<2>xNKҠYں4GGB3xh)֯+G_9t4(56wiTrN-}$d$b>\/:7! CE;5=>>> /Length 135 /Filter /FlateDecode >> stream xMA 0  {h%; ΡPJ KvGK|b}Nn/LAېWWE܉\#K &,@LKӐD"ATC7?- endstream endobj 53 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p2q12.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 75 0 R /BBox [0 0 171 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 76 0 R >>>> /Length 158 /Filter /FlateDecode >> stream xMN;09slc''6r Ƒ"HFp{\a*6v)tBƸ*p Mѧ 3MTNYU\GNc.*<~4.! l &Y&I{<p9 endstream endobj 54 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p3q12.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 77 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 78 0 R >>>> /Length 182 /Filter /FlateDecode >> stream x]K0 D>,8=k(f "tdrze8]0> .) V=J{ٺÿf`y20JZݳew8@qPڰ8 >ջ dZ|MP(:Y~ث.BLi2k%7 ,qb?V+Li endstream endobj 55 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p3q14.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 79 0 R /BBox [0 0 284 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 80 0 R >>>> /Length 175 /Filter /FlateDecode >> stream xMOK1s . \Iga"V'M Cy#^n0z_@x)Y Uߘ֘i O'a31pgh7p(%hpI(1 㠖úE(trgң zO`QmNNPgl8_.*,{h|+|G endstream endobj 56 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p3q16.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 81 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 82 0 R >>>> /Length 176 /Filter /FlateDecode >> stream xeK 1 @9E.4/ \G: `v>>> /Length 196 /Filter /FlateDecode >> stream x]M! =E.pL,OȌ!/Hy_t>83,WTB;,pp-aϭgh+ǀhZjQ|w۠V۔SK $/Q?TڳPe=RUF#WI+EmL ?\u~c!7,.X endstream endobj 58 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p3q135.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 85 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 86 0 R >>>> /Length 203 /Filter /FlateDecode >> stream xU;0 w3I'`BKqRQUU>8HqJFpd .^0{s5gO1yw0iMKmTw{pn%݄$(G{zVx4z*]\UH"ȑľ3.nX2v n9(Ǎj=^hZV endstream endobj 59 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p3q1246.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 87 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 88 0 R >>>> /Length 233 /Filter /FlateDecode >> stream xUQAn1 {H6`6OԴPRn`'7^?4]7`z4ULw(j`[rjeAT68vg<{6$i2SYr{Fw(1]g" $pq~ţiK%}g]FHx$N*{ Xm2{P־\ #1I:=ᥔWp. a_,ZUEq3a_Ezu8+^g endstream endobj 91 0 obj << /Length 581 /Filter /FlateDecode >> stream x͔O0>T&j#mO[6!+$ۄT귯 ԕ*Ux~yX/+%4lcF!3hc-O\z!`( UrS/~.@ӶWL]||d7 k`M\fCJ#4Őϳ!wT!i6q)kS BʗӡH32LjRtH'ٱ~1h8Ƕ-X_(t_ \u(, e_=>c"눚B8{ yS 5C)}D zR8@|!Kת}&ɫ*y-) 5: ܱ_"iOei40wUŇ0beƂFo QDhLcE-M G\$Ǒs܌w4!;l:R瘰 7?*1!?'2;{\( 7甸sC]:^;>pN#^ts h7:oAK}u"4N#8@ _hQc'Mb) endstream endobj 60 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p4q159.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 92 0 R /BBox [0 0 398 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 93 0 R >>>> /Length 215 /Filter /FlateDecode >> stream xMP;0 u ohc@H,:i&DRI|MKI/Iz$N'Z{w.Cn$JD 0HanNwR-PcҜیMU-/4eѨ g&V-Ϫ_b8[  bX'Ŧ{4 ݴL`{Xclg:?b endstream endobj 61 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p4q13569.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 94 0 R /BBox [0 0 398 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 95 0 R >>>> /Length 334 /Filter /FlateDecode >> stream xURN1 +|~=C?B/NvzfϟQ QDx1`Q nK(2M "Y5æGܱsּnȢ~L5IK1QNj_/*e>UOCfxpH;f`2*uYZ ,f 9K^CcS0Μ-YXV+侇<'8&osYT} c9 HJӬ;Ƶ\Effﵗn)̴ϥVW.qjt1$+gy: endstream endobj 62 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p5q1_6_11_16.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 96 0 R /BBox [0 0 511 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 97 0 R >>>> /Length 254 /Filter /FlateDecode >> stream xMQKN0 Y&=kxԷ@_${&I,7t%Iw+i^{zZ{|AI_tdN@ F9HJfCmIK3:4''lHmƹp* Z-By&{Wy@'+2e[qq۫^a!΅/3" R,º1%+"fr1 0ԓ_a!s%3afH5%z?(B}] endstream endobj 63 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p5q1_4_6_8_11_12_16.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 98 0 R /BBox [0 0 511 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 99 0 R >>>> /Length 390 /Filter /FlateDecode >> stream xUSIN0>saĦDǽ8hR\U^#r^{KJ~N8z).rz{LgU-bVJH]1!f=]+88 o5(Pn2\պ͓܄V/XX_"qиbV 6fK)V=͎WlКhj",^bssqe Z,DȕBŶң+6Nh5j&Pܜ5l4h>[G,qfkb(D< mkUuj9n\bulĹAQ#Tq+FX>m\1.$11y_wf-=֗ݻs^C% endstream endobj 64 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/p5q1_6_7_11_12.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 100 0 R /BBox [0 0 284 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 101 0 R >>>> /Length 279 /Filter /FlateDecode >> stream x]QAn0 >Y%;/y [lY3EؚdH'W }ocxB27PbQ%O_p̄naS#LypeJGX%`ڸp{QcǗN02a3<8ݰul [KVjg<8S'x.ɗZbAi \;%o1z[+㹙x-Nfk,P?, 1Ɉ@\ӄ0Ӝ^ƫkʒ: U!Fkh|V!?ٕ endstream endobj 104 0 obj << /Length 3374 /Filter /FlateDecode >> stream xKoG]M9,zh7 Eh^H~"gݵHы9~~o7=WiAIP~ueC5.ն޴zIh&|vG Ujb>,۾G=LE;N RvU}>m_9@#@*PI3Kq$ uuvN$YSTx`C>]/iA7]t]qɮ#yn̹G.uXM_lMsG(O H wS .Cw-jDǿ ^pi5xJ -r\+0b%A ΡFk^b!ߘpod0EEziC+L D Hά LGUusط@潛rS@TOǫj:C ss3w& )B.4FF^h4鏷FוQ zx_5UdI^ۡvp׮k3z8XNMNUY>ZM ږB)cssX2spN.Q/ Top@U#‹BW0~[RpRFC7CW^m<"Z `۹Wsw] `uF^'>ʅ9JC(Nh8zBY@A)c6JE]/*Pf Gǜ O){$qzx;'_ӳg)/c}vKqZܻ"b_쪏Jݑi"͑j]c?>)0Kk!s;a%LC#*OZyIr_I}̌;xnQlqwnhQd0Ci6)!%ţD#Ֆp!\hߵŝ2\bv9PS &Zq!K7;,),lAwޏ^WY{o)/yh~k oR*6L :&#vojK34LpvC^ b8b^P{7d]󺝁ŻGviX/gj.,G$ IˉFm,m#3!jvbJ12Uroz %8(oG` oo kXKoNpbSqKK/(D6Њ^8_)q .HovǴeWѥY߼9$Mƀ}|{"7.te21=Q9lr;|soJͼ5SZ0=kVI.DXL䁭&$Pj&%֖< 8pPY((P={m򵋙7(}@.:YXe:."uUGoJO۪j&*t\(g*~ȵ!-&%y%˨Bj gZؗtzqM(VZ# 9].lswkڰ=l]gwH+.. f"7 d̘tTv;ei%^r/$ aOPxFi^:E!St1J*/ͮ4?MGFKFn[rcJ8c T_HPy*"[Y:۲q1c-aidLQ)h C-14|#ZXv6ᬝ^.,Ԯ*;34A,jލ.!eERNWSþrs֑k*#GoqnJE? FW[ܢ ' sлb=r.b`DI-1Mַwts.(z^6ڗ] ]Puof"PƾkB4e_mMڔ)`,wïux3'6c8XӚW<'4m20E&Fs@RQZjccX g\NHkGoom?e"Pjnؓ)e3ÃU m| wi{?b3(# :'.VlCWVUJGpQT)e>Q -r׽.ݬh+k٭Vo5s.h;RS?qYX`zekRj^4*vɇL CQo\O%.߇M֮SF=k銙7/s4,"Q}w^,(n2eh:Cg8LlާE|n!Thp/i]1YW6M]to{h!P?t*C@X<݆j:m5@L7y|V-{gN`ݵ?Vu: :F 涓d hwBXmFhfWFX/4%g8C^2$fי"5]ROXqx6K0YaE*o`\okg|;0Y V,6{NZ&2IX {>uE8ı[g>21"ՙ1Q3Su/т34-^20ㄆY`( \0BtڷޡulaU)22 NV (YGtheI> > stream x]=b'UC i zm,Id[VbK$wCJDz//EÙ|'wER(I~P7PUծ.rYtUC6} g>i<[=5:`"kf#pٿ_l7xt]za,)2]W7\Jb+A|>U8/á<p1٪`4{[E!>o|Qd2v /xW5}U{Ke|:%LGpHrPÆ*6\5}DrgHtbL )C70 X=VMՕǣRHB]xf٪ rUˡn{J:P.DzWY`_OŰ4G8AO37U1c0?_"܍lWC#w~ީȅ62*PYGT>*Q<dE%Vm2CK=[ X[ڋ5GDl_Hќ'*s`˘:naRQVN_8^$\YFLXn&EKL8`bUh|zGgWz srg,ɹĎ.0㳤G9QX_l!lrj~s.CtֲH/%m\D(Rph,'kHI%n TK_%|uրIBTnA`EnR+Ja46R _MSF$( Uܧ"Kҳϟ%9ˮG 9k0YjlQ't-c2Ik0=Kؤe_.HwB4LȮM߲ⅵT3?9:W:3䷈E0- Vh,ِDҰt)"Ɋ1McaK09D+KnkR"5}BOlUآJ cH 6X`%&#,KV_3<[]W(!Ytoաs%zM|hZhp4^_4z4єsyhœT$e;HH25W0cy.Fԅsמ]b I&X>s*hErʡb%]nZPg-KXP茍jYԆMhwBRjIܐ EU"3ǬeIٕDX[D1AJmX;SC]I^@vU[[@veCokkr= 6f&Arw6;e7|jӞҖIby5(BLR[2,dy%Su&FӋG`JЬ{Pjy(B*-6XJ 8W/!"Teo.V}`' Fە`1rmv"& ټ8q(xҢy:TQCsc@fn! $e5ѣ#00f  op3'=8K˘σL0ұ4Ivrem4u}eQ3Pe}[4.@Ӑlߐˆuة!`F_>686\:ɲM 2[e XQIm֜D0TV],Y0h:`x6`oʮ?8|6?0SLu֜轔Ƚufd. <]¹[#|s7`r5F2׀+Ժg$ģSؗM􈚃#տF!)!T`# pV1M+*<=,c{sT`]ʽs'bfס7rn9;m")yEl Y0ag >gXrHb-ViJ!3_`j ,*WW@LF7LޓM 3k$ =BpR*Vֳ1bJ(ƪ̤?^pZdruEƾ ީn Òz4[}@uעgIDG! _H11ounx9ͬj_f&]=û_ߤk!Gk2EP +Hs. /ٍӠ-R1Τd\b2ϧ,jI+NoyA ‰1le%s$_Q\[jQ؅4+ !lx:+t}Weol?a1 1 Fmϭl*MKظ.zE s (WݾB3% aPm[, tc$cGdPVJFs{ƞasz2LDe*wl P@v`8SW;tz$jظk/m>w<. ?ОLUѰK\!-쫣3art#Z*ruXgDfG2'b'44q8 K8`$ϒcNFw_{h9)$cs, 1|}f endstream endobj 114 0 obj << /Length 1591 /Filter /FlateDecode >> stream xuWˮ8 ߯nqm{v-fvbP (7S?z{~EyYX(yyz!MeX*_lv8Iu^,l$[lUEOmC88ݾ7`;aj`'A3`ƃ V0ʂF޳8eC__˕^c`1t|45}8LsWe?%…ڐWKR,UEˍ|#(hڈϺ^YБLs>D"E৖ݨ T3ָ8Ya4+$S@_ #||C0 }BaVm(*-`]!tQeu k=R6&k^վ5:Il_tCn,籷ۥi<9C AOkMP3?CWյ3}*8wyIx+$oQ7 iꚦk]: >7I>O)6V@,)'cƶݷԩTQt5J}az$:X߭V,M[F|=um50dl-.U^TO#N]n_ƞ=hL$HG6\@p]ba?᤭LfRތ2 CQ[IPq(L٥+׋C]2 PܰIbM}QOգ7t'SS/ V\3繁#aR` Nɡ)G>Vrt@o*w++A74 'Y#FnRِB o# _MǠW쨷G$x9yDbF\\>I"\{!F%0Ž0R.!J QSR"81UO)9 JKbrIG^&SGg0٥ -|zѧG xp>xrSe<Z> ޥv'3*;ɝJ`XxoСJX!aZF ERa~+1oD&y0q(,y<Ѭ,Ejڜq1M]8y@/vM9}zkdZ0)n`dX=܎)ƋE Z-(׋yL>D~_{|xBx/+y5~ۿq _;UfA'j Mm~.s?бK  *f2 ~yQ;h^C4Ce Oc?R endstream endobj 111 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/figures/hidden.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 115 0 R /BBox [0 0 360 720] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R6 116 0 R >>/Font << /R14 117 0 R/R13 118 0 R/R12 119 0 R/R11 120 0 R/R10 121 0 R>> >> /Length 762 /Filter /FlateDecode >> stream xVMo!+8R2ǵR.Tn\Me-%Zw`5%VR}7?J@)^<{nw=zZ>Cک]|G(! ^~زX (XdX?Xm~[oq{AʻG!12FvxN\N+چV[J1ƙVz` 3Zccb"ޭq,ϞxIZeB3"uqatSB;sN ex5TysΆW$ ARUtϰi/F6<ۗ`kx& _K}.*.* L r|}d pVǛK48xC8G@x‡#*MskDbF+=Ao R^ۤgљ^2ZȶPq8#K.Ei5{$-ozzSB9~/9vSvA16qDRD'~WHl,-Ƅ+y/үdL8ɕ~Wul2F_FѨbvu06x1⻂KOB}Fwe> stream xc` endstream endobj 123 0 obj << /Filter /FlateDecode /FunctionType 0 /Domain [ 0 1] /Range [ -1 1] /BitsPerSample 8 /Size [ 256] /Length 12 >> stream xkhD endstream endobj 126 0 obj << /Length 3521 /Filter /FlateDecode >> stream xZK6WR%@`&)o*SPG-D~SЌƛrAww2%ZKɌ &d.>,9ӌFҶZXmCtoRknz %|ocXV!}~ieţer4h&<mnڴ/>w^*'7Y{4y+o۴Mpd4}oӜජƏ mS<ۼ>r7^9jbRSCz =N'2E M69<ծ΁L'wa:7gK Ms?cZnirn?uh??흒Dfd0cIldeߜEzFH_ee63p KvWǼ-t=m>YIBZ5Kпm&`f`hrؠb6Ⱘ[G?$Zhiq7JFqXN2kn64O;ðHcHߢ+/X:,JE`b ~@CUK<6c{& y%TJѵ|ۓvX2%l<=7KaVȎoQ4gD3V[WU\/19-xm[j"npR-P8oQ}͙PM)`"ot{qƣIdL"`4\sv~9nuȾDD&e/c>և8IH# ~gX+ L%"#ݍj̘~CS0)uRzlⅆC,V!k WfOs|mjKu 950nf1C(LIgDQ2v@=Pk"^6~T` /t5)[ms,$BXsU SY$f0#hϥfxϹc%= [rQn J=Z\Ҧ^1xƍ]^u[9ۚO3r|цPA$)M֊w@8;n1KNfac(nL0ĝb)1]N x4rI Q&T25ObHE 'xY:)0=4q qujAH0%_CpU2aiڤ%5 q﯏pLۺ-0oMD2`sN0oLR?,c352РՀ*""Z}-@am}P;'.TA+H30{8})hp<2giܦGCC0FNKXr@SFdk ]aal `qSM0`<hO3mDn.2c7CcE'8/z+Lz^y r?Sr1RD`҃`%W[xRSs8O?K=KgA<2[hWoM ja Osc;%Oo}z:Oʋ<mJDu Ldaa)Ia9W,>C+69f+8*sJ⨾dh}O;Jv,`|Rf~AhYT]8̃Fױ^$㮂V\ s2P8u!‡L+OC6K\@\J#\1C-V1r5^uuI:.K~rI[w!i9==<5MCZu<&Ph<hqS\͐^}{WhHƕ]@ƋçhՙxtC aYpW?z3璒)^ÀroBxBP0- EkLjǁm\uyUo >Uؘ;& fV!5}#1oB~ ˜bhha8P"1$hTtBO.B" CQ7D*+m`dI~IR?Ed;s68 F+zb+1-a0cΐ.@,&uu֢(ydNhoKQt ;}B+2JKJ/h_C_wYU%S,cⅥQȚBv@Mtw񎦆`AQB'{B<넴%=O/$-j._ ؠ9׭o)>jkRL:NT; v࿦F2Y)ŴV\+@@Yb=kB0+Pg0 ٨K2<iݩv g75ܼprL1B'/=n>bX7 3H"x΄V*3gܡ)HE;Dr#$Y&of,V!]Le '$_z嫥l/<fb.C4_y2)9>&g Րs5GoBLukr2yTqz}>VtpzK(` aZ0M=yzQi|rTrڕK=dLaxt# !HrGkDArc6B.*Y.ؽ8zq~ȻkaW#uw5{᫷8x z^q* oUA7AYnכ4C}ulDx; "OU-fqݕd%z~lP VE-YBϢ}EŪϢEcWH%eU;j0ŵ;r]áWsw ~HzS>BUՇB"$,kO\^cw܊աϲLƵ ÆHNveT)%*MfD'' Dfq| endstream endobj 129 0 obj << /Length 3445 /Filter /FlateDecode >> stream x]۶=ʛP C2I:8L}%,]`H,L_Dbo0H&/o.hB E׫W|s#t5p.R6|8F r͗&uEgtcêleM_7+lonmW]e_TK&EUf+aniM ]}qK2uqE)1¯{wBIc&}[m۶Y}G.Ԁvhmw[uUblq?USok?w庬Kl~34~1Rʼyό%/zT$vbƽɖ(q6* o:y[4"yo8YvJhO6bT.bK:ɍ#.xY [EcW6ͪgcٯYtEf}OGi6~-mQ-,բ@UiΫuWEևwS v e~bWPu{)I鸏.$|K!nplu׵/$2R^~$FqmI4,d& s Sbr.uEIhA~S0}n#pf 4 dT"slAIYSc?MnJ1Nls"E0Dc 0ҩ|D0),b.CRR"$0լHlqb[<4RbwL^Fw1M)G0Lg39z&ؾG\q*Ax9a:\-)μ$n-PqorT`5^w@cmu#n~퇰0uwlPz*I?Mjc$}6ٳ8Bu}iFj=_{BF,Vhy}m1ZneU-Қ8 0`B.sPY]8M5&\e`DḾ]km{)E,BgáO nnx$sߧja@|OJΦv1unrA*n™9C,Ou s8~DŽ ?3 )TO{:\ơI2 AAFRc[ϙN_h[­ c ,{V~~|/cZ@@Ά:&11 "JPpȠma1F:10m5&6)=SeGfsܔ[ 'bi{#mSXZOTa/Ha? þ:eq1e$0_J4aeN4 D*,I}qJh_=0|D陥/;8e{GHJ ܨ{U)C6, H*|^4;{3GNæk(QՔ&[z\>!~;uX>|HY)  ?O~ǖ ~BczDEhP tM26uXa5 zIcCZry>>ĉHS\Eݷ77bLdK/k6qF>9 /1+1Yq ̶`ۧTybPjLE)S. gOfp2b׬L>LV)U74yQĐiQظyo"i7GzQ a;sB*V#{jml↪`|*jMޖ5lgK2<*cm>b:{xt,QTJݱ {D (me6C~4B?g$ΑN'F`=Ŕ͎N9տ"k*B$ 8TH Sqn/q_6 ,2H= eX\d'-)Cp{L]4ϩ<*4)Zr1j",xy/lwJ>)#DNŐG&^]. bc=A*~i)nZحh[4]?Ҿd:4t\%=莌/ט_qX{,C)^N.nȶ Swͦm{-C5;w[w<;bȣ5Au %MzȡޕlYJK8N율c+ XlTlv8bSyLؘS8N5jiwQ '?q9X-((Ky_q ;'&:M=nvU_^ [,|']k,h:N\W<Уe_<ԝ ̖{X,="> UF$ #v;r}x=qO=|%+wrF2kIiof[ߗ4 Zl$N#`R&y[W 8u8'1,]Tӣ(B"8*p[y8i 3~zu S5Q|sn fnswpv.,w.鰭@]u_@1YEo_n;hF׶އK ^M\MU ;'>wm6]4q?``'0jOoӈټ_}G+ endstream endobj 133 0 obj << /Length 2978 /Filter /FlateDecode >> stream xrUT 0NRʺl ŗ C*|xw>hC0+!ݍן}BVڋ s_XTzw*{ڻRKaˍT>a]9]vP LV5Unfr^Fa_PoC=-ͥYӈC+Q-")U퀜/._l`Cq9m3\0ajj?Kjܶ݁ZU]`x. /#dM5  ?.+@e3]ǶLq49JQkbF4wxǮs>ೈ8(˳~Zw׵Ժ) }zy~Se ŷ?!_pNy4]0ifO*ΔĞ9b4w(LjGkn fMn}TN+2V#N c T5;j7upMA.’a Ъ~ h_%m}OE-~߁@esUL'ձ<Kcx?Ww{6(Z!tUqSv,*+A1RQ5AAAjc=ˍLiGPn Ёznɍ= E#AH #6(; p%!dW"Zvllhڋz_v%ZHI#nWE~({-k*zpG%nAN̶-r_vqIc+]YQ)è]HDnJԗ_;HnZm XHR)`obb2XnrH`V1o\#EyTk\D}YG(UYZuY۩4Q7ؘ͔TP9aT XGb\b:e kYuD+s.Ģ`4:L*eb95g}fԍŽ`3)80M%&Q;}đ6>dsLEju\M@mbM0VohXh-r#,VHJ%C`=B(B7PTg2 %}! vrDH(.!MԮ#fƋGYN 6E;$_L.`ߡtY&!vS/z5#:}PpI2e!BuX8> r6O".*9B).9m EvuQ -@DK Si CՌ-}x)]8, Z[B8& V-غɣ=7$y(o 1u&&mSqvme,<@DaYVѯiwKصVo:n}PHʮw_z6W⩄=-a:!aI2ab0N9t~[ߑo'Y{\d\SO{gt)ާ=D[+hu]+LJ}戻.4kvL9 SVh6g'LQ(@TzU-}(P) ~6$<ċƱ\܅kЂʎ8tr7<-BCpH/0cw)aa9%VO lm?M[&:|@H$I<(BptJ̽|Lf =hQWC- аs8^OBP9Jp**ONnlLAL)8?ҒhI(-A)sr@_bcFʳņe~LkRXVql-:-UVdQ^uLbe,:`긁C\ >q.#+<DgKuؾ--ݧ2,*e볦ŽmD8b3=l]6P|{^6C8ga#n 7 gFs{eF zy"qx-2`#8:[ɠY.saE4ә>OOQPtNQgD;&ɵ ju)xSr9Ʉ󬸩}X\\U.:8]h$l]uW-r|onfW0WC߷ R|<ޤ;QLqSxP>te{bӎP'2^DtyeFCERcIF/˨o糁CH/b{b UҊ_z*X >a>A=P7 lnybڸ?\>i-$KUMȴE8;+?ו{t"\<ꦌ/ws' Y>|џ8.>yɓ8,8 *{aw~" nR6.:#Ob!B| }{k}* endstream endobj 136 0 obj << /Length 2106 /Filter /FlateDecode >> stream xڍXo "ؓY-+=׃2dԵd'(y쉳IEQ$EH//_ɫ;,/tdzUe}WYqwhݞiQO(ҤQ(GUϻ x3V]J{aM)JdGL-oUi>Y"EOhD4Gmz2+{py{q8x,4Eڍ(;;s_vij5$8 \I'143"j>giVJY?U\yR4_)KDjj3a;GlF6;c炥y?o-ьNpe{ׇoROYa [DJw@{Dci&of$%yƽQuW `p)Ð,KjZ}B7UCߙO[YgL9`DbE&^D"1$ N6z>ǭB.HA#LVQiVqV[8NnC̳8r35qa}DlCY;ة(/:trja"!\ B}Cx.͌yOo8!)̰_E.ycm5Pçe]?[ʇZ<Ci8m?T *v=d@]QHSA|qHm@3@}FHHO!≡Eym$*BBhv٠TTd0deMhڭX微F҅j!8w%emfHGx,= ~z78Z#?D윉U0J OzM/69gU sn]=rWφi{"C0IJ)0xk2-7"FoQ]7-{u ©@\e{4totbv`[ƶp"h ޔp7L}xechz8vS͕C^8k~LfnIU!&@hUbGK5Ebz=ҳ1]*(ɳSO` ȓԄO4oUyIނ_a,1b50Qq8;p` ~9iQ֯fT?,۳/*\ಱ8+2#(濝Z> stream xڭWKWJDʩRTQ&Y,1\j 5,yn՟nR(W6zuWf? aɋWg]:{C mӦհUtwS3<_o43pl_c^R+Fb^y$^J.XgҷR#b?մ>o(X`ȭ(Ws5.HhoOmZgO:߬PD_E z?nơȫv~(Հ4UKǏkP"%N> 6\BѵUwi4v{G'3uQxHn$MV pB&7u!'4ڵ,Un|Q|t͸h n\5 8(=eGG{l)t_Zg mـWBL .%ޒɉ*qQKS漰Qn;tրa↵Ha7GH>{Z=jkKfA?[+OUyt &uG} 0%!HZl|pq[7C{W*bP i""TShQ0"~ +}_鉺f 謸4o`ٞ\ 2ks^Kgk4FTl8XA¶jc pr$tL}k B9A4t6{CTX)6>^:#X`Q A5Oe f&`pt1SLT We _ K[w`דnsQp鲔v{ x] C):FQ!HT HÿDE[H>IXX Pbֈ3dJ#*sYQ]^jeH%~#N77/mH8c gYd53ioJ#k)oH$}Д9gK/Iq*Ћ%9GYmH'%0g~.A˨\)@_TSs ZFըLa qW A[՛9aGہ +X[1K*b R0YO@T8$ qP}9Mo!*dbl K#W{dKv endstream endobj 143 0 obj << /Length 1785 /Filter /FlateDecode >> stream xڽˎ6F׌㐢Z }n{hzZ,9zd)K^֛=q473C޼xVEƲXċndI.b0!b]LVkh*UkYQꈸ#!LR] ?[;*1jzJ<RQ鋨⋨'.("{H%9M%2ȭFj-bb7T݊GKsO}Ck7->C՗7ClMocJˮ-> E^eon*h=(̛+/WB/?";fñM٣-R c{7(䴈KSUU[RnSuWMii08qaΧ$*ӱCH#!) K%4]@bq +p="/s!_|o#XtEyM_6 NdN "r!L>e`TU*- XJ$їe έ2b3NgmzCweAt&=y-xߠvd/%ǶNBWz+d5 =͋÷u dHGsEl~ G \Bv&fWVV1pc2yL2F/ʡJC\xIϪGi"*ld$!JHwa~s2-o`"xzs␧@᎖k`[~ohI.@8Y*0xƉ0qJxatCA5CKF>6}kG#r.@qqYdʥ L(ْL(҉aDߎE^vvUͶYqKYJ#l~x85AIjzEX-J[AuG{ќ{g80dQvYk%mm69(m`q¢xlIē:|f7i{32X>Q9+L_4xmm3n_BU/Eσࢮam&aF$m@KB*:B( PVۗx=+_2-HT `ƒ=dQgt-aҝsٴE>Pj( 8;†?8*6ՄҶΔmY8j`qy?`ʪ8-o_Є+e5R7 s{AFq & V2WtXƹ4'0ߊAE!h O´T|푚eIzL\'Ω?Yei=6agN[K(@E VɔA}͙ N~BM@CW:ץJj4lg]L&,U,Su ƒ)yaT̟q(Ey˓S#9ɿVR]yxI`}i׀dFxYHRj mGiqMe'D,Z3>+M tO+FJ̈́r?'4\z86mO)|ֶ8wb> stream x˒Q`Atrʩ89PgD"e>vV>Ӎ浻ʉ`~_nZ݊KmV:NZVp-W+?@AYWUG Yصy~u~υ[.!/wuYWw27>% s/E[tǬ#7}4 [7)!ոQqj5A8YVICcZ!Xu=s!ENe2.06 N!pԮRZpOtpQ}V(|=.:*coQTVx{6AxC dy$*lHM -VGxǖ xiͮsF{F71(&lqƵ=K}~3j=X )mg=v>`xfe; ve8WvWV*< |ȇ |) #^N;PBb&X7c13?B̉G>GJXMW%'JR_NR|9 ʗEG+~8mHW8N#am_,A0yQ'h[Òc.-r{k _i3)%2 $Ɔ푇,Y{$lXxѣ;`*@4H;}vV5n;Ѹͳ p8ǁ?OM5nqmIX̦wMoG/D+,oJڸyI3\~WCQoh( 1Ǻ/4M_A~΁sz~(PwcVQ2U_]-4 9Bwec]XeB2j u5jp`Cӹn̲ `' DkВ;=i ~ީ/b Zc̋L2ϋ *ыv>ծXhǷW}6.'#.f k^vxlѲ nI]8-l{3ΐ[|@a}w~-fP}?ĨGb0ZQ.TV&} >̫~gыm{3#/2;bueK¢68Pԇ37mQv0Hlj8K+M 7D"\5qK&w]$Ceb+'׊dSpQuo03cb.,1~R|qR}L J@˟RbI§j)!ȉ^D3i;3ۛDޡSFM .A?!b 4H/u4뛘T31f\Q9NHS.5SIn!¹> x{ۛpV&۰$&J?`.807I'Eq_$%zyx- %q4w8@gBiz-5w.b >R|z 2-J )=M Jg'mc;ƫ \YYS[d ,třLڹ'MSm|UW[ 3=ť̚`W15DkAئ` ~^:1oA'vX/`ay:9R.\[c uED%ڤ "%F/|e/VC/*M ~(X5]XVuDLw4le (}g.b =xۘ? wouG, vnT!;Hr/?fս55n?4r8`7"Im#'̏hΨ-#l@]-N;2Vs}XO[Y1vvm (Nm/屑Anۍʶ{{ d.-C9o ?=̝>?vpa[yϰ\Wĺ#k[0-ٞ=K˔SViaf-YVQ*lWxkf<=k duhgX1}D2f $׋?hA5o)Nd]E+%,QA=zH)P4qW7^Ƃ7fB1o- ydP踡DLr.5V[&T'x/qeĶ"I.csR!'‘[*^vWwWbϢ1%}Yq>䧹=?tҝ8p)=?ƿb?`UOdJڣw`Z.8s!I3r1x-DBS U%kw.hW~_]L endstream endobj 149 0 obj << /Length 2741 /Filter /FlateDecode >> stream xڭYKﯘKDfd3DȀK@.Ø1j/W1&@Nl_U_}|s{[lV~H%6Qad7/P^Apnyzwo;etpYDTq^)4ow.ض}h lp,XVzdgU5}l4o! T׹?7P XNjөkO] ^>zG۾im;VhX4`*_TGB*qhL^1ۅ vyc=h8k&lV_ kTɳ/+щJԏ_gCW~]ʹauP戽}qUB ֐ ]%IOKq۬Oe/+OH~7X+(`;Z٤ T}۝xdS)~D`:%:CI~VwfJS) >`Vhz ؀_Suhwz۟߰z:X!*..4ޏVd_|X|6BfkR8ޫB7r18Tski(H!{F{/;f}}A[~]zځLaܟHp>E?=onfصMe_d=tb$h!$G ܈]qv*u/ ͳ"xc(<75,xom>џZ H+kn2$d]u{) 'x/'  e`L$s2eG KNw}1|7?:ؙ#ZL)!^gMSt;=t(g7Yv B>"ye: ImÏcNSǗO=f GA0㮸7$Bt6: E|LBN{dFr}5sT^.)E#zXmh{ƹpڈcPö.T!׃gW*7٩?Cϯ灝F|%?IJHʝ,NFq]RSWM݉R< 8 |޷,^cg=6ω7h9 E73Th{uu8SSBǢ=mެ`x:+~b&21g#[Y%)zbb5K LOǒf\ 1 S*Ghc6 tGB Pǣ@1CHkYk$>*H)ضLixpSeu115kLp:jV, ㆟[O; =`r!0n ML_=jKf>!C,q lRIAv@H!("NlW k{ID/ jˡ?L1`h<%8s%=[*"pc3@g0/>"BCAX@We?U{$Cçl-󠫌(oe:h.^4ԣ"peN 0 Q!ˆ? ,"ZK!6M9N3/V*d_yܫ0CɋZ !T!K;||}$M'o:q,NكW{^snq^'1pݢi+ =^d؛<8Y$rXE`Z쾶&($rȗnM_tb}`vmKƏBq_e?tCn1@9_YNJ=؏ʒCBI*6 +_EԫƾƘ-ظhWaRT#wٕYs1 EŹ8{pږK|@.^hl! 2qknqŅ+~tA^A zvӦhL4X{%N0Y?g|=Q` l<^^KKT ,gX d|zsΣ鄗V2SrxlifӾj?B?].pe=*鑍+4^*\JGx1rdorx" M1 ?1A= ۡX`ʕē!Q@h#nMG~q8ɞ.<ӲJ=IlG.!IO*"2Gtz!vgZ~pj(q2C1kxk!>U#tK#1]uFgr77Fm$P_>G(uGR7x#-j m,g"׬F! bR, 4Q0e\ UNGS;H,dpp.zΏMHF[NC2Ӆ c{xϕ!.1>!w x੽ Ѭ,PCMbgJPOLi8G9,<`" ti(s!:Ux* le.Džc38- $jF/_C??⊱r/[!Diy fokwi8p*!a #'NG?bA"Y>u4`+S !6xqWloKR!9! ΀( g?fz48icld]QH, !"'#Pט endstream endobj 154 0 obj << /Length 2457 /Filter /FlateDecode >> stream xڽYݏܶ_q@*?RN\ч$]OV:KZ.;i]ݝ+!3?r__M]in]HSg5.U\\m/~N-׫_inxbFv >P܇.yp!lي-o~ݦSEߖwaN \&'[g P:%+=UBU4͖Cח+t-˦&C`r)\jr77uEfԬYtB;B?H.ĎQL\j-r~…z0,6Wf}~Odj2't&O ?RF3GP;gf˳ל^׌~VzJgsҍZe*w9^jR(K * ^ۚc9{?=z-N B̘giu"(iZv83% Z(4&Hxռ_KE֧.Tz 76}QrNl*Τ-Gb(z^tX"ЧPQYB]Ӻ95%-6&3-~iVJ3v;}G_E[ inZ+ gmX崙Iw۾wEPibmLI>Mscb\cdG@b +#j<%mمc!0x\ml6udM4nROws.\]S5uMT3swaa o~eM +|_oxyYxD> "xm0 ڲhF,vISE50,jvJjOFWԨTS'*vO[m;ȈQ]>,|Jc!j(GaSgM[^dzV|!dw7Cʚ2( <|~B7!6T)!)SadRk9uDmQ @ɢ >Lc41O2OGF\y9@6OM>ԍ,vH[[*7n.-_ e!m!Hs;b<'{)q۴HRTKge:;6.OލJf)VJpP=DwhU(G*iS%EH¥a>]4do{!r\/ܯF6o I p|l+s8찞m@؀KD{Sagj S Od)B2 E9L0q.`rg{\b\*ӈ-d,kN;`FBK^؋:xxz9§Ǝ,nINz<B\4w#E/iQytvp UGgNw^w*?,K=sku<&})|q@I7QCh&*B~0 HQk}D'7o ;IX;ZI8 ys30"jt5\z Oex0MNT#?. ?ur|g߄2Kң w̶=mNhs{1s2 8}&Xǿ'u5pzV<=i{@ K勿]si endstream endobj 157 0 obj << /Length 1917 /Filter /FlateDecode >> stream xڭXK6ϯp$g\J*IAm-Gg^3(KU`Jޭ 1j_kcWm=_zlzԷ,\F04Ҕp=N&+]1< o[P=?ׇLP'u-W0TԼ%#sKPd9Jk&DZ#0&`p&A[[o,.l,-̫n9>m}ț&Nv>iwpڦ|V@Q|1׽R^p>QUʇB%|@|9A/ed`-O]bpx(c;/1m`b@B 57pd[^IB"#< ʽPg<79Pt1P8=؇Nr ݸp ŒArWf2_1&f9y~_~fTշ]^dR:tŠtȆ KmH1BN3obyfTdMuf. G\#UUKS1=C>$'.n9CMRN$7 6˦XMSU>M]8=17>|܅ߜ>`X I8qeA*Oݝ)PRK&?p)Ǖ!MmA߶<oسhLpi;p#-ǁ3ZMi_9VHjoy{À&e.e-jƷ̀ _ ق 1?-t( 䋱(܂|7c":[3Y!5]m,# kNƊ S%O3 V=\9Su %0Ѫ-yBWDg(Y98ԄQƖL`mH$ ]Hb4=ѩtT0P0;0'`1N!@Ñ3oߠ1)ܩ>+ ?eU1F$DM"N@ĂAPY>BQm o,bd~/V@q0"Q396 -ZR3ˇ\RӅ9plx+-x}\=C JʾfOE }!`lk3jD%ÀE:d MEߠʛs>it- ͆&>U㛆}=  mt/Ҷ(5aO% endstream endobj 160 0 obj << /Length 854 /Filter /FlateDecode >> stream xVM6ЋX gHCr(=詾9(^:+SYd}$k."#!Cx8oo= OHjSR’+X")xhkF.eM} ݻm+KZ6,>>̿!X&f:HQMZ VkMNx2.+1se  @>'ciņ\;%3̪EڹH19p|@*4`NR{}b܀!51Fc֢bD0{ j.sx! i)H0s5aa26`nИs Ӥe2UT͔4H ɦrRx(='vr#/V^ϱ,dY>3xVW:T:52ʖ/qU@ᔻ49dݴ&εF$^f3V &T\5]&WW: ,-]@i`MU*F.ׇ(,ڳ2;8W%7 ѩi#E@zN Y_#{X ymvS.a?3vkSCw ^eZ?4raw"[k!l9$Af<mxH錃>FÐI}EF8_3#fPh3[/ZO,*zmhSgq^X.B/sau/% endstream endobj 163 0 obj << /Length 2271 /Filter /FlateDecode >> stream xYK|~I3 $Ç8Jj0Y%=U])QEguw=z请`,UvvIEjMRt2MTVqu_n_{ۢʾlj1_'+fv\]3WI4I/uLQ~[~&mSX$jf}z3gl)~Ł~&} T)iHJWi?u64[\&3-):MusȔ-gjhӞ[ju<\Gk Գ} _@#QV$|„x@p_Xi oNGؓ#$Ge1l-;,_$Kϋ+nܺMԺ9b؟5cUm<@bݏA]i_ɥj4o~Ĝ,I,[$̑q,j֓]SuSw {&ඨ`[͖m'J8 T>5 *MkyC>2 ]!XZٯШʛTt_{(Z޵M\Fh xf с&Xcחwsxp[9&ߌɫIF@ˢoYĞFϲ'4*sEwy+`{QSÛbHYo5]zOGChzf—^ؠ2 As_trSUpJo׎Xt iF;0r ?bSfCz}A=߬!jބv%\Rl 1 =q*l"¦Ňk]yǁ i0Ǐ$Y:FERM`l6Ldi2"/R\`w>νG L Pij? `^.A jsĊC^ ًc^<\ED]bԙ**yy^U-^-Q LыBBf8ݒNcf785dhmڍk OFWl|źmwRFM wQҷ|#G缟BQ;e'DȷEEu|;EKDD{de# _vTFhA|T3?>u\X. ׷5 J=(­!Oc²^9wT0!C.4| _pEɇ q=V4|\@!>*Dr׎2`ڟЀ&AKa)U%0>$ sUYCڏȀ"[.܋Va[…w :}A8ʝAQ0Lısמ&ʪ-UE]Cil:Mpx͞{.ys/\&T``UtnIƙMrRQ,_X TS˙kQS񇮯!Eܓ>8׉ S῞f"Niol1V 0.xz 恋p7߸dHr&o5aJ(S$y] /g.BB-%`c*)T"?5 ϓ T}R\)eCgb\JVћIEᚥNbxDqUdagpQmlY`}r]<:YEJ=kOX5{4ıT2=[X/nhن=kŐ&M9%KM->e6Jsy؄)@F٣yw RS?[dIbG[hǎ 6?t zUb"UUs~X"tl;|Qd6`+t$챕s"):ECo4w/M  {Q@+ib;T!jvu^@QL~O7h,8L,t8ORLXX=T endstream endobj 166 0 obj << /Length 2566 /Filter /FlateDecode >> stream xڍَ_10j#.HH81KZZ{SUkE}ǧw?XP"A\dJ?.ڸs@)ypӭzctHM!7nsˆeݷɽ'Zێ_晿mw%4|Ug<9#ʫ<0CK}eaR2p$xJa(+!|dRiق&3,|7 ]PEҨ^ rRbWR/89"'*).T%2Shx68_r+TOWUx-Y$9wuymah\l9biO&h+~ߺ_?55I' ^@y(5ɭn@v ]yE@:y'd ]>C{24SŁ ]J.ũp 3[h$pbzBX삲'\*$TЖ_r*xDcPyBF6( mSIs#L;=KP# 3W}5Ƀ[IFr)RiWFӠ .H ǶAU|s|/Af zGX`x(l\ȶo膌᥊XăG4b#x\DGvShiZ뒟feF3YײQݱu {"#R-9QGɘb7?U=`>LSt X,ŒxaM%ù G'8݉J׵,.9UA‚r"9RIUcXȑr&]Jj~ 9 ; hh#++p''27¢9l9Z9\ǁs$FK{1bFwBY|įd-T:x+HXN4.(T۽|\(HRZ!RgDz ilx &%t/E &/H).Pm SBNƖRs 3 !!3*T! RܽYo!D.8˴+a[P3t|[u8%[oڒ]ZxTc@jޜ-ƻ  H"?!$>,;VXz$w->W$XZYs5S]Czb,2΅!>mf#(i2woתPcC00LtaqKmVp }ݽHid0ܺZ{(U=2J-/5"ŗ6ƓԦŗ+=C @X2`8g*~@Oj1 @&ѡ1 l0FkFbc+tL \ j4UGj?4(trW+;.@/zy3tOPx{2:+^D:Hۧнά ,#]?(9Ө}],P~B%_*lwv_V#KX),L]D^YiI̶%2~*@A+[,+)lܧˋ\^Hp|>׶ٷ}{ۃC?](sr!>XuƭN< /{?w>RKh2+)d܀/$Aă˓/O̕guڸWGLءR#45t(X-6.!5-W%bEx0jVwэPUcLIX$e{gԍi:́8} t̷Nj!YA+BC#1=EoX<;P.LR ^ 497k_kH{g1xtmimމܨKUخ ㆆJY3p27w>ate-c=uNY0pL%oXYD?Nl]B9 [a_84EEpVT*'\̠ nPAHFK~rz#V._g_W@ż C oX ?λmAaSy`)i7:)V,'V.&2rb c+/Z"sfjte].kFeY q4]_' QаmCyaTȤ aҒQBg!C}h1!ff<[  qPJP]aQ3nACئx#  ->3pd}[G22w???U) endstream endobj 169 0 obj << /Length 2337 /Filter /FlateDecode >> stream xڵYKϯQ ߤl `$jn+%G}͞LbX,vVq#b5Ie6ߊClwo޺0 rB/zQ)lwxkC6^|a,SF_F t >=n3p?MqI $!kTDəQ^+ !Tۋ6k:4C f`Sdg9fMvKz+M)24ap=sOMCzi.&'/y;Ҧtby9R d9*;i?94+[ÜT?2v$8Ʋ)[h`ԣwJdmHv`%?B^kS0n'j μX陮.)tR1ϿtpBazjꌿ|M.FTb!Eu]7C83C524h 9f'£:,>ѫȤ혗b-gTL=za.I OüuTΔT&qJ/ˌ1ܸ$)Yd־td.(ɂKK3*|E"ɒI(G UYkGY{Sd| AqW$!l[[h V 6*4SݻuClu񰅂>05i\21)wI' txY,kZ@] "U]77ת.+JJ,e6C[ V/ιl^,*~LUS͙#tu1@7܅CK.)ݓUGC}<HHǮ ^%J"sY*>#e =a\Z9\5Ǘ\-~g nm Wuj?U(GqQmp|(: H) hNCYz6 |k^bTM, JM '8dbcY J 6nabƭ+q:ǥ TM7_{öE;@>ۗ\޳s4p~Qqҹ}W?Z8KSW= ={f}ELlIG& R?FmNrmFHbP>.^@zdJ]tF0غp}C$]\~ L¾}$  Buq\CՇGXN(;L ~+K:/{ f sgG:/NK=-ГQF'&3”sL s'8ޠx{-`,hPznY3l/X<\)!ծ2 n])hqwP%l 0Ͷ"y=*=Ͷ◇pLu;1R26| a+4J]vǫ7E8&pEnWsggtBii7>v@?b =6-yn&8^R#v?x<ɾvUC.LnK(anA⢯oai(<9O8n[X7rߙDQgg&izK ZϪ42=e핥]JQBPrR^C hKvMNeZ1=u ₯-jJ=Ⱥ[֑@wT  iq-f@1gqd7->ĈfLH@tHE|C!.>Ήn̆O]jQI,T'p$D{*zggX#H x 3Pu#CWLomUVA'}&q۰FM;IHLc_@أf5<;`-_B'Jä>֘# endstream endobj 11 0 obj << /Type /ObjStm /N 100 /First 830 /Length 1748 /Filter /FlateDecode >> stream xZ[SF~ׯ8d&{&&$4RH;I5ƦLoeH64ˮZ Ė`1$-GJ\@nD1ʠIIbv%{RXYCJkHybgq1.H& >ʀLQEt’(=(E?a ޛ)H]!9%J̏&L"keFAB((1d. %֋K0HF>BüRPcm'0:AR DBtd<C$WFXa2J-fEd^$ƾ̊,xBŐUC֠C0g3ď\dj%A76FN@9*`]/Cm΄hhm*U3B*RexĄv(1GcbXHF@'l M;!DGD:l[euA VGG@g tM\UJy4^{yˇV'I$Gv:_ 1Ɓq/3lG70C[bU)WQN &U[1c>MszP]%ŲWmAZ"114L1Lc(U. ZۨZ5Vv0UN~׈gXp6o)(a]G~gaۻ,rͳa^gy1iQvk3 ]Iͼ}M.iy_ĮA65luV҇W l{ϟ?~/y;;s3^:hv'^N; ,54v =ve ?VgUrZ ^"ƪno/MQިXZG7ѣʊNur^ xɮ*IMާ o;Se-&tyut4ʯFy:埡po^ʼnESԞ_# N7v$vy&^DjDӨLsf}s6^>V[?\,^AgSD>|*M"u#5z*V0w*1o5Q;+vxzwerσ,OWqO~Z!J{$$w%1{2=-7#'3a[Ա]7}`2~ ltt-?dLJEO퓴b\L㇆gO iIi2,t%*DA)qkC ^')AMjY(~ft,%o&|5snXnyZ,Qw$K$KXYSI,Mb[捼CVAj]x>З4Ь5TeV>1s)b\LUU5W&3cY@Z ^Be!?.K73f- U!fbW-Nojq%kQI95՛Yi5}Ж.k8θ6j +]o\jckz4rC Z~[p͆ps9kd`A λSz74-oO33[. ~3[7b[[ xvŀ}NjYp|ZIs{y7  endstream endobj 173 0 obj << /Length 2067 /Filter /FlateDecode >> stream xڥXKϯ! 67C$.v\{vm!HrT RՃ?3o6jfXTfsw/Y3 $oIꖤfgwf'&IY..IcR|X ˹.(tv3wR3YI_a߇N}\]OsuSE_B#@ 'qG^dK˦N}g$_ùg"[{ׁ ঎tVl4"n4}Y[?(vn}:r#B݇yDz*dxni IBstw.+!*QIX}Y? mwFsH}Gc4;;C)>K.-ҽ>(`^av\v Taji̻PQ91B&o[ i /5ffKΌtKx}FLpCw+yoNK eM-TVEKYJ;DM_TDBiDGnڹ <0B&  C'NH^HR-1зE K(!9Jwa-j*b®e<% p|ǻIDHm9|94ej"Pf+.m:W*zJ/HYopP]b*=KojLv' fĬac_7dĮ(InSQEq4&@Y$^uuF9Hh'yD:'$)ӹTKXSDS՘JaGhT#4o䩅ZR9AP Op%PU+ &&!W3( g,Rԡ0q=Xv ʰ<K<7#ݑ -V e|䀜Δb9mfLXtT6N HYt5#RUaב'~,7JʪvU9d91Z)}g^Y?. bK;tdO'kF:?Z8Ai9E:N*t>JhG-iⷢMEAGf)0kD.UxH@Xٺcy10 e\_uSIK!+-$b$Z5@t:KM"J(ؘUi3oXT `Nw6٭%Cxs4N#6SXұy'L(n2EQ;'`rWτ~0)1/8hX>)>yEA8)˰cόȡ׌qzUhB E mNIƕ"sq =7.A8d{)GSqY(( rϭuۏq4EM@%*;muۭȳ)`m`u!5C½Ks(N j U2KjEHocDT?>+PԴ9n.7ogV+#xHbcTnB{>}-6|*OqG-y3:6#)dZ8R7$3m/mM`]~'^3)A/.׏::D/{+"-M=F:uN^=^ʘ,>//lm8x) s*(Դ徨hV?.'chė$D!XXHL'a7Y3}^{+v`y==#?p2 endstream endobj 178 0 obj << /Length 1115 /Filter /FlateDecode >> stream xڥVKo6W(6#RC tv lz%&f+I×"{b"7~3澬5%)S UeEHVD.4_%5hkLT9E/IYĀN4GS\MZa$Fvn+VnpZ$1kkרצs.]eyX&odsE#)p,פBX-WiJäSIh֡dU$7ZBA:zf*uTc!7LE@Y#Yl%nҠ7*igd#A$w\LQ"hXm%;1vN+M4ϊ^(sÞ-+q8Ȃ??~vq%@eNUy;1D lH2jY2PQ$%@xs!u[lE <1]׳d}LDUTK App MvغO}B7ͥt`bn([qŨa$(`:)v 1L;D(h̚t^?|=p㈑un%Kzk/+c5ɳoö'K (4ir֨b}ZԇdZ`nf@T ^I?.$sus*1A xa"$eie. _Jesp| GWR;_OR W_Dˣ ^V$Ak3ʼn Us4+TWUYb]3ȥdUך:#^"d8-/Kq.k)"lXRNZg/14+X7#,qVD`9 vä@9_k&1Tzܦ dFAr2/y3 LU XLjkhq왍: uۚz7`ϯTD~mU9wm-v+nW {[3" 5j&  u~ endstream endobj 175 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/msm-manual-028.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 179 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 180 0 R>> /ExtGState << >>/ColorSpace << /sRGB 181 0 R >>>> /Length 1550 /Filter /FlateDecode >> stream xXKo7_%Yzf܂J%VDb#RgmD:uǐ{Ƚu{1: ;n'v7۟x??!}C%p9{o?p? "N2ZTT<7wuGX|Q| 'R@0K%n0{)){N8*}S䄒'sp7G `P8QNss |Lo⸠xA1jX|60d3 [f4{jqZgSMqH>iyKa8i͏9s| I{8k똃X786MT?Cs1;QX(%j#ŞW8*([1\tʨ_ZOnCBeKiJ٧ hIz=2ϲ/yc ĬTF.BRle*=c>~ouWPz֟IѲROM󀛽%G{nkpٕqpKcW{er<ܪR@FoSz0Л~O?^ӏc |=O >Ћ<`-11??S^<ݡU7{~y}qBd6;V:w͙{=3 {qWWwpO+iٮXo0$57A]CMA5n65zjq{˦ Ԕ^ujJECme%TSPs75K\v5ΛBj*L7RRS}3 KMᥦvlKMj."ojo)绚"=L}ԥ4JKM(:j e~M5LySSpPSoWCMMMa:eWSeSSEv~)e)V~MMiYxSSB25CN5Ţm\jRSl?P9ՌRQTZHҺ7ROS5x#٨~aѩzčZՄV(Z#HnԢZ{Z&iQKâ,jͲEゞRˢN Zr٨SK0hHݨ7QHuFVZh} j&'m-ZM@E2 jT7javZhcV=>hVHCjAI-?T0FSKZiVsR+ڤ²4 n@{b5BZ ZaҳD]LWLvąI]<+ㅑXisx1ǽhʢVAݵ{yw7v[~^)u?|Gg_ endstream endobj 183 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 186 0 obj << /Length 3122 /Filter /FlateDecode >> stream xڕYIW!A@#R{9x'Hq,%J2= =o*ugv4Ah6y y&IT/ٸgV 'k(M"t+ōu2$LўdQ =yһFxvCju\Ճcp{8Uh Y!Us>(!aq\P[a|U*/Б 9/.֘@E w;f&a; ;NeݟD]z0Y+sebt\[:&@*DL2v~Fն}ṕ͖hzkr<#.|TwnjBˆ특tьJikLeZ*IE"`I 6a{^DNEd[;dS 94L:Iz~qO__̟$g ÏVj d㹘|`V{|#L y0xta'8Q:'X 7Jڗ͇tnxƬogLefZ>]-JV%"t8drViGY:Nade6 GNj_t*0T(ɂ?/߄r}E['b H+n Q9g/h2ˑ4 $)VNZ, qhp՚ୡc1}l`baZģ~] &^Nd1K\eѕiCnu])m 9D 05#7H#Adk[ȹkEk܈I7;!P'139#g5a"1'WegP :rk.aR:YL+wJ`P|GыX&s%d ڕ/42m ^QKbA )G}C ܖ#/7y/ ܺ #iP<ᐳ (B1KQV~2&FS^H!Jiĺs`br~FLɞner ,ԲݕBݧ1Њj)W\>GYs .Pт}c6C =PE pՑ7bRon]k؀OSPx_V'D& ;x83HW׬0<P/ R)QTD+1V܏ k~ܺ+1O8DHG7QV$7 *2sӮLbHVLгѐ=EEzuL0'nOO2;C"Bi&al{="VJa{b'UAvNBQam^ݴ&*Ogce7Z.=> ;=_NԯWhI!4Mb]$C~ƈW~.j͗Y=9ۏ&Y9[? Żnuf#[YC2_W YQUFA?P(I&x{/NFr23_iLx˲W #KG}r|Ib~i8̦o!2qɌ4]/z]6ꨦr7ښo_k2]\yhE%7O'Q*U I$".RzOt^;MԾOCsyaM1簿urblF֒h/]2qħZ J>2Mz />q gLzMlſ|Rw8ױXr dךC2\D94#uj8lzpC9>cMVRg|fHcG?Nۡt[SW8o-nJJ9HD+Mu[(#KNDR]ojf(;|CsbxΰPY:/[Jpt! \ *".&ɧtրh&'43V&Glkr^@o}2 I Q.EɬHY$Zx~U;io/|Tjpj 8b(alWw%Js>x4 -{=_MVF{ M"px#O<8 R?=~?R endstream endobj 189 0 obj << /Length 3220 /Filter /FlateDecode >> stream xڝZIWʈ&CT&U!y>ũ2DBO,sxק7@$E6ko_7W|L2,3^_TR/Y:N_^f{:4 曙f{n]aMi)ɀEzkij mv2ݽ5f6u3u]*35Co׿UI*,S94TbZ ?%QIO,ep[Ͱ.Pi˞t*e= Ŀoj2rQ85JVE‚AMp*B(85 w^֌ϢXazv+3W4 2Akd6,m}$~ [\QWPXܙLa ]>k9;P6+f)U_xWu0U tVQѥFRa+](^=P0o>`p".f6+u}y9Um$. =@f_JA*bY3]j!NӍ*QV4p*n~oVJ=X#lI;L;G{0!o 5ycVXQBF>64k\GqBx3B4Ʋ< HPa Ez?݇|}5H3i~Ś'ƴщb'-;P'.<ɱge4B8ߣ2K\$Yfˢ+}MZ As6#hbu?[ ]"G[ MycU8ero:yRg8 t?bs8uĝli1,Hi\N>`F kW+^na`iH[ ]ĀrǎYQck]&0/.0-Lm;"$brSK\BÀ[FzH"C;1!x0PMG-F䍚C~K 0 UB;DZSIF<w=Vbh%nC%+RE*>LH~]$ ,nHŵA] M/~ɖѲjtm-k 랃% IwB\ Ie.>'9髈c:7ZZYS_%2 H$A&_'G6leE`Qe d$CuZ3"74[Cq3[#|kg뙖~.Vdo7w!%/xNqm@rP{JeBcRz 6OV/n))A5nwZ=̦͢0sRdH18JńMI*gMhLmdnL*Q".>!b2kK.iY! c_*d G 䡗6SQ: 44= Vmw|@`4x/ 24~Iz B#6ZwٹLQ3`&)^"I qkƱb+n4xfaCX@t蹐^ F,rWkOU$UQ0bǽ Y<*T{^9A!nr4 P{|7 b*JJs}(~RJ|ؿv ga`gز*]2>2bDIԃX6EQ'Xd)N+oDBXe%KW?@65Rc G_hXqė)"CfJ@xwÚh@4dMGQQZRET3 u\è_U+H{#q@gy>;%i5#0=0^hiE28T"րsb)w_Ąc endstream endobj 192 0 obj << /Length 3320 /Filter /FlateDecode >> stream xڍZIWt%M{|]{Rq\t*8H$x(R&Q~}.jK =7_|>MU||2̋!ϊP%s`8q[؈c4ݣʂ۞xyѵC]Z.봟qy8]P(*"(Y+HS?N~|4uP*{wE|ة4 2~qXe…Ϣtc*/ieE];]ጯn%ʢcKƲ(`,޸V\TaJs(d$*HcRn ]P V77gP8=A_=4c)1扃'@{⑾OF֌oq-SfKcG ~|֗kcJ/(D`&jab%_LD~z3w~s7Ok6R腭*Z[nO)l?L87 vUT!Ї]Hȷ'2L{#Ye`ɤ @`mRT11LXf(r =m H0W~ro]?%kI)̧8g7gkN+c?(=sV4Am;v, Ľ!_"zp{bP#e㺆&y0-'lC 'vC odf_Iyn*fp|GdQ268ԡ,gC--l]l<~K1t1"Ӵ|á$*Z{ya%-/eޥzL;! 흭U-tD*-?3T>c/'oS-%+oH\uumM;vhSn|a {dįiHۊ5;ֺ,0 67Pœ/n<褻 ߼"C9aY%x3$i0 :+ # 6ًE ([zӍ9OtoᎧنA$vNXVSAVҠ}w ζDuOD cH n$^ml1Bd?4\  O+o2NzmA&4pOChF>۴n|nI01q8th/[.@iE\gjL-*[B %,@u,d?T--xZxG7m]^E6х_Ch;7lQpxO]22>$/#5meK5y#r ^ }sAܕj^Q|>wܔհrZL 8Gl č֝M/0f9IZ.b."n6nBzy3MLШ1oAnUKezw[CF*i +$32ZT$cE7ۡ8Sz#,@?ݲbOCnM;;f"f@d,8KB4ϙC ; XIU$N]h~Wa~g_7W*Lɚ8aWL&j2mJU(qȵ4o7{;( "vEfJK̖InR}R~`#!:6)bpSmVHڎ O94azxؘ r4߇xaeNO):^9k~65}!RbKRKIuJ'` >I&4;$r$pBert-KSxBB>0tZ!AZmsqkbܺJ>rx6 вx{&6!ȅ,X4՞ncztlTS$0g{.Fɢ:E hY[}qe!R_qso犙x}y2=WC63l{LϦ ;cO\f(H?;F YV&*dwJY/VlBU=AOD_rCi@=,8(Vv޼jl. yr-lALRRqq7` z0{6{Z PVM6 JJ෠`Ǚ=>(yIJQ_IqI\ǹh=k70rlJ )Ƨ@F+^b2z؈+ƕlᎇrZso)`pLyǫZO2;%0*v`&xD({т6N3-eU;B?0032N%./܆no'i|PQ#/tL?^ U;J/vnRwR^lQM%d%m|LP>/;%(bT.S_/AR=* Iƹz[]/uVqE-gIۡGZMUHќa| v/N$ g9}yM_M=8ۍ.#GGJ7JC"_ 5 ?6/{ endstream endobj 195 0 obj << /Length 1618 /Filter /FlateDecode >> stream xWK6WЃ ,ߔP@ $@{i ܵP[r%y;䐴du/MrDyp^qOR RhWۧ2 We;5YYw7.]9 w]o5WY9mC}=eg:};v8nTFt=}s>wmY;8ul{ Hti*/`IWHyξGTS;%Dy &{=N%.DVM?tje(wGdV Sݻlr.bF* A&h91n{z)>uT?Wtd95-?$$u"p>7xM_sSI^0wZ nH xu 8l.=B!^-T屺'# ݎ*8J3ÈONgwW'P͖nfe8٭4-~sUiequeӟe3ph&;I7>{{\xJV/w&8H.S󝕺ΊR}:NS)qJC sΨE)m@`䬩ͽ:[u0kw 4H8OCޡ7ÑۃJы9̟Ḯ][U`"7f:us5| wv.]AjnLuw1{<{qT}ˢc!Z|IbvlGv$.v(!bT<+K,co5fP2@<_OHXjȜ-a ()"Fʼ;EG(Y ÒK# $MdIʓa,X~'HOD':0>Ƃ36K%i F&yHaD!KʼnyĐ9Qa j~4`_S~dWF2 ^!NdĈ 2cs7K endstream endobj 200 0 obj << /Length 585 /Filter /FlateDecode >> stream xڅn1 w? fDJ! $Czk:ΥFrD t~~7uCk!p S\/1sƀI ri1~6~v[" >2\E"0RD*.BQ!L-s 5~ ! sbw +HDmNI+Z3PK+vDpՑ<:XKj S۝! ňG" yUf`BE\ dA'ȷGcsoz}wo_^@=>װؓI*[?W=hM;˖,_u(|GYz(౥{.*+P|<#@p3י,j!RœPOQ#U< ")uh!AerP, D9UV-ypEp.m2:Tg3'`bw^ ?֯n}h٬?}h^s\It?9ia: *Gy endstream endobj 203 0 obj << /Length 1629 /Filter /FlateDecode >> stream xڅWK6 ϯmvۢ[(AJNHe"(tr!ҦnwӶjvt]ڔy%Š+2rnjw"`~_ÕT1=E{8M QǬ=?vq(:YDؓW>ՓHD ̪[hVSfmHd7.I1Ox\h#*u-$2 ^EHI,t#gԭ?{e#d#$5cQ-6>Op Z #ZtƃvEji ܯ!;fi:B.ήcOA⭣qP8Igwr }$2zOz /Ӭ8rxˁE=-OzR)MQz zfldo_ؐHd!yu|v %-L:Jݎs2_,`0`*g8 d x tYm ƚ`'jOe׸!W6q:^@.W8dLC/9 |YxV8(=Ti#WyἚ.QENBcjųkg9csBԯuZAWi <4CfPlb.,U4 YZy\:): nhfnzq0 -/%a!9IN `h\C!&ZLx2*qP:cin_ uCw{! b\uTcBU7,Q ^Vrz@?H=ϊd:\$QdE!,pj'lV c|I%JhC#.}Дel٬O-6Ri(U_jc6U%JӺ-]BLJiMG endstream endobj 197 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpNdes2H/Rbuild7d4c4bbf851e/msm/vignettes/msm-manual-030.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 204 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 205 0 R/F3 206 0 R>> /ExtGState << >>/ColorSpace << /sRGB 207 0 R >>>> /Length 5563 /Filter /FlateDecode >> stream x\K&q7y XyAA^/fkga;3#;;7l4b̌7G8;Gus#pW=|||񗧿o7.9:3wgm+>u)==X.TY|t|x*r 0`?c6xgiقz] g @tbt)g ^vvt$9G.!]:YY@9*ȹҹW`KIwtR_ %,g2=ϭA:Y™2*YϽOKΪ , әIFRla33K'$똥$^ d)<ˆ: wd}yGZ7F=t23ڥ_!Z>hWB? pyR3T `8Iټ7UΤip?53[;fa A_.]'9_lv$]6k˔3_MWMnlxQe2*eওSL&?2P2?2Cϗ1Iol 7*kٰX&IT\!kaU,ho̮a-Q2WW&cvҥ`ڲ [sWnng\ g.(KSXq(W(+dGhݰ- ;R6,[RNmՅj{S26dh-R;.:q6tmix@,,[UvϤ__kE'† w_ x.tm+ks;Gx!_7z9{÷>3 (Q<|YrQ&7wO}osEًuw.?{wcqޛi fGf9LCt_}atن[lv]6Hpf;.l pkglCm$Ԝ)'K{;_|[Ζ$xePg)Hp$\n<6/2J^=N,xȒda?|;MoK:PPOw aY\o緲 7VVO7oxF|'?ɏDr(ӝjDjP-$ըoL!R 'E5>\!,!yQ F&jĐjd)jHâٲI5$iiQ @&@54jHF S ,&Րt.E﷨FB'jHjMuոI&Ո؜jHj}&Ր6HQJx?Fa+PLaTèT^TC1RgP VHA5j(uPӢJH-j(NmQtLbR Ј6#Րig۩7!TTCflKݨ7TqlTC0'@-!TC0C!TTc4_TC7Ƥ{S Y6!TC0P^6!^j| Ր' {P @2 47}4VM^IΖ&/\tn1Ũ9_OtUЈ0NpNb<gZ To<~`Q@7ũAφua<ň`vE6mBwʬU%mh2ќ b]!@']$g8cq]С,iYBnpz+\d:kMJz˺1`C| %8A759٫\CY6f ICA`СCYv3u#{;cٯBqn6qn6qn6qn+I0hucvMM Qbll~%ݸ6,B eFfi,IԮ7,kw^[7䒔b g/xVmYػx6:B &M<Ϣ3K ϔ'=.|3π\#!{ԭ縆#6͏p͏X2:4?•4?bIi}_G%r}g?(G4?AAOv)Zo$5⩡x_j^YV3Y-ޱ$:Y-JvI:a' +1Jլm+F17Btg+cntEm+#!=rsrӝ kNWa+FWA+ IW2IW2IW2Ԥ+ӕ n> *&]ɰ5']ɨBt%1]twB.ѕv9]IDNW"DIW"a+tJuCW&=t[ N'@W&#]ittE%otePr"Zv2H IWH']:l+J'tI_t>ӕt=++tJ'uBjҕxҕ|ҕF:t9!]i|^+T']9 IW*ӕ=J|wRQ3J5Jx8]f'](t}8])|NWhULR?+j˓%LRHӕ:])'])n']N']/ K&]aλ*ox+q!MdD99jV kh";c"3j_H~g[ lڰ )[yBKPLpٴ!$4A;2;R ST*4l +ԋN [V0Z}1`HctF5&P xZx@-bta H@͋i^G6TeM[PvfޏUdMhoaӼsK YGZQӧM<[|`88p|4ç~^ Gf/Z8eUzUjfh$sz4G>Oͳ3fԕY>>) o,A߮FY>48Zk/Y~g,?!QeP,Ucft*gpf,aOY~F*,?^-c\g~~,ߋy?!|Y>/Y,g#Y>;Y>w3r,Y~b,?y|jm'mf,?t D,?|<S-˧&Y!˟Yr|M;-c?6I̐iY~ {k7Va0Wj:Vd,_|}2oeme"#O˘+j+o^',]Wg?v!x?X2,17[451$c?:f,,Sk, fU^;/uț_~ר BǣN }wd4C'"s;\Ѣ(}PfPAC7Qs4t9V@s9ŢyX,8-s8*38:g< y}7 bNw_F^ieJ0˜ 06oMk ~-J[cj Wÿ1+L-hVfhhx CfhhD@ CCAQfh`hh@ 4<(ga=Ǝ-fhP CFҰ0C# 2C 344nah1ihh,C#dG? /k +F044$ PCC li7 ?( (x 0`h(08ƆPP Ɔ؄`g046lbFB7l{ذ6C#h uڰ 6Ccfhlga346l˹6z׫r͇wXzԋv¥ vTZvuVpth5)\=$J!UWR,zLbT)fMզ<%LKbKSl_ڔ_)S~S~ҧP{qFrD*Jųx:9&۝UV.>Nij[|UQUZﮰz\b#r Uʫ^ro'5(kPӬ-TmDdڸŲ,r '&kȉ\cPkd05kq5tO5FZ\C]6Aԝk$ klrt5G'S5b\CSq !X5Mȷ\0}'V5G5<'ոR }j,N5<5uY[Cqoոmz(N5O8j"V79jTT`#N5dT@mH5-n?MwlT# ֢j~TCmRe-TC1TCة +FT#ҤR-~iN;Ո SPjD.qѧ1E5STC^OVT#O8P p)s>j$ N5RZ*P yrR CF;H,qdC%FTCjH5S}R|aGq/_R fNôQ iRDRLݩFwN522v^2ҹnW2cK) L׮aS}.[w5^Mޟz^ UC*?>=Vt? (S"[?5aP}6 endstream endobj 209 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 212 0 obj << /Length 3350 /Filter /FlateDecode >> stream xZIϯq)Ea؉sJF`<uKv=>R[q rH|=wN]FKfR!US~u9ONV%㩼:y' Su#t ;#?o.ІRRnJC}9 e A%$২f|ێB*9x¦N}oq?}`XҎfLnO@Çѻ]1u~Y C>4F 4j. M:wcَUQC^J@RkKt`,'jUZ/FbŽh|돥_Nizڰȱ ?G3zZ@Qjj'ˡl$\v/nKY)xFe"xD8Ieej AtSڣu7p6Β~vF0 R`; v-_w-0A2SmZcw&q؇ ='tfiYBǟpғ3_\;W`P`41%%GXx]lȫqfDZ|+'ytv#29^m7e=zI.| r8]x5.Uߗ0c C;ܷ ,=uMo}#2ZZqkԔ BE̻4Ed!C{.M5[ÎCӁɩ|.E\f]dFILZd U; "7Kyf gPn9xCZ"p0+N5o)t C&l2ts1`"eKp\T=ar@27~ Q5u5G%D a8:Z!]®az֓~g,68 pBTtAW09O hBW`Wz2>E: Cj8J܆*5aȔY~cx&砨S 2dR*t*%K{5PX̢\Shǘ!"P͞ŌJ2~&!<ؾQ~νYTa8a"=a+|ȉ}!WkOYq!+ܿxj@ ZdfuHk*,@OOЫbeTI<:,,YjeX~@C[A2̋rQ͞%fciRE{\f}Wáe7{g]\W3+yqZWR/*LWUl&lﾽ};tlw Awh}vG&@=zûq5l'0eI[frۄFnK@$jZjn^=?%"!49X1sܒ\'sJL9^e*e칕z62iX*ث)I.(%н PVY!nJ]qpȫ,2zm6`$+Lds½#=h%!Z Єy \3xE @ p!])p)I4[JW,c?RY^vf? SǜN"?*-2X++A]q[jbݾ,•kQ L]nၪQ pëV Ћͥk*W:-\cS4T=':ףSp GnT"HJ^FkZԜqj 4{>ݯ17gcY=lc:NӀ8{wֻ$޹]CtMG tb #v{|<\L> stream xڝˎ>_CȈL L.},ʒv>U,Rr,|PX7J VaO.%L~0:cBS}=`DH׫QBG]=$t܌t@P:!ằw<%5V4- 紪g]w)BD\DGzOFGsK#q&v<#C&!Mu&jtnC5^ЗTgF5\)PP*ږ]mB Rpv!# hGBp=\޾*\7S0j-Ð BO~mlx:rɓa]ٛ踳MTSp\NDȿR }z:dO'O#2 5@ڃKg wC;׹phin2ZlZ6tPU/e ,~-_6ɱ%Wr 繫\ZVm9}z)(PW/w2"NzXt%UgۜKŁ`]aב`_mt4 <!`ye~ot!{XL$у'c6dU;|G@7_NvX|ƫN nuXY|8̖]kzg]c*\3 Zg/;bUuUv<3+K<{&Fmo`H Rj2W|O{M᲻e MUua9_nN f~7c4HH`*5%R7w;eQa*Rbn1κh` `ڲ^0 . VB)U V\ᐁ+h&ƶ$!>l jTXNFZР-S| +UczNu]M98R0q;WŋvZ5!-Cq'ƚlʾ ǥ,

> stream xڭXKsWy?ve]JE=@$$4==ݍ~~ЏIWS<\Wm+!u+>os$/J+IpjK_G|%OXrO2D'͕k@\2̞Tſ0 N4'd2",tU%"5qEŢ](=q_)uidtr i,5^0)2Iy!thbaѠEu/F}-Kǒm8̕\Qߋt i2g&2QLkͽEȄ2NxA*E-x, YyoSRreɟd)/!T+}g,U YM\`zE&qJ+! fY1+6CzIj))xͯļQ¤gˡn v+1[YhtQȨuŌ<Z@ O)1hºK5O$o,ZHL`l~C=Fߺ$vdƟ;6kp%m@R(a*^Q o1XK Nx8IeS@/&$ZaovcT1kP KJDHX@5z܇H @v˩% />š)(À2 K6o}w9'mp^hj‰rcnw?"-"8ù0<0FN/qu?\e*)Ryz򋀹Jeh1T#Ҍצi̡`[*XjrfBH]M d>=?4uUp2篬Zb%+QTXm!\c>Jsq2#o3Ë&5zwҦmGp0$.^e7v8N<%s>A;7^ R)B/<Dي;Ъ,g^$K/fvg螇a޷f +A C /b;,Fno`}.]tҩ#;|zkA FI#Sq"(AUЖ4< Ty"7/yaF!I'Ro؜`Jl fxN{(z1QfFXH͢Ak\éF5G\~]nlf^?!-}IM7}q endstream endobj 221 0 obj << /Length 3295 /Filter /FlateDecode >> stream xڽ]=2zf%QBQICSE.ZId^%Wpdkz>"/[*DlpX)cU:Mzد~LfM_  INmiTCXor7Dzy U5k&fǫk fprt.w*yWߵmfWrQJ)31Z%e@lHU 8r>a85zEi$Ңݶ%vm9RSԲ1/LT:lXe/1dX'rXU:͓mٓtЖA[]UBqV((ohWFd먹yNcV/0 K:CP{k-KL"?CͣCwߒȓO|C-eG"U6е'$'ϊ$u fCST }'PZ2.ڞ-/\2G&`;d<˒?Hчken1 AOlBCaF{4ZLU[@wrmm.y ҳ޲ -I#}m 4cߣ[&͈ql3ˡ|MT8s&H}ۈSZPMJѓN' RX67"wjpY?{9#ڤpF`Gcɴ,ŕ5uH*|CFd "lGh&B\m9]yv,ض<5eԡ2l"^%C[ѹe/@|jF'|+ ! 8r;š͢%P,\rB0R*88Cx+8NM,é>Zk2ƜAN~m;_cp.La :.1o$2Ԁ+"ԍ۔D&HP4_ [#Qñ]۵M}pTu Ly:#(%mRI}j⤃o0*jp_# lCpjƈzF.|V_9ѵ/ p6}OݰھT{uϟ'81țO`$ CD9tB_7JREH++=jÌ⃜Bh87lblިrubv]ԐhcՓ#CQ17B 7&(=.mK׽ Q~ !h;Na8s  :.Pmo-Gr4^$9IU&)!*.Rd=,#5x9@ 順|Vr*Gq"ŀ` q~3)c==RHbA*鶔:l~SCӑݧVXm%lLeN~$d}W>eqA`SLp!Ό8l 9tg-J(>ANu2l_: o?nm^8~7jW"k}d\#wYx :?~Sv?.I D Nk:7{-cSGgETh@`yZ,oWKɱR Kp#dCz {1V hA.<#t5hocn9t>ּ`>d\zE{l@|`CM0B+SU(.. X,S@̩@U6&Un AkލU-2 4E-MbI?]Æ 7$-@3^CC&*Ӓǐ\YA cߖ۪$ `QTe\d)U_TԂsB|,x%_٩{abq)sܬn%d a A2+ޛkuܤ"Oz $L?O S2_Nz~\MEwxR%)>O?Og"aXtI'laq gZ~(^Xi]:x> ˫wm}95BљyT+ˬq89V5`8K#Ix*v{S'WYVVHwu3LpI@3ym=r*l EGvhg=DXkuiªnPH}nÑT -lxF氳Xzaa0Y;] %V=wUSJN-/xHt_Msݩ§tmAK,@*Ӆtè^𿃪"GJwO\bMdU쥪g9XYu)7oʐ!#R__A!1){B %o6<D5M5?Ttchc8a[ /T*O/X]< D6= $U"b(|c_$g+r=LtT0&o])~T8ZL.[ŽY6Ͼbm ڥ?؋ JUx@Y)PUu-VjS[ߣWi_ƨ_KK$t8mCB5m<雧WpZy|䏮}>:p㧝׽{~p_|Up1:a?wX. w&Byuc jx/=PHa7ʯ/Nib`ƷZX.2$A&w2E{İ endstream endobj 226 0 obj << /Length 1703 /Filter /FlateDecode >> stream xڵWK6WTF*)Jt 4AR@qCmk6&wCv孓pfyQO֏E2nS-dHbgPVY^-Z_Da-Lczc=8 wWU$T٪T7Ѵl~vɓ@Dj~R#6'= +`7z,wnQwbP|<7#8eHoΠՙcFUXo Z0zj"<&@ך+RQck:AMݘvIHdLe,a'~ LQY/ao{ҵUHIVqa̕Os4f1vnIt̩K6!>HpÄUm5xͳB䜅jg.U5c-(`B>B[nti}o D|pUsU0r % d6(N~&"vQZdkgl(fuytΌDfvb? *SЋ#q1HGg'<a58 KK+'|L[uBLzb>>iXmׯWo^}lD ޏvݥLL'NVP⇕´>/? d"<;<ЛL?Vg"?14MU}4OҼӥu9h'$ƟXCwg5Y7pGH?ߥT9^:f6~sh"%N,˥KDR jƜ&5&Y|O\a<(3 D> <@F9H/ /үQ#z$}xa~J}B>$9@xCȦ@BPFFqf_f뎚/T-Z3R䤦wAgKO01\9E| 5 endstream endobj 229 0 obj << /Length 1716 /Filter /FlateDecode >> stream xڵXͳ4xɁגlPfN{`%Vc?,=ήvĉ(h%t8\K}X_ TgW:ICEq:afsEϝ,/mDa*MDZ]Ø"%1{* {%?*+:ɊD(Ngɺe4ű,EZ,8"z R-Ʋ 3sdʂE61%TB/5P$؈TI"z ,FI/+XTa.H\ER"LcE;_:Zͼ*Uml.$UeHB_5&l]CcLY3]Dܴenڝޱ_ywn[ 3;c=Tymm 7)%Sh]W@[mfYVewO͚;#CtĶ+)l=Ϟ̄J_iv[VQKFRfS7${ жmSfNLdI0MGCޖ ^1щ"%d"} ΩRtX)|*Iӹ5 @]Pa6$Ivzѱ&G8a^84>QI ;bD`g2 D ZK;e*ѩ9*CD zYIկ1r {cGl9^OR(6!CP\x)\ PM,r.iseSNLOmli}zIxɓa}̆xޚ](qɢt8}gT`\ lzHELr@BAčm˦@DnMkŮ'GUO|/1Q1sj~P{1 O8! cBsfP$4"H]un}(9B|Ereߠ:oh,,_xUB"}(Ճ ;mzK>8$Oq q TXY2jȏBŴ˟ lJqT* Ԯd _%UAk7z(:LF$[5zRhYEl;Y3!$"9pNO恂@@5-jqrgv7wˆٍ CP} vg*]Lj 1RsqĄ QH:OUem _e(M14Oh zX֬2G^롪ֵ{{r©ݲ'*A /22 b龜65{xx}U и7" d''qȧ\M~SLU=/}52O]>LtT\8z}'H%^2~iݞgs 7Ce ZovcZ>GZ;=ޣ4Lt?X$_h *Ju8)E|OO#Zrbr$wK(_PjBR"Ӄ@u+'$r||U endstream endobj 232 0 obj << /Length 1354 /Filter /FlateDecode >> stream xڭXK60rK|HH$ْm}r(KlwO&Gf?\_$]ofLT.u>|u+KEig?(J4Qj+.@el3`|8(`pE k"5&} <R!x H2vd*eO,<:+vH#@G K``zCAY;8OXs٭M\xmV٪JWJU#qiZ\:2۬- FRO uEUȱd ZX|% N/^2n )a~E1N5e#,Q<0`Lˎ`V `P\<2$U1E{/Z&nqP%z7 ^Ų#S0EetvKFr*F凃(a!Ŭ5ۉX|AK,65<\o)]p¤{ ` U3E^׌k˩t%o s'K ‰mD*.k܄[b9ߍ+bsMJ+}5Uv\͜ܪn /v$2__.lmv\ CݱɗzҾBXxrw^ft_*U7m- 1pf *ec3:J}T"E~AcPS֮n_P7?MU)nF=/u[+1$`ÉzLT(isz1jGʇs=޾ɋ[\q|د[l6;Ro5f}:@n>η/ϓYe-'.@B qm|<2~ND} 84yDB )AT/eTxYfxfcʺ2&VuwX18c =L,7'ׂ ճ mԀ1 7ΤQ&>v&+ !ֱV@!e=.\h>HCuc5ܻo[,^_a@:A|4=.{   h+ "faX0ՌEQJe“GglrvL'pTΫW [^ endstream endobj 235 0 obj << /Length 1683 /Filter /FlateDecode >> stream xXKs6WHM-!=t&9tTmN%RCRv /V&~ORq~ũ&VpV|gGvz)M4r0FbA B* Rc+1c {(cwS(MJPQf҆kP\:n%#7eBc6@˽+jp2&M}ā2kQf nO RpOLR08#FFC5Wrh,}:m.dSڔda_ځwܳ#1]q]*~b(6Bߞ(3)@Ⱦ5i}B%nY^0"J͔(”S@ (vyJ Z.`RH]z0z遶oA#֡(BH~"(d<-bW (x]P|Kʪ+5WIo}݄FO+ڮUxMh\E4we\c6q/e9'%.(@mhE}xjCveQu-$Ms%q#9#hSؾGRO۶D*3B$#L;adrɔ* 55z[Al Y}x(qOk qġ>ѲE՗3syV7M*/HE=VV! <{Ei_:!zMKw径 !v]ym1(w-d/p,KZFG@w=VJQ%@wF Dv+o˭ fe]1ps [30u^i89xfmG@@yO.]s]EB:,7E*j 4t6@4ȋ6k]1, tr*vޞX =}%J 3]ZVɮ螋!cقrK+b2^:2.N]Ѵasg0u fe~ Xz #68ƌa)>m #Sneְ^%GQBHdeՆAdՇ]JIs(S@䌨PsY/Z==C(Y:35G,^]Iuul `0nXQ#%zdji xM|\.wu+ٳ^c2v Q89Lnv{'I_jD->n`O( endstream endobj 238 0 obj << /Length 1499 /Filter /FlateDecode >> stream xڥWKo6W@!qH-"@@ki[JZHڸ ɡ%[)Xh||x㯹լ.d;턮XQ]K&`<{϶qɺNΣK|?dN׼fo5= h؃VawC;-|ʌ!vɌ0E2alg3n?~]&u(Z%-еSs2OЧpYқ]4]Z&Ý]@NŻ5ޅLơ?ɼ϶~ M9N k,þ ;6 ^{+y~u2g;9kgs۞i_$EMs4í==SoaqY.UrBohNhd26(dzǓ?4Bg;x|k p c&[R.$9y L0{hB6e9 0 .VL 0htv" [g4g;BO;{Dֹ/Ʉ8LB1)0b5m|k<xL놄n Id*GS>: 43nb遣&gbrܹzt~uR0^|[f2/0ɋnFt8nbme95y8Zpϸη#ss5±2 ->~ע}{CKXYWkC;1+܎' $ Bd$HF# FVQ 4g~Y$gB%ICW~,o h @qqEId P=9+$QLlEUתձbT&g/A,ߊ_YW@; *|5"ZmJUqf_)UVZjC_4UPSyjD2{E_R6`8k*K vW]+ P vRZ@Y@62Jjvi'IFT$^2NVƉ{(WLRt^Ӛ2ߞW馔 XgDHlleBAG 34\/ETSłt@;)ojSNӭX4gE,buH?k2l%,_{;yMAo ^\YK+p a 20UPtJI]3%rhhͪ "}8! endstream endobj 241 0 obj << /Length 2632 /Filter /FlateDecode >> stream xZoܸ_-,)Kw J I$}]nbMc)r4_ 9߮_WiInED+\dxC6)0qe 'E8ɑO"}r#FG^x`|gKM6|0ERM$3jzr07' t0Izb;TMX:ӒSTAA|0p3|D4@.VC9r$H;vkgٰ3~p(8}86klVF@- lʬ?:mjڰX4_UZ #nRRh6lPH{Cه@q?۲s˓@?U@1rތeRnØL6l9}a2D`mL%-;=f!("bަ-}&WPw̶E=pNLԩ܀EB\L4dɂ _I(٩6.rB-й\ULk9c.4r.J9£})\J`]&hĽ&*S}%۸qy#!3<mT铎7P\Jm;0=hev6PmcLAp5xSڳ_t:ߩRdt9oR-f~ni M{3*OUd%仔%̲cu76//ﾜNEiBj^Zϼjaڽ0گI6ĬA>|*6 i[%͊f&A]~~\zzc@ ^=}PF!k@q9gkh[8G{=ӈ(}ѷƻvgx cơUۘOBUl`OCr6D?. S>h)"ar۲6E&0&L#*:Y+WM;mB*ھ|SMD9Bi$â8"ŷTn8ȸ 3& , #{%$-lV )0qb3jǸ3U+f辊B&6o1(aS"w՛Wam endstream endobj 245 0 obj << /Length 1716 /Filter /FlateDecode >> stream xڥn7С nZhE@E^(>;̾d1Pƒ_ԯ7o?(0B/w .eb<2[wOKJd&o[_egKåLWv]y'}Vm[Cٶ{乭NM[wQ׌z4[7[$&#ᾪvY%"mEi\(_V'ZF;v?'vpxxliό Ko?| [43X/~J4=6,c[iӖ 0R?40w1E,B@t9 wwesvbAޤg7:*pQNڰUx0x_RF.bL1>*y.B11>'G83F>FbGd>+ya*dT }둏 #b|W?M 1>0f&|aW8E|Q/Fx%LWȫ%5) S_.J|XE*9Cro@^~j{;]{C,v@:-Ԕޜ+`B'} M6/C͆0ԁ4n4tםv>< |v-O7C TTk符\N>lkޕ^v:l?^* *XiV u[[pgƵ.',a`Iς.4>bq@MrD<H%\Ahۺ7P P|C+fPyQ!t R+;SI2j/9V62#$ZvJP: 6(g`x q_ +aTClTD<pVY,_nϨl+_xɈ;\ojv N@!v2RĬڬҽ',;sGGЯiPQ!l˅!aUnV) B(Ɲm"9v=-l\v$LA;.7M&AS@6}-eS WUǣ+V)v.Oл 3jCݦ9:jٷ_0$~SAj( Dt^} ;tQ1?X:+m2Ն"0Ϥo 򅆷,BH.cr1AB+Қf6 N4d)"Kw*ѻҚ 4N_1;&],$4nX^? O7op( endstream endobj 248 0 obj << /Length 4500 /Filter /FlateDecode >> stream x\Iw#I7*r_5̰yC*w%i7~;YUUYlw?U2#c""/_+݂r^heJq^/?VW+j.<ϧ}g9+Ffx*O~?ܗ۫^_FyA]?$҈F)O$Q!|LCz S$%@msE'gHXKXA$}+A[ KTՊ Ȫ<}f,SS9m,+, ?,Gղfg|g3I0pڝs[0wad(kvVc`C4 cs$P:(NbISLDb#xzY]ߖ{w>po.km(:v .o e+E@-Ayow|*w>=E?fnGG1'}ii'I̩$iy9>as!aG[{\1Q]:ݧ-Q6,XW?B#% ԣG޿?b ? n#_ $]|ϯm ;B) `,򷽲JREBی' m7=☶{?"fX7wC^ا$k ojhU0*.ȊhSioK JDveҺl1Rȴoru]P`w9QLYa*\ ũ勈x!12B x+^#+2H>80,q Kmu8񰼷!㦐+V9NѦs$"[&Y3v6k副H995b "F}F@*f1yFm;oE2> sfOAz\ 0?.b *PxNuh8BC.]m^*gA[|lM9ļ!qSiU5aQڐS~Ƒ'fR;:xm'uguS8Xx2!k郣T$I@W餹4 !"y!riʂ G5Uβ/s.A̐(}J*ٹ4ETLQ#iRzD }3 Ծٿ]$Ih f|\㱕~"(U 6#fFRYH2)Vf-ާGe\j YHSqyFv! Blsm5 lF5l !b'P\͗P4 9`i>#wW+8YQ[ J&I1eK=E"ڤr[+ 0Ϩ] LYNՈ:_|qrkߕbaߕUWgKksKЬMt,\pIQPv[o9.(C\7e 8hɘo0Hvnntp%y6AHۛj];}&L A&Yh2Nh|,L]p/ifbj9 e=9M2*GA+"xe oN梷@/x[n!CEQ@*$ X@F<0(,G0A+!h !k̥~B9[Ll+eNlc.Ĭcޯ1-iĎi0Osh]H ⮆~) R ޓ#žTwccqIDv%E,yMᦢn.!XRX~9?7I,C~HVsY>|aw|²m<(g .&Czared &6k%XWًS i@w-,qOq®]n?=oTrͿ ~:'u @.בx_.荔l+/eOKX).)lAUm9eN"f\D1͊v.*X{C7̋eҭkÕPq&< kpw~_h7$9sz9>|vփiU-@͏<;dy MM^3Fƃ2.nP .xeg5FOq-f~ÜQmZEuJ&fk&ݫ-zJLyM.KgxIOa#4Nٍ NeG$Q UyU`vY7O_ȸ3n*L-xqItnF%gx뎧LM7Ig}2߯! *캋j%,/( ؼ)+6}n(9[n'i+JB~gj3uMy1̈fjgNgC1X3Cl2۹G;܍nPLZ92P@4Ԁ#['c7uS`ݤ1/ZH3k&(@䌫#H~q5ƫ, I ad(4=4Pv װ?-.<%="jPvN'P7̈́ocvƍτx`'qRY(Yc\λT'D'RW+n`d+icMGr_Žع%XNŴ_-̓|RHScSpPH댛DӁ`vS&@V% Sr DIp^2|c>|@@ND5~%{WZ> vWădGa#}L 5:[_~L7ǃ|zFDt5Mi3sN"=&b\-€B&kFIE#H:˫Ē%3Z6̥fۋaDTWIvTImZ&2͇$7efͨ $<|!C>˭'ցEj hgj:OME@fjnr Sf36of<*QH+5\#x.ӟL =A*|Y J< )N2[c348ʪH@qх> stream xڽZKsܸW̑h@Ij]J)΁p$z9Xe{ `$9Ӏ@hOc<ab+0jϷ檣+ձ==|+( n|lEc:2 9&8RAu)l2q^'xq!EOǪD,M"Htp !>s ǘ-(ð) Dy|R}J{`cU]Sѣhi;?ti,K2v`iP"ᚢc=>}d9fb>[A7l VI͋j2bXR<(HJ" OIc_Gpھteyϒ fT , {ܹhkW/?Ի]œ/_ѻ&Rci,;Y X"8R_ؾ^fj5 eBCTx8.}"tCstpюjdegdF_Έ.8 ώdsQ2XP:eH( R;5Q(Y(#w?,х5eM$llBqh[ m% d80 06&ؼNҕ]Wef.j}"~7 .=Ytd\;6EYѰfQ<`3xBj8 ]USCl'G"g(X9bmWW4>TP0ne] Btn3ܳS⪇IE6rVx| Baaq~;B%YDjK Drfɀyب3ph4L4-IQV=e% Dp0P&pҖ>t"5Ԭ ʛi"Qa"7[LwpCe/@ \BRVoOw5bPM\kR0y xk*fخ6Īx{`1L%x,ZR3{@٢Y=@ʍ6R#O16qOV>{\o*E\ ]ߘº0NgP87;LtsnV9tJ0y() ֋@dng]@b"fhy5ToOSus`y`iM"Ln5RRihѠ{1p~5yE>}QУmLoZ%mlV3W$鹶`j sW{ B+>?SZg0iDCԝL;n.20tPla3ԅJ(2>;RȘ!jkG-@଴w'ʴ0Ƙ-lx!}1M:L@}fϑ_c Ez]-3p an cF~i,.ÒK}}OZ%Q۟,UB+3ee"n1mgq-Ɲ?.bmYhŮJEN.mxsT@4_Km0tz@o! µh贈-KR>tC^|4L}HM%]ZwuSLkH0>m&I𔬊3|Docډ,ca?lBckm~m94YDd0"2a<şK9>0D;興3KD+_ ؇{z2{ 6/yt1rB@=#6=w?߾/y endstream endobj 254 0 obj << /Length 2104 /Filter /FlateDecode >> stream xڥX_s۸ϧKf 7ugn%m'X,4g.vI4{/bX, }vXd&2i&t^ݖW'<7[6JF)mƾop9vߴG A žNmsjQ5,ڎ oTSWj(R6k68` @yd[RjWH}tn\ǒ %Racwd[qNdYs dVz뫎-ny(_*x`4sGf M"&o2Ȑ.~ظщ:&!)ܝu#TFw 5#$T0^Y1)M1Xz H%̴[1b@!L%(>w[w.ᏼ&{:pkW-x&U/ Ah( f 8;w=2du:V:*'uuO;?:{Gↂ ZD54Pcv̓ %er($h:,` 7Rr$3'ht'W5\n&(볻s Z0լ:,8X [c9Br7&BK=1QHpkGnwn!a*G4;B@u ss׹N1n,5&Oac-4t$t^$ꁊO˲,=tkԄ&Y:H#C",ȐgoL&|wpjiy;:$F%ť:,M;@ήdN UdؿćvlhY1rV2cE7;ϲPX>y>IK9W+ђ 3KBofK?,.& 7 %!L_."gҞ!uCc(jH}"#\p>zg.4|a ͬ:B[w=Co$En u博`K4$8-$67-6ܤ63ˁ*Їa }wܹ9x=L37ܖ^Y1Zr=YP_O}zîIp3Pl6ӏ?>wN,:Zt36ge#jc媝̄Z]!"j#Dwd$ .\^!X4[nfx|xO.0*%Im;D>5*V&3 )ȻB/'e W5{i(yx2ߋTtؐɸkf5]3a]!*1+v8+(~UЩ_c+ؕ~ ^p•2tW6$_?(?6 q^MC_+Ʀe(e2ߝC(m[ :$Jѭ^M endstream endobj 257 0 obj << /Length 2070 /Filter /FlateDecode >> stream xڵXYF~_aX^!*@,zIq{84I mJCPæe&ք׍Z]~uDB:ME Аt "&YM Aj$ɒS7mDE׷i苦:*׻/oyϺ/hWmK`Oa:].L}?L>kqg{ϙ˰W R_jE+:`/,~ueqm)L҆Ƙ~zmN}VL9{"/=+  /aU_G~:IQAz]K35j>FFcұu/RGpBʑʝu>R[ViSKӡ{W}~- ﯎B/BZlWm {"w7,PIlvp+`wm2?vtEH3s"M>$lsJ/k6b@$:LtSZp4o׃ ?x&w%-&0!b:i5ٖc_:(xّls!Ʌ. m zP;Vb,:aZ8N f@Ko9d)jVj]w(|:$U_MEwH,9${;h}ۭqsVMT=uD!6(2O.k;~ ebo{w_ D2#ƁOU.A^XX -f'd#@ό>s@Hd)қ'6ӛJ*q"Nw[28r#GN{(&_ d_xoK B0ȢsSt4ںOՌ!Ȼ>z-Q 7Ě)| 2엦d#s0޲sWPG"~/eS)t  }7Ƿ̷Jr؆ a]v%C}fqEkXfQ>=7=Z@;к`<׶pP,2~V碧nmsNEVz,j!2|#VW@2.S ;\a+}T͖rϝr #K p?!uf0_N! Yx e8TE7^ FbaXqNSOReC&A+)yh!D©w醁)$f8P cBI>v|ccS?OQ;ǜynjnyAo]gFV $<g5+BU>ʂ!=SAd%|g~`%^i_2&C^^ Ր"e=67HэW18WMw$P \6v1<* Vڏ[ #%Ku('Z8C{Wq?;c圠4<ѝ9|S/y:dfgm}0ĪHy/Fg<%%cw endstream endobj 261 0 obj << /Length 1400 /Filter /FlateDecode >> stream xڕWK6WFʨ͈zYCnI 4N.=+á]e[. 9~~7z$٦qg(Ey~8[gW*r]Պƪ7twufU5j)4q)NsT/w?gK8 XcA?iűoL{rE {G-*))z\ pK1PU^Rh٥CtY->|zTٔ#trS`M(= ga%C1_r4"cJ>;hG-N O7Cp|y]%1 5jcGgk8hJtZ4P9ir=8lRh |׳%k?65!Y34cYXNl\fJ#]d ?}'#.Hh%,p1V"QR e&금B8+LZWqMg7ʍ> MN}ۊNVe#OΞ/l+s+P[@&g`v"$m4yx[ etG 819#xa}$B޵^5eGhg-{UnӂLNPФV187End]YP,{b/tXc-X.ڪjȇJ hPVAh+4Vý&X0 ",:\f'{I]PmmO. Ny~nrrdK&7ݾY/4D5S><|2:Fs<9 $ж$Իu4Rz#xH6G"(R*/8dQu2=2:paWf;5yIE-M΃bbRQfFdG(a2nQU<,.!Yrqw(ܸHCI6Jl$pN)s`Q@RꓲSAM@`BT-j.бH6`VMf^ }, \ |!fjA4AL}aj2ň',`A\#Q3 O|7nLߥ܏3谞+M9I~9WM1vuϱEhH{Ϋds6]G@+N/L w>7̲ PEe~e/{*zvwS0eWͰ8|-Np7j Hl-i6zCu0ؾ/13P˃_/p?n~МϟD<]iE9b<IrDͳ endstream endobj 265 0 obj << /Length 1370 /Filter /FlateDecode >> stream xڍWK6 ﯘX+zX~4l_@ dnM[cc'~l%Ec:`LQ$'q;,ri+/w_XΜb鶄?o]}B/7$ٮ`E*J,wJrlwvE>L3~/tԚ =?"jI;>۲>=?Mrz(3 'e :U}\R ,ΗùHѶ7 i=bRG_ѥdN]r&Fث`֤\Wmiހ&T~"suiiVGKtl+~LXhFRz<{h}EMX7{c< qCT*\ĢLJAB,˘\no_jJX"/_W (D@J`z jv1ζxcJ&b$ϖmi=t] ?9LTCӐ+GxH7<ȩ[6a$F{\6IPَ0{5)KXuNnmik5:Q8D:NIxb$X-D]1BHH u[QAd,ψ,4VowxpsZHkIܴ^N>gGûG'yp0psPٳ3 [}c^dl>%rfY o6w8K˄f> /ExtGState << >>/ColorSpace << /sRGB 268 0 R >>>> /Length 1046 /Filter /FlateDecode >> stream xWMo7 ϯUI0!a:@x }iFᤝ$o2]5}^' XOɳ7I%6A~o?5Z?/_@Ooߑ?& \O)y-9'X2N3yLt3`b,΄@F3Eifgb$؈qV).GR0a>/p"u,lr!TcR+8ZS\ɓ cv⬎JaSb?+kB$YT GFaײ >AfR2|fa 'Mtfᐇ|9kzE0 Ť^X+Vh>Y-dw/ &.Uհ+Ft>cyHy(6uf[}9zIN;+_Z1=`75zv>k)V{]呇n_猌o}$ tGch<HqXyuzVΣ~+U:/tY_Z4jYEɥNovm`pewG|7u#Y ΋DV v^ 78ָ0+_a'w]JzQ4ӈQ6@Ұ7 ֞z:Ϻ,̐xlemA|uArZeuGMZM=`>-iqy,> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 273 0 obj << /Length 2314 /Filter /FlateDecode >> stream xڕYK۸WmL|VYvjHFВg&䷧ !Av|@_7?_|W9\wW~~CӁgȿqn!b-̵4܁R9lQ. CDXSP[XӃ/̻'v @*[s9y@2^=2Dqt0^bArF 9oGP6C V^[ CPNHс9˲A)ر.XOP'Vl<$ rn`elF,=G'+ ;pFʖz|ivMYrȴ9\C'h49V2s3ek)fb?O~)Ynz̹CAχ!}>x)KGݐZV& f M 8B'ٝ4[CYjή.V<1ڨ/]>"uQw\H~P LAR&MIͶi[0(F!gP4}_;2,9 I "ȦzR@ǧ:K;BxHxn< Cܲ \O6㿉Cx'1tanfkJw(,tNnpVQTo0a ^D4Զ3=>؍]jV9ZuVξ٬F*>Ij3X9p )<$&6]+2a ?&S4v]}¿)s"(섛G7R:x ^;l)|Z?={E E5uo}'Bx4n5`n;ȕa)y9Pı/"]bPN iH`fZ\/M'g 4P7 P֪Adbp^]QDnldѨ|fb@ɲUx&AI^&PLl?@á\uN<戁-Cq!>RҋN,NJǃGh^'C ïIY MFI=Å4!JǝaE,m@Mv|ci/ϨspK\Ix T~ 0e2 W|coަ8Y6`y0G ջzgJ](%C`d_#}1Yykw9 `$; C+ݹ98Ќ`>H%axi6z:;[ʭ\Sk;ꞾAA^PW Yg&(u.lti[3,>dJ],}l7^”>G }#g]wr], 7'#8tyT']+z)l&WrIcIh KeNnmcfq^v*UȖ鮀/ \R#D?.MӜ b%p; E7 endstream endobj 276 0 obj << /Length 2313 /Filter /FlateDecode >> stream xڝr}B:L ̴۵w6q2^'NZZH={HP޾ pMsA t*)B,$c"Nſ [(ZnWk!e^}na7--|M_62 Zٖ_>D&Yd""T.ww΂g"]aœ-'\r,:C]D?y[Z(Kd5L'ygS.hߕ|r;$cOyze5KҘ^Zo+xjNA^kDU-mun,/y;{saPTt_h..BVey^n/#OJm6˭},[Qj @)P&Τ0YIUPWf3j[˷8n?ˇF-ReRͶ[j CU[27?R?ѩ* (5=f&Lej)o?xuO>[+&S<NO;} #ON U.Mn oEP>!o}&> @(,ǙS_40L0ntPq)3Ԧ5C%p 564}a7I)sĻI7ȫ4qY'iOۛǐ1K`fzK7篥K'q0$]|7aB`9 z[+H};`szD9҉fY6r"D?ZhnYTb; Lů&?z>*&󭝔U8wwv |ar || L2Gf!y\OɄ\UɄLL6d.+K-(+&޶EwhQ?! 6]aCS*X "LDD&| Ys?Ak2QW]cg\DnGSC/uvOgw5ms>,D/Hxn.3ۄ,16{-SJъt_lX7j|kw 3r)ɿ=S, (WīI^HU.gGP_i3ټڢښ ijrL3 gQ6-Ӆ5h"Ժ~gm ϸYp>` 1؀g ^I음~B=cZL3Zre\6cy5j]Zi8SGa]T,`+ߖ P%tOڍp{PfO 4L4X? 2; Y!\w\\9ROX +_ g)R1w)9Y]ąF|tu%tbӨ(.H5䦤0 z!mxD&+s+k(뻛_B0]\@ =^VH79bao [QAe v}wFii7җ:O\fрMڏK}c AGm+ܧuPfdOں֟v6ۀ^Znd4>f6 `t/ pr6 ,rΔtȺ^C^)qƤUNQɴI<6CI|+01m;1+A‹1.Ad3{; g63mOD-Fim9 g9N'w55jv&l=m}G{zy1>5@!QgLOyWwcho(B3y)_cvj<{"o?9> stream xUOn0 mbmEhgomYױ 1WjNGsW=$t+ZҍK HZWF:i[3[.zq+w!.ne/· &j"Rn{T ˖l^9l-Ck0\%<"H+p-BS sX^ 5 4h2)&_V:|Ks 'A"rV d endstream endobj 282 0 obj << /Length 1434 /Filter /FlateDecode >> stream xڕWKs6 poLPDI9tf_鴇3=t{eR#=6/@Mb?l*(Vrٯ( RT2JV/v{KI\ hdεEag0^ڕ_Dxi> WRuB䫵Ttl*{*pQ^#1Ł?MⅺLq6xyA*'s}x0@wz,f͞E1:cޑha}>LFVUt;"qMTA$qb?u%PrT0 3Z[i7V@隺7,u:;D K 3g)&^gn9(s$l̑0@D:ڢ R>Y *|)8̱B 15Q".+:?W_^䎸?ʼn޲tkJmajF4Z& ֝#LLVƥ 6=$r*`Cs9rtnc1֣i3klbӽ |cٮZ/!X#"_`sq ,2\|QBe5bAa뚛W4(0ea8@ę;pP)-ʻrd?y~sDСO怩u@LGZ Zzv/jvsX9 y3VEwù>¦0[L{ķA_Ef) [Ot.eu(gckfK*QgtMfDdo+j 7hb뉃Lg_>x I&l?F*3\dFֆj{4& 08(g]Q!H# /M"^{JoA{DSgGv'ⓕze`gseRjΕ..]xP>'i9a..pB wJLޠBlny76 {WG>͵,rC`hi2NJ!"9^>9ys8Ѭxl:̸&z9;:N?ϕm,U vQԝ{^ Ts%gH|!/?AJqO]SoH m8'ʾ3Ma[f.Rçm [Y 9ь̖O5U<ղI)pu'ȃ:HF!XҴXRHb?T!+ endstream endobj 286 0 obj << /Length 2422 /Filter /FlateDecode >> stream xڭYnH}Wm@Qtcg860XLز֎Zj蒤,Rj/^,f_\"Ujw?3Ccyr& 8=MJeΞg_܋k" \v<β0eO0Kٹcz7DQp.e_x`% !K<eҘ e %,"z ͖Ǯ+vENk4 m=9B0MWiݬmmYG1jYWq?pIC>" Qd I/d YU.+t1& lG[=kYͦt-Y}UXd2`e!M]&`;B0FWu 4 +vtc!o |^GeuElhuԯ +~/(Fk$NT0j~d7-iKؤ[[iO, m]Cy7>pM9 S.NG0W R2Xyח[dbR2{S)CGM|kp5ƀbtaGmu G@"_:禮UQxA MneSiV˾zM7:4./6( ηpKq厄8(K@B`,OLߏo%́BJ0NB(=XApxpx~nIlih4:5\E|0a4;W䵱AAA^C-dS!(/|`)Ͳ9Mvyh09AGƷ"h$?BB S@9PPBd{2; Id(?Il fh2H1(DC{KCk+g9?|H۩-*I*kNt@j<߂~Eʡ4l}e:0_^)]rm=p=X-\ӒhF/lBooǖe,\{C9kG88C)4MHGM3͔7?7e<1CZTt: x ?u˺[xmG28GO]`{ްkهVy9oRBZ#Q nOyW|^a4XX{XJ`v4cHv* DA)$sjCR6 I1o)ҏPl?1ܐ2Nol+><żVTkpB1Lt`N"&9 ]^8QZ4wb+gE|%ݷ鹆r9A?6ͦ,ܒY9 gxؕCsl }rq3M&$ऀ$/ @]<vY,Ƣ4M+nb]omq:$lX T)1[xh9<, Oig#50D+ T-MWQ>8`;chW@06Pgs0Hs)֬ӎM'!hTnK0z/qŎGr^j/"{$ n Nl^poч߁Z{V.ESI/ 猟'DsL@ϹƽH:iRjC3I6GDŽhG^#[ǭqa+8+mgI7(˾äUχPkDQQu~P/!1aiDFCh1HFcڕ`߁hǻ[%rKc~am - FR f UFQB) L++*Y5;G}Mgˢێ<8Vcω9N>&9=hGҡx{ z1\xKyw秔@nj 1$Q Us١#ylqtu 6D-g{$rۆ"q`xU0Έ܁wQt4{i5I}.N;8n'ʿ0 3!GO舍./7n9^X lg˷$AjwAqr|1 ~ X#IURW0GE<ʨW8_ƆQA[ՖOI>uw`YJN7"._3HEkc7C*d|/uH{9Wұ A!I%C:0Qߡ,LS.Ơǧw;9 endstream endobj 290 0 obj << /Length 2520 /Filter /FlateDecode >> stream xڭXr8WȊ8$MlɲVXv̴bA*Xd D,֦qbc\^o INNRcLqyr833NeDi]m/QQ/hbgښY*GS-7Lʣm۲U0UeGд闆:֔C5mGm,M#OXKiKUkϧߟİ.*šlM[۬L߾c`LXHi÷ݕCe 13&gz,Mid>4,,N 9'v.Yɵ<:L qɣ~ηWEt/cd :u\h$|0; /ض~'΅ {[/Ξxz7t$U|Ien }ZJp@ "9K,XГz9ɡ N" 7 ms]Z8R 0޴67J ,Vv4ȮLw)_Nu.2kw gY=Ioz{S%|ߛHbeޛދrVs vv咆(pB:0IW~. KUzfw Y.jSQwQ U욍aF!|Rfhk71>PK:+nX! N5Nw]SZ@:f)D' ϙ#Eg9*$JXC6 ,Cw:"cabTM<0?:zxF\NtF tZ| _K?Mm"(Q 5Tf]36I!/*MxpƄ6}u Ig"ߍ9Ǒ#]%N&\aL P }tP lShʃ0ַ{:QS汶Ip?YdJ<Y,*9۬q~ƤL}E0!:XT] -R,A]y}}|!F`x~@":_7T0 pɢs^?v^nH&eh[ hêK} P1 w!݄8QOeAtOuGց[[yΉoÔG@G+Kr{@7|*yyGYƜV8 2XaBQo묛\wmt7=~Ϳ4Bm"Z8KHM_n5t}z ׏:Vb'`A}h,b.&XU&GqU5 t?75഑A  ˧Wk9]zb֋nszP AVAv66j93E7T<?-=p^x+K ~Wr2NvWT< EWOb:캄jiׇtdbS 5 ˜D8zʯkC"Aw ,tz ̢|:޵%S{E FpgZ8HivM2)2p'+Z/\;Z2yvA[F$(A~o@y]ǒ`S2/Eƀ<;p endstream endobj 293 0 obj << /Length 1090 /Filter /FlateDecode >> stream xڭVKo6WH+&%&Y aFe"iPrC8k8r}3CӒ-j\ *0KQ-/1e|jwFd9/ topӢB6m{5KRk9dI*o/ s(OKAd1U֘7tN I`3JB=70'a@GuVQq,%SF9٧{|N9C }t2GݶǏ(= q)= 5eYXRLVG,oɺ8 #ރ1*ÝH%Q.΅ݙvrll O%o8$xhQgsp \.x8=msE@K,a|yo${~ 0UQg!aTYWrfb`s^H^z뽖 endstream endobj 314 0 obj << /Length1 1371 /Length2 5949 /Length3 0 /Length 6883 /Filter /FlateDecode >> stream xڍt4]6FA7BtktØafkD aD= z-H!zI<>}kֺ眽g_`50WrB:@Ց XPS`,Laۉ8̠(4  l Dp@Ha0Xo % B|`ND@D*HOr$~JP W##aP?Rpɺb0҂"0 E@_-8W/1 AAs"иoZO(/_>BBJ'W"w0 A.3  `0| x8ԕ ?Q0O Z QW5!TPM|0w@"9Nοp4EZ08ѿm.P %%stU)ˌ!( 8ڀ?4 `PРtsG$$81 wv7'1 {ĂJwTx/2( [3pFRwOg.}$PDq3X+J>7C<`p?s18!qZ@7tpia 8-(!\FZu2a]_v_BP$i{>8NvAqgI5#ʄqP"ܐq;1 @'G'o$ (_q/#?;zP8y=ZBDSHGnU*}8ӹPoOȮr?:TJm]Q:Pf9n&ٰ4.hdmNfB&~s@[9r% |;4;gMǚX/9Nv #pp8F=E;(h'V rQ8x\0%='tE/c&$L?H1c` 6G== m՚ 7s8oT94{2`!INon욶&K ~y(Gܜ,~v|U2{%o}Z 5^tlM~U\?.ExXKwI :l$}>/hIp9 k\_$I|yȧ%LL$SG;}\~meO=>bbR&CM; ∀~66l k7rY&\љcy ezɚ%i)M:4]͹Z/nXpՋy-x2L&K >h4-< V"Wgd-.FBNlz"n| _v{Ii7MKn\{P+ﻂo ~GBNO # &TeyM>(C)O[Co=qj~Y%QC@cpz(WZOs9y lE`j\L5_7g7ޔĝ-{3?\/,x[)N-mLM:i%n-6>m-p/].tX []>\{ds{2j7 9qךBnwqS,׍UgkN] ~)(T2ZJH W(IGub)}3+2D{- wؑOtoVn9ϠM*d1塥mۧ{TP ďSZE~Nw$0n N9{/-)X+(俭oD[+W"ʮ,R9fVZpʺSvoe.6r}6&[* Ōw譆#1e{ebIj֍^y̵e?.;kiǨ\ e]|Q"i6a)ݨOnbR̪?.~M@Tq, UPJL<9s9Nu9FZ&WًWnV0:jl=2 . o\}aNJlHn7q:8.>ݑdF}Ay ,S#1{~wpmqZ;WH/A F'F܆L =:ՉIѶ06ͭpڰ`Be$&>s70ީRXRC1Šޟ=`½K^NZwsz)V2Zav9Wйl""S*yh){[w\We1uyF ӱTW6ӢԠ)k(̾>:mF%U> ׳7(0Z Μ- &e_&HK1Nʩ?nB4'h&#a.siEDY~D־F^jiD5ق""ph;x͐ҵĽGX~>&L/E)!"qwl?&֟ Jg"Oh+>d +T`*h)[O1 '3OKTQ0Gscf\?f0,{xtt#nʴD7 Sƽ߲*"ѥإ@nc7!: ?NkQr.VBVZ4';ey3?U3fe|o2U|jGMd,#jCIBղ$~pD_Q+.-- [7𭆌U*\EdpOY~\w=fГ;~>*AFx0LQ7R+,:O1$谫l]~|E0Wd|NOS?* R5=]@pX`flW=wإ2M=[b'_]JT*|:Y !HyY!vv䛒' tZ,?>?^l _t3p1y9 : HXۜQN)ꅴO%y-Er )f.K Py8Q[a7GO IVŕtn k™8R$o Nmo"}"vuã:bzƭ*007!ՔY,jt(\7bO eIngtdPD\Ww}2]TL- %sL%~@v;GO8?zFTry\GwԱךl}w@˰fnpvA%T7x_;.0,seqԝ:pԴ}0, 8g$֢pQq/akG!i1ofZv"!"D9,?, I`&tj/ S#97{89E[MU`Ygl`9z?N}[ ȣ} }aw1s6ᱟ|Xٸg|gtAu)ˆ?Ǫ7g;>gQC%mjf!VR-2;2k,tg`Gvt7lV?,?c4MѤcR&{(ip,VV ͕d_o<?T(tEjҧݦʽGL n&|p9! ]G a2OUt 4Eб˚TvOD:pje^J?qL((2Hda4Vn=)>: =3,, qKEڎҽ7[ri…l;=hδe>]O7[7P%mt\3MhG҈kdYqLүw$aUFS wU ]JS7y$ (R,]dylNM~ a}NrCѫTZ(|7;͈i'TlnG44rz3tZk%>cEV@='`y1 ?/=K%y)b5&bwA2-Cސ l**>Upkh+(^$wGIa#^+\QqÐN߀o4Ơ'AS2"OfjecS[xwlbJфy_hm'x{3wãʶ5,ƏUoj&rP6j3 q. 6z?@>\U5ߧuJ(C6'^hݡ @h@-Ҋ/xd_Ҫ ]0 => :g|o@m-e[\m%P1x z#3ƻNr\də$_rW3%̄ PqkOIu*2)69k/H Ϭ^記z% ~ GEk?p8fhD29n8*w]y#Mg*boD8I'r_~0*moS>pO/Va24Li_(a͑.)NmQSf\ eM*k ..Sֳa0=☻QZk`ޙZ~&\t뺵ne8R}ޓeYڸ?O^Q5ENvrT(VazkXE'?5ҺCuӒ-\WBe3VQl,.HMF2497ok)VN/=:Gu9w;:> stream xڍuT.]HIwJww0 0 1twH)- H t#---szoZ{NKCf VA<ܢYuy#n77'77/#hvsYȺL0TA*N>((77[?07QbP`w,FY??, Vigԁp{CF Ap`]D807; Vvn<6_-4ZbC$tap/8A@`xUVhik8N+39>h*q½ !B(Hk՟; wt8W1Cmda`(W}r70a>\]#Ն >V"B+ @ ~!}h?|a=8w', X P?`?r?ȏ/N>q\J*FFl7)#q8xE<!!^@i!2އAfϿD׆K ]0q pE*+Rprgx3/z@ 65`p:HC$] тA*O\׮9A`-;/a@/,Pע nn@k~8 x6\P^Ny\n@ r­!v㼂&aP?Ó.""$ s:@]>{ፃw#<&ag~kD7Q>xb~-/BgW< hk~.Pgܿ_jy=d"ӾWB|}9dL2*`B좑;noHB*x \&HoC^|*Tl7d6Ҏi*B怄MPoeyfz}`R+[-Ph>1@=j%x# ̕gˠoMY[)߽^yV|#iؽUF@qV1rtDI$!M^"7dsqZ`?# ]74Z ,%s 6~G'*^z xˬL:OSHm뒕r!tl xCΪU]K޺r<j>*tTn B=ZxX3h&~f"rZl`X| 0aWg}yAZLmR'{ #諐Ν_%oB6󮆛 `muBce۱5;Go)Ww;)xIWU-ϯ-g{zֈC&2~E6Smh*U!1#B(Ic3>lU'˜$ύAkdW]IZ16F݆0K/L9X¸JleILC)yGv)x r+%"JH(,j 6^ɚPT[!1%og1I^jt0:]5L 3Y=]Q6//c~|\N1JWx tA˚@#z\2 IUȪĂqN[(Q6[՗51]ʍջ BYJhۧR2+%uOlQdMDdj'r1Ff\W{vHNEjE|dlI3O ۔Pm,߰k.ՅldlG:{}ҩ_OPɺP_ؖKfV{gr[퀭!SgVLrrfs) =iD|:ϱM]Ix "@ݳZp#ɬ}V َ G|$k::S1zaSy?pAѨȪW^[KgYeiϮUQO{Վ~Rל f_v>m%O01*_mE3E,ykfč6fkc YӳVK'm\aqz w`!BAq3X"'z@ƶHq%0wu xN DQ.5^8l8պR@[?b r;DX OF wZ[ )Połks%45 o"?WX`p;hɽ;8EV,ؓ7O>=<0*4x8&Iy=b 4i|9yM;ɅhRLʔ1Bn)sN 4E1~&<뽍FzsC ?Em:ҁsC=PPu'Sp!,|7p m#kihĐO)K6py;|rʱ)?-*#w"ɓdk4D\Sk F[qlu(s) %I-62avԯ{?-hu|e"ac]!>7CA8 iNo>Qc]kԖ@**IQS, +x}SQx ;Τm^|YV}~'1эCSc"3T6W^iC[/)oBT { )gcЀ·G2[Lv:dHi#Cs#) Im,ʺcf! M΀bg8}̭߱,kޚхhvFN2YCDE dل MP%HDƳ |ƣQތ(l3c'镄(%p By649Y( +\a ԙ֥XK},Eԍufp-nuk*UWPNGD6 aw 6SwZxRۑD}Hr`\yl֗፷Er`ej-~ I}QpnsteVfzCYS9G-y@aD [t [OŽ4=#֣uyW{%|xmbvRߝь )Td&YR2O}#1Ϯ=nvu5tq}:4Yо,&fDie. 0a*hs}nBqLV M=;|zp2*"csZ!4)\OL- *InSp$sYfq14׵jFΥ2qp{8<6R,Yf9)Cde5kDN\tPGfz|ZCe6/CE9zԶoÝ7Lqz~nr%vi?kfS:M0AfJ.;.&w` 97tnEjcS"~l[pbVH}\wln:pZ1V|fBGk;D(`"Qif~G"gp2E}w}iLa?]&'؅ 6v3w(d.7lpeC!_~t05(75xJߺ#\ݿGRVWYU4qPHNfY" )셎əCydL]èa0VZGz_wy.1*5$nrBEA aA,E$U!_}\ٕ4/YmX6.ڶuVjpft-P^Z['#fF5vofQN 7= #@`g̉&&אX# @oLIJW\T4tww _ֺOLiX$q I3Y'ɸwr.,Ft),NT~ZrInoG<;b#{,۵ף 90 z$8h@4lP!|$A|__.veț@H{ACV0|*IQNV6xY(P`˕T2SRNt<nߋ?ӀN931o1#l m-s(?̢"<"op+e \#E^!䟐7z W^8}F0sHv(V_ [k#0~|Un53a@SW{6t3FJ.Jrˤqse̪_p/ c mf(jIUN0c9`%q~ɽ>>=(H.;Kel; gUIЃC1p)zs|={^pq/~N{N{gbGs sk MyƦj}gCT0 oW؇oAZs< 裞YK6/nr9sڒ>Gߍ*v ߊz\H472-k,/Z4-= Ov&5xRt, F(K_475% C#3KRՃt+1EY"@!yKb&<U=U NcIWe'= <y℩ck1n:a!kv"A zΛ/r-t4y )WTKc+$frT*+ ̂:!0fqQĥI)PvK(됮Vcoo&V]نD^w- UHN}({ʺ9ށ[ s"R&.eͻU5n-ZCFE,TH|u` dDhoy`cϾ)tT sp ro. *?M?H#tԚ,D2/rsĤ_)È%тT9r)D!ɖU:8i&h,$v8 [T%ܶg;8tk/J"mLU Q xB2`l7׸QiRHˋe`.ºF w{+: ,/<P|!/b.5#TK=piie%՜E뉉㸔G Z yp5p/ {⾜5q>Ơuϩyԥ L6}8&|LqԺBs((IeXBe+Sӭx6@i.h3ey>iJb9OL>lb[,dtuقn? 7U| 1o(N#g2Y|\僾pwUwWI2x6e>w?,U;Ǟkd3(Pμ[D#okv=RRЎ'&k-PvuPDʌH]RIo2{|P2ǘoH}[yQqTHEz'_0:*a^֘IF+ƤRwy_qCOA]4%nL]nWիT_3H$1+KzWғK?=(C5C"W(D[ctP^{~OA۳1Nn䑄^osPK[ÛI 'y3\ VX*%,(v ]:9NdR?Gqm0e4>cų7MN38ˀgTKJJ1p&Ee,:߄=skPsFLʸ$PZlza ~LuuyCsGF]_y.wbؚ}v! bO7O彉oz4ooU 9!lh ԨF^2br:b&tQ.@Xjx+&Z+((;}y>栱4ٷ Dz'SJ]ҕe r~_F=0B_+ʼn{,zCalEj}Ad15a&kh- ME!kj/t$L %y'o^[Z!g},:nU,;;\!NKK`m˅ g l8%<' )7 \ΐ^]fR 'vr? Lpݺ,!tTŰk֧D1!H`fZVA gǮl+}&yObgw"b\ٹodbG7b TtZƱ-m lKwTӯ,9u20UEv(^k̵GZЦ:-S1?'ͱ*A`y~m'3kKj[)v(UJaG/ 4 zJ&;YH>mץ$ߺ+Oi#Yς@X[g _ʣ}M7an B#9}+q TH,fD1ԫM)pu Ww$s}O>ъHMlu^d-$9U]RBɼ "Ub4A%6݇ @~癃WGlxmoz_bFj3f0; (Ӛca9v}<8T5-$Mngb>YH(}{%;\)|cqs@]DO,]Oa(fG;18ϼ&YvD'"\h?zk&=+@ĆI~I/@Qq*Cd=4杳oV/q͸+&o[d|bݻ\ F " S)rc@Մz;9<| b77B?X>6a)-R7*B$d%L$1OU~dݚ52n+.Xq}͉ॶm!Cfrb%&pa+7E̮EϨtvktbM$@7 , ?o;^@Cm":^K{?ǐK\Kd d jk cN۔Ƈ<d&N2e51:%(P6,>HG$|]\ǁ/2Mm-9\ TʜF]ad,R_y^rn5aN-ꔈuDPĨ8Y[QGз[A_J\Ӆ۪ Z('z{?%l{+y8N|ۈt|_ӐwVu ֑\s~ID"[-%OR1P`5pq\xrH왋V_գrF@~D~ }¤V"LEx.w~?O8{hHbM Pdmװ#5aNNM#!@=Ê47{*|od铡EH \)eKhFϻdIKy ?=Cq)j7umN7/}lH8}a 8~B4^zL5&j(FigjU]޵6Za/{>O)ЪxWeVjVBic kHl86N endstream endobj 318 0 obj << /Length1 2169 /Length2 16820 /Length3 0 /Length 18120 /Filter /FlateDecode >> stream xڌTKӆ < !>Xpwwww`=@p!8_y_5k1U]]]wwU3* TdLff01201 PPY:ۘǎ@ad Cn:;ʃ2_l̬ffN&& A<1 @ 3uBٻ;Z[8G15a[SGKc@laj1 24uvT|< @['5bdbjK2@hkoi 5 K ̜]w/v&rE{S9ˁ0307ܿg@cc=`fic PcpvsLr8]6@wS$wdhidiFƿ¼o( ,Mݝ߇kmrYڙ%=Si:ؙ8YS7c ƿPs7{/oO{=]ρ%ff3fS;Z>33+dgG̨,#%Ao`rD9EF (qKF=?`cC1%.&?^ Qz_]b0C﹨Ci[hco{J% eF/?"?1Lw)_-wy^[m߳/'b叽yb ߽هM C_;y;y;{Nx_Twmǟ;O.Z?].o2ߋ?1Ș7Ȫ!Nߕ~w<^~HyP|WjvֲlU}kϝF&w;zbsb;D (`)"D<`J=&惪(^])1$8e;zʲ5NTیFvop>nnG醧*du= $֢n F˸^8j ?疺g{Ib VnP7(\Y\P%pZ&E1x<ٯb9EC $vO[" u_|"*yr(N>j+EgYDqZ,#o!r;9M\ij%A~Zh\,jԑkyz\wuP.;FEGyl6ze?33~o2NpuUKOnT]a~-&  )?ah'^%3+Sȫ|1cEp)ziGQ›c*CHaBlTM[n$l=)RG?w~ 9>u?2.77 ǡ1+MRS\̾M!HGI1:(܄5J[Jvv2riS=NMy2L7QW[L˰"ȗU;3%UE9FjKp%7+̑ق>`0oqx}`rMhm*THi=N3):kGeq1D f3>€F_}xd>^FG92j{ʪ r5)XOM*Ce$‡ qgfõ㡵`p-E{ߤُׄPenX6fuc#VT-kvaȈc9ZmB2Xtjw<ؑY[3߅s,u:-j:6@`.5Pno!MmRs./GbHs &d43\n2aT+{{d A&Йk/PLӶs+B^,VdPevRN+MG$.(UYdwlt,&dE_=HsьyU墶] *|l}O ,6X}W !S#PWA8{$KV^6aBӧ'[$ijY=ji"cE~Kd0lveV>miO7c i:H*Gyp`? =cK;7s\Wj-izdto]1|paf(.%v4!jfxArx2haM|]g, gIz9pMX:ےҎrsAۑ'$4$a-b8|hU:m{V= ~Ѹf%Lih>\QOU;_A8H}(!gH hGӴv`X3E8)ܲ/Lk㣭j(koϔ=|_ߐЩ0:a8^=.s j&E0b79`>4,  f%#{)P&%IΫ3 } a`?H"/S_di氙G] %HCblX]rj9Ku+lPLuJm-؞q ӌKCKTƙY q+ hlk@d vwMY/ fg"+` % ]__Y _\^Ց54+21Xƚ&4I30EGVuPn~CPdhuMNGpZDˠB @.4lmE*%`.ay!kr5brg)#tF_o𞖦HU|]G/^} u6L1aTX˾pig?Z tZ_R&r h[0 "V* ]Lr& 7kt?} o>rBU}$+-k3,Ṍf$CPqdDYnK`vL}#⩬=:%5-[3i|B6zŏB#Dk)C^0 3Ҡ;uWm= ]~;` Lf͋N|/_hӄ)#FZғy_==\o69OpS.A0f|4fa)|aQf-#:m\Rb@c`0c09{[;$ +$TKSqF ζ39t Jw6t75c＂)!1+\9wfYdc7 IN\}~b܀9NeNa>)撤@ ~<"3hGnwNRΔ,L#?KŋvETo.zQ&pp7@/ X}!Z)iӖAr<#q$ش` oFs+xگ xu!h7˺ ʤj}"pWwݬU'۳Wb;^[6ԐܾR9M.M^i qҰb=GZB3逧L5šPGR[oBƽ":_ÿ;$ȫCKi.Osc}ӥ3_&w2L,~/рzn>3Z<~RX1&Y=؊) %t}O] + käT8c1>FіǍ%'L‚'& C,s?Bֶ9EcEE~Ea9M\af8TSu+g$153DԏNBfF/&('IH{^KOgۂ=kz~C W6p\0Z"^P+\! ַ;?ᾖER1FLnjBRGü&g7vQ%Ss! #?, %Ц(r{"rGw3T۳ϡj%%,+-,s̍XR7fYQ$-˕Mp9u3dٓ Q ubm0CboiDZh8ϥ& np]WSMSbM59wUf~!gA=KNbziyNS[B\j,lPUelkG:N3֣tS2Ky]voRPʷGj%=lD ~-D ς/!t a{5S KRK$`L" My]'>vWa晤4ıWe+h F*HTqħQ~̀EҢ{_6A5eUCQ$NS"R>bD{{熖:g5ME 6E7r}˘{Vܼ1s.YIL3FЍGf%0fTlcG~CZUEѕ\"%v@Gz<`ۼ諜@Tx(,l'y3UBOP%p;s*FOˠ>i Z?I~yYQ3TvI"n& 0߂,)vUi&gNFX,:۽ؿ*+^6,OUVn>z͖Ȏܨ_)Q #c1"!_au~|;Ⱦly}Ť-Tv{|HO3y'ܰQCMGCmtOjѯKgR)m{o9z86+ktGs=N7v6{%(v1#ۘF=9sf䟴-B ˠ؃WQ\!?Qi]\ڏ.e Ww Ɗ]n"sJ~Qy!K{G%gOW!]m gp2cx tIN[NHs^$fﯨ{YTʇ͏~NM!7.| zU4!H+xW^voIwHEDDf_@'u+qɄFx JIEt[H8^/y [{jYӍDۢ_6Lj.Ef}"C\qLǼ5!]7mHڭRLħKTN؟C+A9``3xtȵiXw͓6ơ*3>qTH6?5tށ˙ ^T'NQKt+[)+GDJilpRSsz,c+L' ,!PIH+a];DϑՎCL<\E},-$E2ּV1x䗦Sj8SIsFiY/FZ<@d/h3s.~Lg$-ԩ5-(zJLwtmp̪&M#|G#sp/?\UV\k)A%E O÷ ) l,AǴcn7jٜ03/1bvj WbBgoZX紋[m+[-V΋dUxl8Qˬ]1%5΢#<=CB͎lpZkv\`-?U!d1PUĺRCR[x;x33IDIbf]<"MR$u49P(!X2)ՠrTm?/,ȭO" ww$^"n U1,,Z3zdJ/6D{|y侢Ku,7pѲ7q6qwPrUhn>|l=(ioCC,=|5 'y'Fbz:ᇏR6,Iɟ4Ǹ5G]w`Oi:NCO)(jհD2wKP8rnGk$Ix@Pɵio'ݴ BL}_Y1~tLW7CZ8"6bbY VOg BL-in|=H kRyy`݀!Վ2Bd@%,FU (.Im.}߆ondxWئվAG:OZg,3hG"SΌTl#Qb"GiV>9k#޻r53v#.!bpm,*"Aś[4АL8X%A "cB̹YórHSFzX9=F /7r㫃v7ږlj9}i3ֆGÒiH^$#89=8B&97Cò f"<K8 i cSuF}. |ูo:ό̟61mDFFT۩(c̭y=Vbٻ)bP2(Y=FBa;J&k! ,=4\rƧso"iъ)ww>z1*1GGSi~XS.siLi\O/&%U7{or}c <6H@d6' ]H3r03M$8Y}Rii {*?aSOhNzP^ːin!ʬ00V$g /e$zq6;%ԗ@.Gj*[tD^߹<)fh~\$?y"ut8zlKT;^k, @#ե%Kmotw 7-nń(\ $P{âp[ADeɹqO_v/RbI&-ds!\+>iTx|̈$THoE~gƠ1rDQIy)`'4{')D =SndLFSㄯnj"^1f! B * /[Kt0yK~&UX/HM)?ီ c*9!p$|y΢˵ӧirDQ@%8EdHU7}3} lXErNN,Klc(V%xwbߧi"mM!whPQmŕ`7 ng__+*M@O(HVaPl;Sf' "1yt+7bSaN!Vc Gp8 9vBՕ9ڈa֔tT$[Dţ$YvZi Ϟ/$kK$ΦΑpiUb&;r9Q50R[y[gBD"19Z IU/of2Y_~962xl5X\|psNjSbgm.}#3+w1F^MeĊdZ+F-QlUâYqtlvTc/(* ˏFQ *u o;0T 3b>Z]vC ۡ$Is{8՞4"^Р<:6ݐ.\5~]yAsڧl=LUOy>\BkD1.]9*1}v9O Hcc-.?5cÈ,z*)|#q@ڔv̾+v]bdAHx}[ߍħ H>]| @ޘ&Dz{}\oT?~MIQyAo{*#}U;SDW!R-xFUB68bGf|QuI:]O/s!;ˠBIc+~#'X;xNeҫ,!,*yѩ&DZ Td,- !V/KeFXNIZ _puhԎR+k\xUǔ&RnGcv)chܐ@S,W]ޝw}eaz#cRʓ>##JҀOY85u- iMjX55ץMiĀ b ۃ7wtCZ`ayƆ֦֤ܳje^CW_d K|?K5m^ncBg0;$6PE8|&z`St/8|F5Tb|A{ ϗ_ Jwf!++fRMx7vRz8GoqP9DOl> `F>P5Ҏt悏,mo9D?~L!~nQuA4K:Q?4hMΉ>gSmPb=xӜ6L̷FQd ObpS{jZoV10et_F>䜈5BJDWypIyF8gF j p#B}@ō*[D^,+@vjOoG"PuMg⼬r96WO3lm5{ .~w? ':DSEv\u̫5F[ [r Q*|m !qa9gc͝ Z,vY.#7ZRY`錽}oE*W~H0.qo 㲫.%~K0E}(oMqXPx}\B/F*&Po ۤ YzΦumH^9M5 +PߙPPi(bW5_._!":y}o8 9DWpF` "ϚPiݯo86G $Zԓ 5.B#GBB jꨧq.E#-F01UU <=-[قrE;}_|MLͪ\ǣQwS^]'1l_lU `(9rȲTnKLJr~ s9i!+#b; Vs9)Ϲ8kyTk2!uhWu"K+<͊W7_ˬU'|ep0r'~@d'?t&&h L+΄9zHg7$dRx` 6& E"Pœ+Bžh+oJ=~xqA6<58.RW9taCTl(0ݺKT7:Z0A_'0mR ,1h p82Π<f+#GIK1+[q^:h`?z@V*p* -й1k@f5!VDE|}%4S'د L9FEq ,&#*!-℃lj"M*,UvaC0T"|N$[mv7 @[~H[h]9ec-Mvqb޲m4 RI |8Iϖ8uZ| 'X_P"3lLacoo9:||IÑP)E'El|kHM~ 6}c缡Z9}@th$j[w7O5O/|K~Pj|dXY \9T$YV|0o9 ֶum=n }!a\Obsp }yB[IRT!r|0\73L[˰hϾįALU6'{n*^hhiZ$XH<~9] :x7ge5Y38ڳdRl,TT_FL|+S8g'ql.R{" bulȷTJI*ɒQl k~T0W'l:X'GGw2;n]IȺo98hu^{.P>ez|"hX29*:ZŊSҵ8"hAy+,SF0h9b @þӵtLIeKÀM;,|qgۏ'6#̭pmZJ4[u3K4~L<?©ˏ콾RsjI`0#Wv7 ;#J* ;NR,kUU K˪xN>KjPCG5"KXfѲ$po> . Ġ.̓:m!ڿq`7Ay| cnKjKY|b9ŜS{C$Iˊ$dHWx2TAqlwF槲`UMdE,J |tl<-I]֔,v2[|`d?%J+" }k>j^J'vE2(i MqJKH|sIGP8b]kpZ0Fq.4%3 G}݋>% ѰTUd$-+@y ;,i gEX.'%YGuuQGژvBze[?8}"U,bW' ӓoRFkDh#&vpBे8;~Wƞ{b(jDo/ _ʇqTbp1{Y!]@^~s,# R1v=NxQRx[ 0˴8Ď1U}] [ hiU,NkfU4\4:;yL&͢mqȌ;{%91@:_넅ɵ2ȯœ֬3;Y&-Цb4bZ9#j~`((eR}M lN+O:<$?HV؉]]s .ep }SƳ؟Ļ#-O3{AБQ cƙ8OBN3y n K=xF'A>:6/b@$U8B/LP;h ǥ}*;I<*d2Bn9kޔUˉR`t~Y@;ƟG2m뷅ʼn )ݮ_JNwҏ&\%,ȮWқ)L%/7zY]; TRW0wɵcj)v˝CINЈذ~lTfjsK7Atny]߫T;D݂KЄ_s4_봎,Uf{AU{K+BeArSK"l~)ÇQM(n 2>kbBo+;\i6GZ,AE`؎+jK9.kǻ'Yk!h?U߲HGl"#M)zLm:enhG/KԻsae@8JOIDL윣hwz#ܹ5Zʭe'ڵR_צ.!6?Q9@^-Iyv;c,)~2gsHdT\NΗhfL`F5 y[[!KTsV*dg/:'<]%< o,JMfߴ<tMIc>h>W֍g?]ڡpakm%2'֖=IR㤇 n(Wd1#F-( hR9b? 6{As-z dbg)*AV8FDSב6cpޡ &7Ｌ(Ԯ >I~ ) 4'KrSЩ#?cydBaC8H GLf>Q Ƣ7 6 ;]*y*K.xF%'oKr%)Y?lT[1UwcZڗh`"Q-Ⴃ9CgAues`&=*E9lɠu,#!hFazKҡ057LMZ#ҧG.C/CqCgあ)XF עȡԺ󔸕T+AY:>4jeeGZZNl{#2kC$YU)ǺGQ;E2U 㟛6Mâ2 w\l9D0zO zn\,ؘUZg;O%bkľ/FL+Jp@V"Pcg*VɸC_bJg5YwCC62Jy -LL6tK;^;NR}WL[QQC̫NYFU#V 3fWlVW~Tøm/5NOH!( 'B kj6B=ovB{XV[vRJOV5 Ita1g<=f[yhKϰ Ti#_OQRU;b$  ʭ[|C%Ɨy\ɦO~trkyeDAA b́8Fwր.@|!B\khNkt٨\7?ig5BV?xB%i>lqDuJ5 O\:eG>YRmѣMx٤[.˶Y/jTs6iF; LoFB<5V{T $ە+<JP|Nhe(P1 R9Ώ0:x|*MУhӖBP{ʩyJe! {致ﶚD{E~;?mhƛiB\:nB㔁,O#hIO+LcqnϿFg1~\ Q>@~Jpq@*bIYY*#躺Ix-aK$fhZПB"J,51quOB&KM5O#֩H)h[rsiI\i .fE N@Jg=x͖g_b,$ r}"*PESwodg/՞nĈ!qmxO7ۙ%&`.%}Q-|s"'mDwvsCn|k$Iݨ̇#*$|mB(t@m~]:g18k됖ؑە*<$_d ,#Q/$w!F O)Iۆ۲݋{Эk;pՊY87. o{;~pXTgK`B7 _iB~AVZn|}y2d$W=ipn/,#^kҐ* CPuʔVOx!be/ [WRϩv1 OFƲ$R-(NU+0{z؍ #|Rj4 W'toЪ!XTƫ^Kd_jCpx^1c+^@?V #ngqnkbzy ku},Q0D Mύ)Cs FninlEdI 039@BHn?M+ūn†w%q*>|`ckh%~e?x9vq |,]%2f9<5$&73 ˃-]dT,A!鈜!KQ(ɟdg/(^rv^ԡ|Z=MgeH]wPg aT1ofh8QLhK8Jm/'fhuSCYE8qx@H5C6:Sў!R=)E]lyQKVѭf6(> ?nJYHfNJSEioO mWXv=VN[ :Ud8 gAmy:Z; P eU!20asRAI(: c&P\ђ =X?OoJ\%G#)$h+{$3A_<;cs;d2&8?x-ʣeG^-vR8Ljb&Zkv^-sFr GqL9WRyR]5hg(3mܕR{SrOJWEiMŨ5 ;I2f/$dWJ$zdpw60?i!|NT){2/΃b8ߊkL4%9SV%:u HFLζy#AA&,K++;mpXaof11> stream xڍP-Aqwww 4!5{ !-풙9gf{UVWuk_MC,f1KC@6~Fj KJ vr@ >$Ag;%=@Ylj 52ʵ~=Xlnybc~{?y l?uHٛA;7@}3x, g xߢ?/o`5/rXϛ -dZrX}6Ϲ>'/d>#jspD>v|V;mh mA(\o#7sqrz4|PrתO|ڇ&-_Dtv1aiT 7nثC8=d]N_CqH%9*0ﳋ]^z0$]W+[mQ2:d5 *ĿOˍg89~8!b?@91y)^dUKe1GzaԚOq“çB{;N˦7lOu6tlz9OA/L}ً?] /Kt"a\幻t0VY-g XtVCFYUHsZ ¾Xj]qnw1>:'V'gx KrJy -ZYw(R&B܃FX;<\VbfɎ⑈s=Yo^qwo hiD;P=ڰ 'N%9U~HHw#$o5%p(N%nkQ]R_!ʗptK1TV,~LoRGs51ӊFVXD y1 89 UHUai=V)N.|3h@” 6q{^9rLjd0e;)xh$PFeV놬@q;IP0Ajh}EtT*zck\;He &^7P#7ٞNK06 G $'thoKuwT"oy$'af'$sO(&oҷ '3m^j, @q ?+ZsIfr679TS9//&Ьe)5K无 tt V{dmfż 1}"@Q"''_^݄&B?XKZ1F-R0jip ^obiTg"^][iCkH!KNr)2(|E>*KjR۲-V-9UWv.%S1K4P=fX_@8!;%`>nį=VCZ]$q9/g'en7Y]|M9L(K|,T;'E$9/c:P:#X#2sX2q@؞]' KJS5)-kmM 3Kѩ5]<#}JIS3*pѤz' !{)kϯ(5iޏ B?MeVZ"y*]aBk}Ege/˧ƹ؇W C)h27H /y/fZAA&^5[BcfԬ},u$@͡P ]f{I5=e8fn3|"L- X4e'٪t>>?൑Cȟ>%0w -)8Bv !k.S/L,.5ܪ4z7pj 霯\rKV6D%Y s`q!V<ȤNRQ-a8hm2MdE:>ϘNBחcm)xN7ZTZhzk՝3I~{#~]' &yG8' Z!CX#90M5)h^LTsݦm ν 3mQuwh0>"oft)OeG&k[*Fp@t`M*dH2ZHH nc#,Mg~tW(ب3⧎#לdD1FZλkOo |:YP}Gz CqI'OOPblADwN)ie̘E]FQ+G=|)y$$M|Aе꾖n-=\›2U^)| 71Y(I[B Z罝a/ i4J0/?TĘ4yFξ>iEҐd_M1&ud_OdJ>Î7Cu~/5é얫B=rBlre:'EQ,=j] M4z({ ;w˵0E$OAkW_)QTi#6U',.4IWVtv^^X_ˣڝv8qXpo"iMCdt7\$J. oncnzkiM8sӱB0򔗼~ֲ^G~wi"F`A [n|Qhd% %;N[שA4{ފd>Q調ȟe~@"g -w#ڽhJrY.C2pхAI?D2Y|(ϬI ],":.]>DX~{T[QN5 '&K=3v,[:ת9d]Bl.vj%?2{D+3&$u&LQW \"17]LĞcᑷJ]`ڛ)e=u1mxyB<gRIOX?WU>d]UQ20ɲ"h:9>ŸZ/RER#gU< w_?p1}v\o*c{}Xj-82Fd+OL= OEwl$sҶ5e;'bhC:ޱ[2Yz涺L=>&j+5۳H.@e-v i-0o 2?T"1]%|?w$[hێr+wR%!+n ǥvQ,qZڭ2)kn-DHogVӒC%ޟn8RiKy !#:cקM|ZAŽ_0eB~僶"@e7Mw::Dz\ Z>=0*F!GSv/,rĹQC~r;2$Qb-Ȓ4q-L;2{xEE19؛b0'g񵑖ɘ %m*g[K i!\C[H;ص} -%1yl<[1<Ý6Uzi%iӦχCb <.JPؼd4Sق!}~߅;K0%sQYE:ݬ\"w:BK}L&01FމUS^ y}ƒO%IMAj18Uj$1UMqkf(]JL Ak؍7KCȆEjj+ySz/"LU񯟔FFڽ4j$aVTL# };qZ^^T1a'ih7N+$8hL NX l-#ޣ3fd./^eEV,;4j'~?BܱG8i¡,-~@QE~|E:~rq׈ ;w4/mT`&"%d_web0N|dw<88U@fX߁c}.)Y˪Fp>]3~j2!VݜQ߇-N\!ibosݥU>xoY܁ls%VYXۯ4o1ou/?rmrK Փ50On!d(ɿ8 rc_wS]c71XbBLe#FGϱ](Z-k؍ܱ֋qlٙ?ˮ=@dL) ;5dj߃w+*zj2g.7oK-zLigV,8Ԕ]>'|ebMVD'0 үɢ"HJqA7j{?ίckIɕdT}p0`R1NMޢ/pa72úYİdMdU,(YGDQ2w48dQK"+:.eFTosgWאsR›GK 4l,@W |PQ}h4Y7<ϘX R|V:ea}DHubDO &_fgR']Vak (NV9\)0,|ՊPT]\rU5# ge)|{m$!g=0`+<6`5jHlfd mOz'; 0혡ȹ~A!%0ߖ\gwbv‘%c[恥ܼظB.P Ha0s7^ \29aa!6b^"tz+ U.eT)+:t{͑1BQ'ĕS&SB~/mȒېNJb Iӕ)*oq0Ȅenk-L(LIupE܃d}/6L 3Բq7Nʧ /Ϊ)LXحAz@Q?迅U}ƼpBժZL3N^X#LJ~a&Rl E~N . ٭^w :rXGN ZOn7^ڊk/ 8Aڢy1e]8pR?(7]>2Qn'UzLh{Vi@-ʠ?X3f\hR1KI'/׉?j%t(cyɋY~*%7$p,wX @ЍK"s銱o㍥|XwUe"~1] F#uBo&އr YbX ՗!bE#Xc^ao&|_X$2,ADfUE#Rew3K,?zO\ܴw1pW)-><ϏA-пBptkJBrF0!t32e\k[^(tlbN6(%O[%j E*5<*hp̌49 9#`ҏ?f?D%i_6H3pJlHa QQLF>r,tf=_Ex[BCipB:vBa.M50z[UThJlXA?ACbXã/]V |S&rK.x7pkEReEݺkw]- v]͖ M$r~J>g&uۮ1mߝjxN2GcomZ맠 ]7xe~?>/\ V>M4 ]>V Q+._.R|Z;ծT谣˘׷zo- |-'%!E'";VBzW^d\ۏ\9.Cv^~eH][>Lvb ;cNAtzBiz.9M Bл:/9Mhrl:sKfFM9ZîaC~]B /~}ZRo N#l'0$} EZ+td21ISf:̐7-ڔ*1( MOA`˳z6d3{?ξ91aYC3.vX|_7ǹ[7 ;=NSn6 &' ZAA\1%9@RjxE1.4w{YUt\^HjzX*|  ܂sóC2KI=G@ WtiMgqYx ^k(eҤ2D w|trC1<4AۋB[ oz%"!|KҐ/6l dYNC]%ʁЇ.TBPg-: +t/ϋYܢ_;lY}Z'3p|øYtb *g8A~RK6ZAo-NGK,GyB1<48@{L&FTF{B~RfJkx'RWWpNNۆ{:~ EPto"3Jqs!ѪHyGEwrQѡw'u_d88Yҵa0ɶSqB/%眜QOo,=s{Fڅ`vQֺjv{"I&>Yl,5 d馶 ,5Fؖ0]Cj:wwh|&tK #u_v=Ul2{ )ө798a8׆WGwUFLN٪x3$ȇo}H! 6N )q^ն\ۛJ؃rR.MYL/RPˌw>}xÂp-M7.q /k؊3gv.wB[UCDEf :e{-L444鼟Zx]PSA>iA'4[ ݩ=Qx"m0;u r6wj[W S`)osmR!0bf՟mTͺS2,4x>O0C ]It=ϯ{w nV ?o_&}Km=ss)0jkswּbE7ʋPh]X_sJ:nCrg""݊ g!^jZuH%X鶏 } \f/x.m9X—@:z;PuC^m"drm0_f)*IJ922T@i^1FyP-n%KB dž_7`ܤ=T$Fo%$b:茶0Pl72SmAجAA{Tw)o`X."O䏩KՐ[4f?-Π|Y%|9HVYҵ1gTJ_%5E=`1RTzln4VJUn'4^,Ώݮ2W~l;U()dw^K!b`.l(˵`vm+򊗎@MyƐ|.Y/Y>;/"*Q:){bJ_}}E}a(Udq'PZWG`3MuVcmx Ov.{2nkߣàb+0QX4+Ucm?Y|WT{1 8Ŏ+d13D jSC <ܙ61l 9 )KlvK̯IТȆɈl8BMaʃ<8-,~Iت-@`z*DXyR: 5 𪑎rػqsgݶb`Dn>sT(ZEfv4"q9JlUa9^9c's?šWfؘk**i(EADTj[l~.e`cVX*?GWBW  K1zǣ)t?=H pb2vN=&e.|4a&0Hsp=yѻvFKF)"L]Bm騮7cykBmvz)ݼQb*W2ҤAj:ղܼKo0lmW]]<;;/x N t>Nw\xb{Za4bovlhn Gnb| e,(,/w[ +lr8,|~o U%7s *Ε:mޗ s<0 endstream endobj 174 0 obj << /Type /ObjStm /N 100 /First 902 /Length 4372 /Filter /FlateDecode >> stream x\Y9r~篨U8Dܗcb#tfd[ّ֖.nƿ%PE( H$B"qUЍlTPMr Vx(*&[5N[77{vM޶I)MTRܐiIjDhs$(oezDͣw )c1a\7Z[Sc #e2юHՊB6:ZQitYb1 amF+bXMq4J\c|p1PؘCM͓3ԳjlHVPscK-&DIiZXg h=j4XjIRDNfj4hv3IDHIvį'*x yx\j_$GIؚt xx/QB^#cYOXM$&؆ %k N&5bB .5YM0 I$6QBIS:d?Qu&B:&j Ml8"CBR#DaMI،H edfo$,881FJvypX1L?XaeK`TA"htA}Y3xMۈfD<[]o ϟ'v] U.z^,fOW_a XS[p=A(k 4dI]̮dXg%KJPd#6s\^ߴ=QE#޶_͇l![!l=[bu|m=Gr^II^Li="tuo%|^73uq;oר5S3UJ_+=7B5]NO٦e/v1Mjx/5kſ-\oOZoxS!DGd/5Cg>a_9":<7Fqg~v̑~ +OZ*wȥ<9Q;vvx`KRZgBE v`<wAcT1"r1cuDWi}'փdv]8&%|RSwlRz(c~hH;N]7udJ%L#=@T{ >UĿa7F;ndã4}Qڑ뾐/ Wl~pi}(yqDEb"Iݛl-c+]ܧRx"$o<&' cAƅ'[򉌋J9bt0(G>>O0 '%#61(}Z[yLLx7Hcy<ꀀӎIgJ1wc e0Lw?DS6%DXLY 1DD- mr'iIOhCxs i@T29nvN3L}ZzPj锴+̅a|ǫG uyޯk_$NȰ-tmW<ϵlX"}*59@'I<Dz$,G(3'bր,^ċ.YZx%v19<%q^ F >ϰz0':0[LIQ/!29۳aDWXx"ex2ylJL<`AY@N%g32V B,w eǺĖ4&Qɳ^`gy%l&Xd;V5yvDI2]8PANeqml$ɻ\ UGָwx}􀊌K Q˙-VY:^Gpe/b0aԗ2n[}^wU"`dEUа(̥z#֋:Cv&163׳pɟ.ly&kOl a/yN@ X!6,l)QQ촺4?TꅘM*v3]6\9ԫ͌ i5վ.Ϻ,ﺼoSi`uzXÕx߷k76.yqmձ=zXay)ЙL<,,% Ů=3÷G%їQY{]{ޞ#|w423*q?N޾*HӞ{* e"ߌ]ճWOl" Cf媰_rJwy1wfCY0IvaW:5uo?ܹ׋jzW٫r 񔯺<&C a"lp lvcD=V|-'ח˶!oտz"ޕF-<["}{6F񟜎s?wr-q.}lor~`qm/׳bso/[qH]WGUu}z|PX.6WW|߷/jߢ?>? 5zyHF6ckFUAU?sx)Yx% ^x+$މL|l31 1_,ąhT֊OR\PY,ğ_R\[q-VTCk%mgz+~)_K6~dٛYnT&$$ʕ$Fjo6ZvYή>^H:7|ٓ~ endstream endobj 322 0 obj << /Length1 1962 /Length2 12931 /Length3 0 /Length 14155 /Filter /FlateDecode >> stream xڍP[- Cp]www .Cp- sW[S5ս{~XQ^XDd`IqXUAVՍmmEq0DAo<9[s9LL\Cu;Ҷ6Ǝp"vnfc@eH rqq6v07Է̌N4Է+d o``OMp1VGP53wۮbkrw0 m"loTd v6e& O'2+XN`bne Pe6FVoVo* )#hn["4o]169On߬?#';F5s{'c)(o&?6Sc`l0v54c^/'MM1do#8 `dnf66]+@mߟ<}~/#[+?QKQL\Co ۺ<zf6&p=xwE}`*ecb 2][bw2y۷5POLlLo_Q+og .H/7_[:@m l7U凌362w^)"٘ 3=o9ۮ{լmm[ޢm -osKm@]olN]cfc;8]bx02؂Bo&p(70q7`T|cAF ,[ mw|Kldl7`4ސ/[u42߯Cyl/_h/_M [AVF.M[No[h/_mEogٽퟦۙڷ)F7iREjyhnhnbU>LC'}6w06v56[5 hs:MdӁMn~UH_)_Xt e_zlչ2%2{'CnH&.tS$ +`dڧBIYӳB^$!&(]KhKl0vMe3Sh|* {.6WPz }vȂ@(b<Е+9HOY·h’qE1;i}ֻN<>%OBuvzJ;'՗+WD|߷EW f]H1WZ"ԶTlWDjQeÕp;G(+ǚF%_{LVÒL?a y` ?Y L҇-q׍DofRPn$:7ɭ2[^.ևܫ;d(>[*XG_T01Z C{w:.eqծN$)QƓwDOׇRTŀ%1?װ8mϓU`!Vg2q{ RT㦜E;]ʗ؁$npYƚ&?!fP>QQ!N[ +)Sؖ5x|J_mrt "\˛\Qp{6p'q|xU9Cq݀K;Ĩ ϲS|<@٣Ֆ3x 5&jg ˅($7cU ٲ}bac~FpaXQ);*pi4_WPLub`\ػ̩KB3K7uR`j.lf#jz븏1 >Qnj!1 2χn $Kj/i K9`O(C ¤O2j(FnZҵ޽$@e$i#9`x)EDfgDԶLԃ||5WNCQss\EvZ]ה; [MryNwLtށ 4 3* e' RI6?Cze\;~ed kg_i|xlk1;ډtV"@R!V0xcawЙ^Kdo)52!p̄}e$Xu!Da p&@E(@rwg.Qm VzxOni$v@IsȒl~+EӐY 6 <꜈$|߇yg+Vf~$K2/?y]Xl{Ƴ*;g`|"/ JjQϘv@ /֠1)(nKk?tx^.A.Od@)kiI$VI)7|D7ZHH e$C&":nGg%[ (lژmC, FF~DÊJ5sYH3ͦ6v1@R]?ΕirB&o:BmDqx)j ˏךH~QIg; +=g؜\GsJkvvPkvF%_W̜_(x/tԜ9D3{u."P8ӻZ_Bɍ`77vр짗w\U3G?=[wE0tЋoƤ $-am%V'O`gq\/ cߍ(+l佄D̚WF<>n/m8 b=g6*3`m_~܏܌(myWz,Ƒx\MCCG )v8,I<K[qxSg9q`Kp#9D^DG\⻄LWn]4;bk'iM!GGiB7!ż>3=Gۙ/M(n=A6`to𗩘\6XӫW;u_L; m.e%[zDh9.*0MgjE-h{xdeuXKȳ XQbxWwȑ{ V5EqwgtvkI RDS3u# ZbNL?/K| \ݲC 3jM$Bq'bOEh*wK_5d&,ɱj`{W0Ho(k9%׿ -p~2Aa1ւYr at1|wn e em;KȮYm`2ї}Ye !; }NRp})R_XIVm7x_(tb?u4ݤ 0;{OQ2K:_z)9NRJ| ;U%zn_(C*3?5*j|laC?Xrψ6=j^we{]Ep 0%V_\gkM4?I9,a|ᰗ7Zb쾌7PڲlZ tՔbkֹnV ~iyѶK<$R_m7dj?MO:B>r ^`E`c^tx̾ÂH|i<`^Qg]>pv-S)&՜Ms&+T`)$JS}_uم&Jz6 % ,$iIfuAHC}-`W0rD45tw/(sks޺9}J;gA:{5d"!@sJP]E-@JBU(g!0%bś;PQҘQԈ(mFg y8";wl2bkM{u< _ avA1O qI_OLvT4yM~+kDɞ2sUfp~ЋcCJC-q.wsDIڢp:y/T{ܰٻewdChj-_Rw~07PZN.AELud`lY >no֜7yh [93y\Mz%wPB^I d {E**(Ӑ=u--"tK/ _*N@Hxt+fh jq[M,@GLy烴Q1)EkV.YA<NtcYPVx$JԾtu7ee'`˰(ϒQ#͗JܹCNE׀[[2}д|OTW !KY~.2g#*՟Ϗ0tN8(I`82+& pWFXQ [(QxP+lo+c*@G¾F \gv9isJxP 170+qCv]I'^!We"ᬩYY?: 0)2. ,856F*,f%SGzSmӐ1y5 4d(~N"*Z[W 4%yRq8o&϶Mnt+Vŗ#qpxߛ:/x:zu&ɠq[p9Q9oF}Y@Qb@Do"g\_ÁZNR;3:q a6 ںNl.:U`yEf~5pGq T !+]U_oN퉒tt "T;!}cLv6վ.=:ȥ_60VFUxQ.wps]wO*} %Z0?Lp$dKBt;&[qA^y$3sg~- ",4!}NO4&)ǫ==%~ !,T)aEd+d9T(_͆aƥoP Fib8y3Z|5G7pZW ꭛F0^nOh5EP =[[n(&ͷQMERYq,ͽ"SBc-8eJNpL HFBUք!$ӱy#M.5imxˎMJJ-w}#%6Vs2g ;9 _+3ci- ~=q Q 3 wSH^a=!.R\@ حNkK$[iE:wUG3d7U>\_oA=Mgf Vu{JFi_&+rr1PgȮ6 Ƚ>Ty/WbڧcN =E##Ym͢A+=YhD?|9&Bboȁ6y(A\>] >\~P;gn\ 6=M4L†QG)j=c8AĴӥQr"N&ǩw ;HUq}3(ϕQ;fܲvTO}>atA᤻rT-Wo۲ @np:J.vT8[ZnĪkSj(dNc RS@iimg(@ މMOjc?w% B&G*C"`,"^AU|1*[?R4rOro,ؙ B4 ye_]WP lyδ! l-bP.RW3f?,kݳg&HLE6Qp\ڙ3gbuRiϥƂf6p'둋ϑ.q*oTz@9(3Q4De}5xEAԇO=@-)n1t)g%9']4XrG;EH#e|MI8zIy}5 4>"x0%A41ahokֺ\^-vސǷ*Eo| o\R_B;5PK{'/npxI2xXX`w3!EPKn룾R1$;QhUl^L`C8,2z]$psĕ7LdAr02s@t<\ P\-Ę"NЀfx>8.h(6/5WDhU8-/q9Kٓv,%;|ؕxDgPp^m#z|٨;;E;SD̼$4q t_ԝ>^ٚ|" lZR鸜qqBK@ /c'kd]Õ pT7眹MuzadsEɠ\> 43g)R_'iL8xmyɡr46w;嚵aQu1.e_fjjCOėRTPx뺍r1 OZvT_hecǝ[3Ѐ.hQ'?nyB(/ <(r&΢4Zkfʼn+Sx5Z_w.J;ӧp_J8HE$oSU={6Dd,D\ QMHBZC؇- +.1K`6kE_sH~XY% ?tZҗE EpL-G&b@|M_w*ZWK>]k(z㹄N VY=/xlFzKg  h*akcHUnvjG  P& }oJ*sL_PEPhs\cgWmU53x.d:㏤&l:HccYYbH^ӧt}y UthM ]T!t$hYA8U!Vuq(U_o"Lςaf7}>3!hp vnuM(*?G7z?Tw܉kt[P9)5d6cՄ>s%vmQzNr.; 6 x4s'EABYj4]yIׯLTR7GҭM/#Cb>c.|mlahvFm.YS }b=-]GWRx=sp +`'RPH2bڢ'ܙWޗ(N˟#u{?Zoxש2w7N/5V!9r`[0TGH f`⅍X$z VJSvjW'si$73Sn |]d~dB \5jٻ{-o\6fdr>;\ԪfWSx8HwM)Énc ^D g+>n*=p?)Wg},'S`xΘr,& 9 bdFi8eg fxLeE$Ocw:9:k1s`ɋ] "}^`]jRN60O8hU E<4W r4S-6ٳ.ZSA<$` 7Ĝ/zgrM5FuŔȝw:krP95f֓)Az^4ybH)0$ f?WFUIrI4|焲ìN ~vSJyL_Lf;-Fc39ˋɭնJ:וVJ:f2lKxrs,pd1uӵ`puP9DZXއ-KjRTzSHN\PH\ȶko&}d'jZ}B2Un'mi16@^޽{ތI1+VM&i2^T >֭ƞ?vϭ֯:x#1#; >Ç@q1 ^FʟO}l4رڠO7vhBU_Hl? lڸc OQbj(MxseƒTX+\gFzaW$"1oAM0{$*f'pc+p~ŰCO[#2x4?Y f@r'MT9ya^io+zt/v2U] 1M:Z*kߛI> Ѭ)vKLW<tv=݉У27A!=YNH>o m3Deu_mb+3; dXJAfXY?Y4 zl>B)rgEbTof0  C%uJ犴TӚ:%RZ y/as)ҟ| K?v%q6ܶ)^Ux O\ɍe46lL"NyQ}3wԟ`(q Ah^S.20ZzH23}x@UV)2. NP]OJ?٢LO$tZ/fl)\f[dWO<rXb 4DX MD\9ɊQ| 4ZZRѾϜ-*ܱf^^q3Y)Zc`Pe{'3#QSƒz8H as}.Y} EQ0yrD|!lS!fϭKVb/w:8cUa0:j"Q RmKBBlaq\nM̥@/ų:D!9~xUHXo\ڵ9N4U2C*?)4!X+Ö )mQ]*3BUSSl=s|cأG~EӢ}󐼃 1o{hU0¸0`MOp hjrm}{H C$ tPx|Ƿqp. Ad7|DP( )ݯl珼F q8aO'v|^&c9-{k&xw=L/0Ges #ђLE4GU^FxdaXmEmW"(A>3^FՈ41Y \F MG_[uϢ]?"m ΣMz"Hllj8ghlo)#}a7F.[vT㓲qr^nrxeh߱ҁ~y,5*@'idfzU=dz (3M4OVnP5j+_T׈2f+ { 4Nڍg,IKZ6szS!^w)PsA;!RM)fjz1=v!:(yXγwfkyx4r(YKT&\X1j2ܦSu5s°X„Cz+'?d&` m7GRy\׋)ԿY(X,K|Pٔ'=0%ec=ˉݍ0I{\NQ%ھX8Z_6knB*IBHĵ]_6+΢[PӘf#𳊤U=-d3S/n!c\ԫ±c9%yx ΛɌ3&e ?[k)=T?M. .K1T e8y:ڷ>\&SBLv0s3G2]iiJSa[NY~@"*gZ2X`𵹳=J$ ϵ4'/ yV3&z-nF4%}S iqgcSHbie.4#z5-P qk[8C,݄ad}@Y#IK;C|5%5ۚ)E,KԾ>^2xU%CY10'_=8[ȧ o|n<<%EUAtR y'[jWi[/P^T_&m35??J/+ /-\DAET~CZy>tؤ$}z"B;QؤWhe^Cwt>fw]U endstream endobj 325 0 obj << /Length1 1791 /Length2 12400 /Length3 0 /Length 13562 /Filter /FlateDecode >> stream xڍPm-kp'.ݝ:lp;w vdj[54j,@0] `gbegDA(4:@gX?$fWL (8|Nvv:8 @eVB# GC@t=da(Al'Z4,@@Q @ llf." wt:-4 P1+ @`q7s^; :^h+T࿂ `=+ǿ3 [@v@+ 0[hfof33 r3:sp9B\X]@v딥@0@@ױ{u` +&,]ٴ 'W!?5agg@ ?<:9_;vtpX6Y_P]܀+?mpp,A9FZe^3`=?lO˦WIH8xY,<?D4jf\y@j_o.WܐY) W;??n3{u.7T*-A땇.8cȀRl`NJq̜b}+Uܱ_yU^̿~9?/ 6M݈S6oUJz+}Y5D]-/۷X5ii{'zSϓN{2q8,/pmy}]^.aA=\b$_HnDF@vjxL|9Չ}sֻGw2y)e} j#8:Uod`dRt4z&xuGշ83C16CmWiXNKX H|Glٲ.ްBR>7<Bb<el(2,$fn{eݓǵr1-gحM)%yj7){C6Wo>xZ@Ql22<iST: OL~AE6k$`/AJ}na|1bsY#&]tT/d< CMcۭ ojk+4mI(xP~nzړlςp,m[ۍ F-款op"}BYN9[b<͛wm9i$ L=E5EŸ# =fY(d葊ta}:_xը~W$lt'Fni9i?W{}Q'JevuS'pq1m|Edɦhg| ±o7 ϭ!;?;;s,U %[ &WTrz;Q(YTu8ax'VS^PM<96U&O6c2HKɖHÞ7A+RB%0;m)lMumOwtvǟ:mTwU)JnxƢnaJbͺak4)iGlVW}v4jҜd: Jle<8eY7vBUcݨTmK2(RB5>akØ?+8(,~|&IDU>| (ϩ51d#reB"IFc8%;nk_-Zۮ쮜WA #+A{9 "b= (>o/l-Td=T+"41|E0t[=MK-88y8&%W|H)71 Pf!D̊XnSmڋH{Ϥ&{wPlw(:Ni1 L{l9R PGGh)c"| JU5k _@|jݖֽ̭VCJBN`uUOLe:Ea|;3nuq?@NaKx!<t0WBbeARQ,y3jda^YTW,6Q|w'G8 aE#XqqQD<ڃ[I(ݕ`<@E3^W>@|d,M )u.nC6 g9O8)Sٿ=O]I9q&(p"t yENPsfr17Ƥ롴إv^sg8u롃Ǫ/{E8}2FlEe# Փz0-MM 4iU⪑4R pNK$o n>F֖;|>U ǐkWĐ_ނ$gt0v=L3У[5mEn3 lNUPGEOC;JClT!Vi\=7n bTojV :}ֶǝ#^% w ˘f!\;sBR<ʛU_lejbI2mx]=9N$O_z=Hr䐗g[0w: яa9E:`~^v\-~{mOO4_`}oOYOSWh6Lj坝DdL7 HAo7OK7 ƒn<Bs|~">6ʒ-bPrIY|ܿ.gH9[npˑkBuu_VhVj. Vӻ2^C͢y;Pbr/Nn`(~L 2KJq Oώ_LYAߔ"Yrm& Pʖ&cUY)L#Α~}nlno1F [:R{A%7k:X7y៰▋^hFBXJ'i#ȓ*ID~2VK,09ͬ!7U"2쇝.t2E3Ts1ժXvՔƍʴN.b1jVwstuٻIGCc%#ͧ;o*]=ר//\Q|-xz<(֍3vk3WBwArAr9]U&@2:]NS"[,{gi-uCMynIxhm4q#z%ae+('h-CQՓ]=+6݄NT#9!_"~Mղ<&鈷E9筘s-ZJpɃ#ӾU 5}ؙLO9BQ;ܮәx xЦȵ"w}sx[յ`\̊%F!: Q戥,aͬ`f\ '~-RԻ#M0Qo=_:l1y-}}lȺqƻ0u>U N+zh ~;mz+CWqL~ؐ6h-s<h-Ҡz2tk\:+ם،\}ЅYhC~n_cNK:G j Z>+I9ۡx=K5ӌ.ssox@tc<KJ *S e&:>4B5l.AKuI9.XfkuJQH@dU}9 u%0iEa>i4 ˼q48ȝdV-F֪_M"<[9#8PyAE|߳^+\nm*#lʺT` ?B v}bF Wiƛ]}lꝻ>1DiZSa^.>AJ 8VeŽ\gq 皨 -2 *I.-W0| ]ӃϑxUUD n̊> ߒt63PRC 6{ Z0]l"IhCǔeQ-g[jX56/@BXcD#T2EF'P8Wy 8|kb 2P&fTd!Z\-S/ _'>\S!&;aVNX4JΦƆ2I#޺kclqʐet)I9qB5˫itNd?0Q С^aPyP[j9X`ˡ1q"j՚d dm|! ~_Ew܀^Cx*Z.P:M?A AJF (ᯐК f3>]Vәo向Q`-ru eEqXFad@ѓcф\yD5Kl5f,bt%g;D} gOäKn|b=j XL_*B}==} t ڥCI莒֟V)_-7F^G?!sJ0)6a` vzDT`{+P.?r9/_y9/Y(^~wЍA ?Bi,c$5u-ygTyb#mMd:v@1w:ewPVMCHD*0K RGTǚ(j 8`7OX&y Aȗcf;,9a;u^셸*7aaNWY}' ^)}Ѳ`7-Nl낥e'*̦ef7~*tFZz'>iw! ٵUǫ`/j.^,u8Gʯbi'2` 3 kg]_mD4M"5Spz5aAb&63|?=dq_r'ƊYkf,#EJZIϕY>%^ŝɖ7՛6{ u4{?Lշ =1!Rw,÷3V?YT̓XB٠ 'Yy?tvg}9:NRl>s&h`a$~G-Gk1"7kզ@.:Q2yWt:>_|ii хǹWry=ୀY#wLMS\iS_ß:`iMSjQD !lpo7p:'|4icugg'3KkZh / Pf[ew(8_Td)ִ0Vl媄}W~ɀ݅Qp#ˆEh~Q5yj&nuOt߈/bf  \\h;ZSبX/^Uxj LkCYb#Dðvʑ$t_=Tz7c˜m>0J ?S!:B t3(y\3  0fV`FaM r3l^VP:yMen_})޾OOW:L6mFz"4]N1:/*m-;gm9yrHvQ CG{RD wz))IlLS}f&rdġfDx/T 9TN4$x@6)b1)3rwe޽{īstC&Gw\]/Um$EUE4;!A'RQuͩ_TCK(bҁF*Rߓ[};[L *"ȽځиY0ݪ:@P)k$G-s mSN%G `mK'~դ엒'Q+twCeۭ \v@Nktoq:}x ,0C22R4 ,Oo'KWRz,b`=} ,͛hk nKߜ~G+m1< ǓzƏLeh I!:;/|rTʙ^r,l=Jaq<4^%T# P#/trEyRBVc}!n!s6©ۗ|,amt'!g|\H|s[ KTq^ mo!6 @=GOF@ŸO8{L4@Q9ib/ySȄx+2z\4퀶P6Ul\>y4yBo`yv8Rŋ#> chvIKR P YgEdyå0ZjqKLm!E%$$;fz2ͺDEfv|/JaQK;&니?آ3y#.p, ``? ޒ|Hn2"uJ~^^ʥB(3ݾPqZ;u[7qqjp囤 0Tj({RӰNӶVPFo_ح<|yAR9 -Qg%={j䅌d;PfdI mdEfyR4\wRR~eŒN߻KP+:f=`Si~!f&?!K?N0cʢ,M@(y,:ID9x1>r9y4{ڌ. (b=8Wi=oDZ#/YI\OvbnFM6 %ʖq3|1>Gn\Y|kސn0f`cBs; zAʰNg(t-[dMܠ A*"ϧ;۸ND}\kSaH-5߶'jc~ ;KjJ"`OIbFk`~;I o*~cKEOIJ0`7ދ]hvhfH=N(SAsH;ȚԚZ|ϋ+ 믷`?z*ѽO?ͳU2g.,wk 6>N~t gZv_\-Ir,re?^xOזד=Yy[gCGgW+Ky+}Ҍ+4G҆Z۶9drJDҚ*(7$g/Xdޏ/EFn,G7*DFSr8JܛjrQI6>}dŝVk 3T7Zpsa]aVK.*(m֭?}|=qV4F:oK'}$\˼FKkU|78ck#3mH\qKCkޙ:C{,XBnG\`ipaf =e 3vL7L"W| -P~7#UnjuI^{|YC,PѶΈ10l#LT[dOM4>o[޿j.䱏E_7^ńH81 X0~7(l#$E\<STUW!!"+͇`:2(/y ^{ 8j)!AcCb@A kcJ ?>O'0F.PBrjUfg;U0i6[nf)ہ= R%f[qp>dR2[U^|mU dWBJgKX{v\Fa輚ɍ`UL.{&Oi2I@?) Q[vɩٯK'Kkw+n/wu|9s< .q؅'Fߵ”’풑R$3R$8\| R>Ӡ3m!!Flpp&AjVD|=oj3X;& Fʤ8 |VztVuؕ/rYn #hb_v\}>RUaз0Ý,Q.?^&vWh:5GFc_"a# ǫĊ*o l]*.jj6DZ/Gd^BoϘKT @Q[f <() E^) fejH+Hu.R+v,F?`,mvq8 ?F[pЄmW{"e@Mg Br%Mֻ)fcŢ$2?Di3'+Ɵ>Xe|Z?.ٔ?RhbhŻz6$HZS ÒQs$Aؼ"Q|`S,Rwl5,8^"`>DQhQJj~WBӢ1R sV+d-5]ē >YshJj)[yW63tfƟ!,͒˒_ӽLb,vg~3Q<4]DBRUd rff}cmB?o)-zBסtL8?Ņͮiw=M0Iֵ2j"F7e"e~dv(>4XuJa{ oTER20>M 2Z^S<x9rM6:+ Xȗ/ڸFꓲaŪvf:Q#P?T9jbΔrɸ|h,Pw[;&m3hNz7棝ɗ3+,Eme79+- }NF~{R8c\2m`lmE;/g-O(1 S(W{Xz&H"]sԜ[9yt9Xf8s{G"dC k~ZluΉ:akM5M(v^f̈́]Cl\Pu-*Z͜qZi'k%AWo'BQ(#UlE@?6tw GcuXK endstream endobj 327 0 obj << /Length1 1505 /Length2 7001 /Length3 0 /Length 8021 /Filter /FlateDecode >> stream xڍvTj. 1H4HHtH03 t R ! !*!J zsݻֽk֚ygǻ{ ]]~{-HE IiDpp?(1A@aJ@JMhxEbRRBBBBQyH^`{@ 8|=N+9x’| hN E;+f!|[ pB0LJ<|o0 <@_!߉ p ? P+ < m@ GWi#01qB}PGQ@ @/E+z@[=_%Uu_mu¼`ï=`wO_( KH@/熾nB_0*@7(BÁ^  v- %; 9: ' d= )No"/,/*8o/@_Qcu$ ߾P!KMoAG!`W߿(z"P׆&ߪ&? {B[f@wp^sC?ѯsCA08B$_2Tٹ"jh2fk@_TQ7Q0j A> (*@̃W?@ A6y Dm(7Ծ7,]=("<@C&c"yo2*favεm 9M^/x{"IpSyB<~*u-o)s/\5ÍhIk Nԟn%PPDŽo(9=8C#SD7ܻWէ|i*1M«)Xi׶38~&{?|HO~pˢK+Ro~?bo>Ό bt_k͜irOLK.1_2?/=5^ ?¹)?%ה5RY{ܩj~Aq1}}Hm?{W 4h{JL  Kr%݀HO_Q;D U =+-8] ^d)~Y!q/#0$uɰRzyBLuOgNt6*{abt:+sLbb"rqՖs_%HS:9>أIBY 4rbj+F2& NFb?a3v/)p|í́g"⩰wFkdR<`Y:/QzHPcY?_kl!?.&iz\QaGވ9y֤03\:x섧eEGDH2ٔ)$)U^KN>ݛ &Rw.ʾiVУy$aD4$v~2RSؐřh:I;[&#LeϽE~W<&_hYc; SY4KgiIV3K*'ֺY.'_~zV,? _g0˞??:l/- vPYE^h]g5F:41:axG3je#fC2LYƉsuIƦeoӎ夾U1[lօLFjra?(fy_|_-K]ٿNWPz{9P{nmbUa՚5Ӯly@FK/N] ^Qt쒶d!)lgH-}v-  EtwnS7J,xrX! hD[ڌ1Z,TB <vA-i<\M?]?lLw7'X}Ym0''r;$^5$纅a =Pn uP,& H0VE $B+AU=6B [}bq^|3Q3 .P~x?тK{Hv+HLO*Ԣ/JO QZ%xНn2Ƕ5i?SF,3\6,X<ɋ;&YS;gRft,{Ԗ U[*T+{FlH+R'މOa$o,5ƙ4Ɛ-e@@.4E,̊g.ˈE\'N J1t6R Zm􏎺mr h͇#N^J4T7cNϊEo9dysmi\|t'xza=zrOνZԫ} ;r=W0|DotqVW>mc̝$QV%C tÆd6%>uݍ4K:a5W|$҂VH?y/_PY ۝(Q SZ_kFی "3z׼J&t|t1qӞ;nIy'F91vSĆ~hĻ_O2TA^9/iʾt5f; a=&-|#>W$um Mr7it3t6cJ1éEA yΥ_Q}wbP- 8<^?|k'Vpaf9ؽ}=g{fJՐFVeY£v_|: G})G.U WCʒFk)Su[ x,Uo-|q5]eJmm=7dYwzА*6M钕>+Rf}˲ݏIBeVaDH"r9HմK%9Cq_M/b'yp1ٔ@fsY>dW k &{3YB^iLL|ߏ6 oP`AbCwOPbWxkZJ%19MDtRQ}g%.~=D`%lߚ.aXp"G#橛UMvqm8T nel.21R5[:'i"pwwk' |gGԺ$,tpf&iegZC^! *UmeTF)IeGΐfiCP!*#^r̍ws$ZgV-S vۆ4^y1.qo w4ClPcIlw*gnڽO Ű=7Y 鶯c݀-uQF3}\%r6Kw><{Lr'G"c0oq𸤅1)7k&K-sIXnbE}JAknL}:(ݨ—&!>TIerG0 g ÏgZ&)&L; Fq;0ȓXt:jE+}ةOCohKQM(ޅGvI=w`jZ׭,ZgS }bb.?쐩xk8?Oh9f'#v0T(YiӒأY,›Z* eM],2peq\75p!ji"/DEP-%j>ȘHw=Oɰ]N=` {%@')gCĢbmp|Ƣ3qNVH6-=HN;]3פeD}¦\oϿU9D4ϸBl;?[ר!:]=pzhZ@9TjwղvN4zg_+U{A_: L I#{o|cI%(<9Ovx$xp,V_FfMMm2F-)nzJs=S򵅩A݇|:tk \ny4%]Vi ϝ0"I;+Mz7>PeW6̧r "R3m.3ۤ~qE(j!Q3e38==xtueVCX[NW,*(Lj`nukM ?1E~$ZΡk~@ҺK>uOs|mㅸ X&uwlbSPz; eyѻ I͐v13&o#kRn~l\S쨗?&Z B No pz辅cύȼjTrԁ=#H 0ǂϘc KϰI.UwYjq {H)&1JDLӅ+/=-Dr}ܥ,T8W 5^T~*,9Dr*D=83A)h~zH]MIK;o;x=zPG0Z.IY X$ w\/V5>C3ܟG1J3>|^U^)^\EFo_\`eZ?;]+R[ߊ,t4h]~P~!$A啬TQ/}d\{)g7Fkk]l] :.}Y9m3=Ihc@GO)0#CCg5a?kk~45{b.YMBy K]B);%W.G|՜vT/eGo:? )S/=(JjZEWPdƭ6)D742* |Qֻ (:[)6=jxmd>, %M{4|=gT{AϽ^D8*Q̴w"}a$0ᵳL~6l ҫ-hq(nsureܠĥ]Kz"⸅p=euY)&eϺ-86y!TмE[6>+z f.?ܙvټ94thr@ɽR|,K_٩2YM(@MOy"/4u f}`B)hN:` s}FW\rSyMhm,lv׋f(Zz b} hϘ2<^gS"*ƟFx"r)soph;?Iq*3Ҵ)RDR..RVU{3Q}hY.= ӖeGw9-F(~X;e*c0a:9X'^qp!gآ#Q?:x=cp+~cSWM*G(w,:/dh"!NrWabL৐E{q4 @RS?cş ahƆ1hrf-FRbq-RT]\ b`Vd*#\ƞVZ`IHHg QW2Tцi"z >I`UdEl%q"W7iyQVT Nu2Pɹ\P6yfA?D+?M\DwJLhmE(6 p&9GTvY:W}CN y_)r{y*Oev843'K.)- b_|e.?1O{VU<2t.B͂ǥtIh?g'͋; O_ʹLMs;Xg'-yl*f=$c.QE YB4!rIr[`[?kOI~?s/oz_%(%'QIqט1J!z_R}0[1:jz<3 ggR>U|5b.qX,KgCi3vla y#pIx&_$ Lɳ^:`Na{nYRh.bS{DU@gG2*<ᮥVCuϒLeXjĉTDQ0?|jl8^mߨ0~B.t’5Gcko*r&úا1go_ W 9ȶzyG,o?;Uqs #E:Vtc]mݿ~,;Zn56skBMrfQbC' nCu]lCey<~<#+nU!h7~̣wяt/fM?g& \"ࡪ\U91=IKO]q=<m ;2܊jH|_/1ӱZp16-dpp]K[ݯlY8 IX]ФhKĠ*~cv1$>+-i4 4t8h}Ƨ;~~zmSZEad4IGxJm@͓ZÊǂ79y ^2*y'*{qɣJY:%R&+ד PRIc*{ 0 endstream endobj 329 0 obj << /Length1 1721 /Length2 9528 /Length3 0 /Length 10652 /Filter /FlateDecode >> stream xڍTk6L(1t74Рtw0 0*%)%!J#-(!))%7ssZ߷fg_{}g8ۣ`*(?X$T6@  p<<(0SxմQH+, Iť@ $EP j 5PH'CwtBG# KJaG;Kv4FݽaJi!?# ( %A@;u  tC%0 zyxÂpGa{@A??YgtG )Qߔ/$`!!8!^ ct@%L}JIsA'g-A ( <Mo/|T]]`~ţ =( Wjވeս G:}pO^usTč/+ Cy_(@~0?z.K=P0;2]Bb@n1ZkhcH./'( A ? 9%@A;I-c y2A~vF#~PW34/?Bh_q*%%GEIv. }!U/_㺹z{Ph;/'%O:`!4:ǟ@c} 'Ϊ|׆G9L_pNy4{_qˉX8O ]Q:f71E2&Z`rgͶ|m7>#zе{I GV 7|塕nXWW}{Le5WogR-ńiݣ>Le9x6"3͢zL^y/REHX}H '+@3LB} uyS;|V o< u.NXκͳ;X.Rmd2o̬)HӢqܔg,mCLE.io?v '|M ᮦv;Z?Wص%`g-U$'"*> OMJ'. mu(u :gM4}ذo%VN;P0t!-X,j\ZsUxrْK8ͨzGP$̚Q-wi:Эs=uZ~mM?!Oc39 bNao䧫qH[ْPv> X51I.fG~7( TB@`7}Y=8ǜjg`'{RGKRERrpҬv uII[ wC ߺ{Wvttw @1ǂ Z?3FhNj3!YV\MZo5L~nTX|wv>cb\oZu[ǩ|GR)' '}R񿎀u4OV fe'C6AޞA2??Oyw~2":GiE/(WG.[f8:S:/C%c'j0J Q'Vv9,xw({yLfs-}^2ǀwrgGZ!Tr&{.bS+Bb8M5]YLUaU. Q%=_^բL)m5 m%oU.;یSO9uZW 4g,>4bmFuW$ed^k9V)[7#|8GĪsV~D%knŐc˼ϭi n|2ܯ4!Fz"mf+1Cig2$,"Te= -IJK3aEɳ/x=3yO}WH̝#̸3¦ /縮)h 1 .D%Y os.k nDx2g)u7id֪N:},8rۋ\ID~w.ĨR]hGs.+[]]F} ɭdkGf+FL!tD]ֹ(1|)? I˰[_ͬ/Y*czn7/e]~ç_@Ȝ0o 6>)e y}U'{A<ڼ9@c}ar<|Ybo;:adݥY/fJm0f8W69OqmBD gp,ּ5ĚR}X<{gZXJz=bUU :Qe!҇nGY@e{BJWtQ, ]b!2AM-[ y5S1^<${Zqg,'OUCƤ]1VȌz{4VN m/0SVJ/Cy1Rf_αX lVXu9 %+MaY}&joEg*36*~8Խ8\Ybuݓ8wAUr%}%՛&d(nDԠFS dOlCФ /AW 0-\ S\cyUDC J]G%>wH0"-D)Od:3p3'r(^Q59u<u%au"C72[&e7V5SAdV1pYq[S,xi{/j,Vcw:I^%`\gܢ _aeo'By7jT;* ӂ%4Mŵn1꾵mJxt( Q=-rI$رϻ&(6őZv?Ihټo`7q7y"ppnc= xL\q|f%^|zJ,M*s af}{m۠\U1ڽo@L"%ËkˠhA,Փy[5]%NO.bfȖKKe*|?Nf>$ev/sSԙ.zohaeGC־I/ξ&P7@sb 7u=sL T&aEbqIb%yk)y<0q !F"7p![$kz|/M|S۶eʌoPO8cYr3{ChxPf710wk7}M+^xmt_`_>R<[e(%h2Y(?%mvQ:|W%Pκ(Jҧ ymq\/!sE$Um :Mp"F^#݂$[w Ӽ EIFouos2Owc0Nna.}mOCm5 Rtb䵟-/^nCc[ry-g,9M⻾]ԟ#:8%=ӊ1%qHqN(YJ ﳻt)=oD.qO2QCY8`~{*0ağnsx8-Sl_’4ڮ7shv (}YE:*|?3N0lPl0lTR_k#+DOV)*78jWr wE[Dѣ(b߭/<\M{H`+CQ8p 0L9`]P9?`*js0rlFPE$%is/RX8q%$vZ)H.-p$8WkQ'Hkk?h02$Q$N^u.Z&%voP s41U]+B*>߉{3TghdzLSTUdBc['% F{'7k%89lBɸW="o$Uꭀ!(_;` dodNc%@^R]MA2WZ>P앃[ B"_,x UMga,T"gFBJ\G'(lvSM˚u;[YV1b gRafdJ,ȡ.iZZ=IG1U{:=!Bf?}fZSW؇Sm)9 Zq<嶍`0jÌ}J#S/˸_{=#m\vZ3d Jb]ZyDy(^0k/2 qkSJAqw`Ue4ÞpVY|_kvHջȕBVD맯4( .b'5Dia91#*?,aD1,-oY6s`Fmvd:)N$ k,tz< j D[46#9q߳6:6IF_8o".; ŅT=K#T=xeKWe=,#2 #\a[#WSU1Ս5!Py:#9xJT灨DglbOpy[iD5tZ$V2)d'ȏo{Z'O1H[T\1XgaTI48O -bqLꆏ*4/1.򰌠5;CwGj o&|Šw}gsbj8\p^StEj}6p=>Fu{D@Ѕ`3^R-U F|V̕"Fe4#{g9l5% Xǝ;ˑJJ0'9fm;^8C;bOUnxvB4{8Oce6GK7WW-wqΤ5ݓ}K fQqnokCpO齒 RSADvkEU3 ͫB"Jd\)X*H71, l0q=X'O5t{U;T6:{}סJ Z1猡~9WjݙokϵBAv=b@2{ER i]yQ|ԹC\ļuQ&<~BD$\W,Vq| jT>TpYaՓ7z d7?"II6׼N`cYqI4&nms=|-Ѧ^si4BQFKd?- `D%ii-2K wcŽj 4u-׬zkQvkcKtK}&wtG6l)-XzN+2Մwno: I̶'X|ɕI-깬mTUCo>}&QG\EKYk?_?)P=>ډՏaY/e(꥓9~KRSU!,#YWlM>cݪul?7Үk3֙_-rH0F2o=B}mE_ E=^pXKF_.f8h)?adLuIdBĞn,jRk,֣J\& JBV?QMOG~N vy噿4C*!:4ǖ?Ya%Yrm6Tыo)/H_5/[7e3Ah$\**g[h\X pcK\ HR=Pu=NiHl26˵0(~޴hDUAo/bAP?E@wT$|^]L>n_&Ct-nz}ߔ$>d*NjYhҹ'R_. !>V@R=0+|NFSq:?U0ȡrMm{%gd)Sӯ5By7=` IYk S0}P7w댠 ⺒$iSN1;AA)ԏww*鹮A:2.$)P7\ Bł!O/־8Ŕ%d΋:բԬ$98 d}f]$4?݀-ab%.}f,%Ýݯ/|"a},('ךLn ]M%Zb!<p4߳Gήu~fJg|sгCGsHޖCokǀRS>YI? &ͺ+$|JNE*eάr8Aގ +لd@d%[2,nf5KljKchM\M\cKȥNziY([;<AҲ}eཛ֊d=x0|Hz8,,aFiT#$Unal=enbr^=CRfs)F@,OM OvZTUv WV- ׽&#K[x\%PU9M܇a؁qo S &$_*hxX?Zz9zM6\/F)etLӌڇ3{rWGl<U]HO#64`nImܭg%׼X{Ԡpdvug0Ml"KǔKW 7ղ~%nK$Q\rw[kj_'ȳn$'KI>ô?mytfԼH,/MEt9=cQxYhFɎ1mY``=G ' <9ܰ)g[VʔVt) RjOӟI<:*JF0zcCR~3t4٬mYEy3E):9 ̪>U U5Vb8 d 79,ϷD®ވ-?Y-c.}1{?ϥ"PAź6jA<یE.^͗Yf?TVNvu'. s®c(s*؞mHv  _L}vs7Q 0Hܕhӗyl7kjgt&UsVb̸"f/oʈp)ċsd²hoR8YI9G/ Hm}[i"<~a<Tx\jIkP/T[/v.1v? &]i]DTHƇE_&H0>g+~LRy>{P35[moyNFߢ\0אx8h9<7/?eR>oNZPvyo%&N\;=nNO j>TKt/J\EP5/?xƬ cjKT&׬^[qV @ֽKRM K'"IOfhp1Q}_yo*(J V>gY"qfUxwuvʸ94%TilQz_q td$V|cf.j}|?C5ah"(Q"_ǡ݈ؕ@|r[O}^m ~l,{Yⓒu} $'҉|.tQUyC¼Au8xĔ^,G}":[dD<Ct˱][i9mUjcN L'3Ҷ] 5|f5{Ee;y+{k.Mw_#zh|kp6Z[ endstream endobj 331 0 obj << /Length1 1523 /Length2 7046 /Length3 0 /Length 8075 /Filter /FlateDecode >> stream xڍx4־Do3D-zkDcä5-D]FQAAI޼k}ߚf~gﳟ}fps )9($F$ P5@0(Jm fPw4 w(T,Qhy 1H.H.&Tp0@ IUPn>pG' v|~HZZow+#`# p(!d0""^^^`W0Q6 qAPwOW=+Oi¤'8/1 CX@h0Au"9Hp#;!G:`p#`{=;u0@]V>4A _5 =f5 ĠI wB#.H t*M TB8PZBB>@!N"60q650l8 C=4? \@8:‘ýV@@׿ s@!>neTVFyDB@HJ j"a(_b=hπKU.o?!7Y]*g@E`W8\ v tQY@7BmĀӠt*ZtGx/V{C _ 75o8jB0X/ l!`o4VMP s_5$kD%`ww)ؕ8Jo1D( 1Cj$ %"`D;E@auo@ zz 0p7lcw"HkZplCdJ!ر-I1}@P "*ZK0r{teO8s?'{^2>5-g?~6;x1M#ֳ| #8*4zK!oEdFze;zPtBőƂyӾؒk3`**Dt1;OITqɩ|C,ѣP113' QT9TߧvAl*@Oycmo/z7ǛZ:#P\l m;ۉ5O$05Q9F9-d+JώqƛQP7I#4IEA_V9_!1\.Q.U*5Ux놝 lDDms;ja$v.6-'$gsLmiK=ȅ=mKRm}DtJD!qovxS75Oh +D7ċ7,GZuZ;` @V2wւl6({ [}#OeJMȩX]SZH09lز5oOdmU^ӏYFn<ŝ ЈdE8=orq:*(,' ̄IzR!XGX$ns mV `1, m#JNOpS#+8O2}A{tVux,:=pw.- U9Y\TK% %2_ӎ/wc\qTq{xƺ T$C:BƯF7񄅽IXY0&?]؟]fn3̓L1&U?̐PaJ2#f3|ZpX(0/j_1w2M1k&e)q I>n2̪WL{챻Fa YT8C ^5iO 6_76vkvЁsPS;Q׸ȹُ7\ë_0wPH9{<EVdhN5k<>jOF0GOjpKan5RZ[ݡK;!Z" % qhI)ƸAaƂ/24Eϼ͞r@mږK.%=QYn* kX N55nfay>h=o||PޝVz5ۻ^ f6B1gR婷yO"h|(7Ǻt#MlF5Zץ{%m9{܏{~ew#,tE|]5_|E>6NtoV{G2Pmϭ!yRrdqTeFmD{͈eI7zD7- Z9Z_+jrdd?K9u} ^וw);hh}6z{; ~:d> 7s[xQe)(kҾ-MTE1{#Ql{Oc{G5硜LOhIn ڃg^}%B|1'|` DʎY-BvA"gjⷞ:D~-@ťYs]ᩓ:rE @5L8L .~:2t\x-z6ҹSCcϋ3Wr:xܚnW.Զ55yIO: WG"4ub:kINщH;7ߥ|(y!< Qvm;Rs-n߰IFWMbM`w a[=Vɷ BUoM$U |YL?0D^/I TZ־!ךyW`xQ ;K:,#G$WJr`;whHm2zvڤ5+#Η-UxɥU]쳏_M#pn~7 ہl?48=)oEΔZ9YMM)vr*!YߦɒU?e Q/aaoacp9YdNLAϡk3nZ:ꚕJb+[fǏH[+7yTR;NvyTRN ͥ7wb# A0)3=ǫ z}"kqG=,aۣyM#ׇR^8ڮ>L c|qM2aB /h#f>ŹǙ6.=Mק9 /-8޹B( (rNhl=r1H sAN!.,i.ѫ+BjtQҴ信{F`2mY0#~D&/Cx_vii;8^52ˠټG>h ӭ`i7vbokEzY,S qAYk*̩靅_kG={xޒOsNJ`q{Kj% # (Zc<^k̺ %~ṟZ@ac9 ja.z 'fL *z1＊E.o{5Dԁܡ5"+#;ݑCzje~WE5!Fe:PXTԕ?gpvTsoʎ{ޯՐ=[ȃ^n:m( VL? 3>隷9+9:O! TbeiӬ8][92*/ ژAtΗTQp4&uʃf7~'Wٶ73kγ 6׆?i8UY,Ӡs]ebȀnm>3y,(ei5L 8[G""[',ۡ rb KN [>KMX]}iu1buϗ-5A+-}~^}F6LIsLi1+?m3XVk U$<;ɻ=kTHΪ_sv;*HwqFA";{|[Y 4ze`DBHB4$zEO>ByhI= ڮ;\8`;(>IL2tԞ7© ,Vd”o&D[ ,k(rDF3❘ZU&ɍ[\]L{X WkdCކaQrC6^]{p|:Ϫg#Pxv34]?VGԴN϶o*j:B[D9%Lǂ 'ÀLr;_[{(-eC^ s0;f+ԅ+^`5EdVΔl|N&2ɍUbJM%>4ǿ:#Q½YyUo`CW_G_G{ qg\)c_Ľ< 1j1ғuN| zI;KF&&AgUwص#K{6 :K7(icM*RӼN^m;COV=T#)x./g[6=!j dEQ<c&11]NLlYTժS|Ka~iEo}"lJNYW>H?SQEʓeba6HuT9[#$p>umz&t+UN8BfOǖi'W7Pn[j$P+/9:&+<3؏;Q1/M!|]6قzIbg>!nf:כ%!izCϺРٷ}ةvc:H.ZmEeφzv1eV5QLZyWܺ![䘢YOЈM"]f@#.EͥaiTcg bȆyeE]u 3}V:1Nq4(qI[܁DIpnWx{9ԫk{NכK1^w22OO7t@dg`Dh3}%0.۱h5` X 50^>7Np=޴Nj ;v4nI~K%7TҴ/UD04>sE򩽈-\q1gؚZp>eU&V{B/!P{OM,`GE/kXY`vࣝX-vJ%1 ,ω*kdMs tNYe&MsCA\ş:)+%wDɟ'Vm(l2]>'BL/@G^|@X9%X!CauS^zb?uOntLa{T?s.JeTYGnsfa񱗲XJeKN2DLSMoK\t^+*vBy<KMGt DcO׻ق7E܌ޔq2{Ayjڰ2|||Pmu9$01y2P-<}GqzʠMt{j&:A-{EO'3TpwtNtQ]2'eyPow}4 C!)<KggGiwv$iR,3NlVGh.Ǥd+\ d,[uzJfWnp^j:& .G}مJsjd50`H>p7R?}c\痽SRl2g2͙,u0Dܔ_Mɡ%J7P14^'%-!mGoj8#m`8wIjc:ː #Nst,uz@Ho7⻧9L>RUo2K' e%;UY-+d_ XuE w#Ԧ,Hۭke3ڭM7Ģm*S휧o*uxv]AiN d_Zg/xƴwBU: .~(1:gC7/R>~oo"i<*?9 wJɢy|"qн{~yf|O?E_΍wmcJEQd'288ҋc^ `9K.U~QȾcRd"|gsrc︜M &RYӃ5J@~4yA?_ܻU"Yi`8keƗKM9$~rZ$ <֚\o*W!"nY' Y_bۺ%X+dh,-1iW~ol$IkkkN]?C+*kn2 ʾ?D^^} rc<!^) /Uil}rQA ӹD8"e/Kj-M9CX.gad3ށkJO 2ܭW; &?T'7uG6}G:55[pBO?f -弡0c(0O$p<< E7CSOGy滏Ȓ"W ĊWL;ZSaٷ l/P endstream endobj 333 0 obj << /Length1 1391 /Length2 6232 /Length3 0 /Length 7193 /Filter /FlateDecode >> stream xڍvTݶ-H&M>BEzEz$@( %WID@A^H. MzQQn,xod${^k9MGOzWA!|`$o"@ B`DvI8 nRP4Sp>~wTu(v۸!\`wӯ2rv#$SBmf(O߅- 5 pՔR0;8H pWec wPb#l_w@a;Cؠp;?ձ0{n/ ՞7 `(XSMEUΟSP@y0 ,,IET5- ,հ PXh" +wM࿪4 `~0,տ& S< !0UCC>Ga' */8L?_NsB :(wįG 6 ^6LJ;VCp{2e3AQ&`$(" `{2F;?`r#u?{o;#?a][^mq8 nC2=PtR!ɷ:xua%"Τ+\5kA:` +\cI?&ޯ'C^28] {|ޟ~k߄ŞG,SPXN4Z/[{}Tbp(ْO3ZDq,L)c`  9Vhf8^6I훛Mz.tY.Z>[FBm|8\ "GIqrsY͟ew7ajIj1o }*b CW#x)ڸBqϣĬǹ*R q2*fչ)E.Brqz)LNK)w>٩a7F$F(<9 3mLn;(NV#[]AoRHp>w;',^^QGLcVss IkL6ȱp{7Rc9fW6B>/WђsDÃ4Gpu7y=J\ڟK_n<> jGt9ÅZ(];.r'G$-L//q?eZ[ek9GfdT3S)z 5[GO't# 7DۦO)z^ gP&T3ypwk@U{IYy<CxC bDXLyĩɰu`HW/fuX%Ol׽o뜁tG ouHJfG!z}%יOU:u.Y:OtRDFN-3tgy1Hz`)_YWZiEʢn2Qg1duL._F*wfna 'Y#oŻJyu L#]miul.~^QYQmzn4$xs-f<F<ݧ]}PvLW}Y Z"p ׆L:B4vc`Uk)˭7 1ƯPMɗRoZjQ' e5c%;z"¡kϘ[¶| #+*@[ʕGJ,e|7L+-ԁ*~䄱u[˩u ;Y^С9.(8|tC^0Kԃ &O^Zu6F$&ڏicOw9ìO%4 UTKzo$xFq_~s , E%3;ASKDA^\.'&e##VL -=3E[ںF2&Jv[_rl_J0o0hNR'zXy KԏnmI$R^[tH nRnC@,ք*+HY{h6ŇV­Tޟx_LzJ8y~g^#FKG`aqC.Z̭}3.sڅމރC/]*_,_ճU3K{[&) K>薷G;a/罟)xO Muw& R~P j$:>lzP@_@@ `XT tGY;'8jqeEAbXn85&#$;Q璷ՙ3c_4˙&ZBȥ]<Ζਖ۽zr+uH',.)ޢ٧67 IYtg H=7 |X4Zm r~Ѻ1w2C0y֡kK8SnEBz0DiQ8 (ѶfqQْe J@_n}Om ͉hҭ2MSCWwBUj@C?:쳹azqtld^$C3>a0GkchӞD"r۽A9j2a2~v|mkXGVUZY h9Aí],bi 8d3ݳ3މ,G&"qM0Ps!fE)7FlODD*sԣq/A ̄Ջ@#032#żR_0bsD*l(Y+MQƘJQzp$x23uo3vk}UA9R`OU+DR_t|X z.2(T!Hֵ +=9m{ .O*]fOQ<YݒӶaw|'S[]fʅdw p֐"|A/ƪn~CC[ \:؄U(LO>DȂ|*ᇷR /7M<|2AER.UjV3 4/(ȞAq=0&(Q ղtV$u֬gMLC?jKw%tuq!ښ_).x`mP T[Xi_ԄʨKNf 站 WVŻߊޕJ7Yh5Ier B>Ry08RrekC-;Dt yx]X]Qzu)hK j5 69V ٽM ^W|e \Z9S16^) ?<@NoKc$s>f)rmfZ"9cO9EyR޲#B[jq#G>ɘak5 1$˙!3J Z<N8O 'vr}Q?N$Z@VMPxFh~vRg#9n #yLx)nӋr~uxFLRLs k{\J*?b%s2-9]I5t-^Zl6Ld~@oDͽ-9ݪ@.܍v%V;[bXş@~vUDnLfѫ^;wbxY_'PyaVڛ-ŲGU:"vOxbAKeeZhLKu 2tEvjvCuZQsX_4X>.}{HɪnhZL,Pbe)uxMv{~Te Q}A);]fөX- x$ӭ^{rΫ$_mwI7(BDz4_WL.UE*Jᱏba73A V fb'~v4͎ :{ z|{6X.wMI]^"&{95CMP$ ʉcVy?!r~@[fOC(XAc~jIN-PP@bͽXu׏ 8kJWq2<$sZkں#Re4'W@ł02z &GLPEFҖI2EjqCx+ë^h)jc<o5ً D0gBi;$TrD_rOhYy?1xjYZQqYׅ[LTT q\[)O6ŗ;[O+BKi}l2r endstream endobj 335 0 obj << /Length1 1548 /Length2 7305 /Length3 0 /Length 8357 /Filter /FlateDecode >> stream xڍtTk6]04HHH CCw7)Rtt7twK |Y7+9 #AAA'PJy$`p$5V~~p3,BP9٠cj zD@f0PD[TPg`FQ  8"a p  6-_ZqvtD[>Bݠo 늠2i:WŦX0A$O+54Q%}ɚSE!#^t{n-sIJH4eK(9rH89|d?NK#,O n_/]˻nrZ7 ~3'!1" Y1F)κφ1"a1g2Q4F1GoU> ѐ{0gwPe:-JOo6iW1gi[I5 U54u3py*1pQ7QC6 {֚V'],:]}sJwj\F,7H_0i ʍN̨Uzi BZҼ"%o{6x?! I~!Ѣ饒QX_Pll>kЬF~7{]`js abw#:ڷj> nc>:'0a]&(rϹ~wtyD|I{gѸuGta#j6FcS =FQ*$LRzl}t[G7Kz5e>)PD3?x;FD⣛[e)GR۹dquc@LCaL::΁2>e:{J=D/'bb 0*ޖ0>dpEІ>Ϊ*i,Eb8(whGr@jIqnZ=/ Nrdgu| K <]]q{!b395>aPjt>3b w Z@ƣgL,!!&Ծz͙ @v>r]Pt|/exNSj6X2Jk|{)F1gK] 7˻ .F&!m%?ja!8sS*ڧ6ўeߒaj|ԓs4;T lgcrsP~|+=y.m'vڂRe&ks hl|\%Sj^Dpխ-V [0|zA1`i|1#a9g[lYh!ZSmNG/);AP':ꣷ\oՏ){=?ֱgt+]g7ۛw'Eo2&nqŨ4R 0V/|U9?TW(0Ya[ЬQZ4QYj"+riF%uS\LXzu)]\O${ė90zP 1gͬe=Ypge J[lÒMZŖ}(x)t/ OZzP|?3I҉ & 뜇 );Q;7sN{*%KFOu^}CkaO&F* HUl$?ݞTnyr[@jG 97k/(g$lGa50kþc,kGJf"3ä&6hU yRxp@Xp=F^=lPQ IZ<(f }"i[c:z&A(BnM򞚪D$a Ii{_BR1`H¹ NS,\V=KB;c;MšF4:J\#zN?}9+٠vCøcy kNlp (=AaqhUGuTV[ڟd&[!jMe,V/߼CfIt@Z}˘1ɒK<޻]jګR*Υ/qS ,B)" >R"?.=ONXG▼qefBOpa-ucZ"F5„5ۺQ>l3adG|h7,iOp5ЋHbU Ҝ~! R CA? J^[>zѯ5qHE}Z;m)wW/ (\}d`F hᚍb Stxp0;U%/9+%bF<Np;ۙR .~>Ppq/G%YP̎=;w J+=nӄ-s|aR;o)%8eW \B*.ZE/uxMëSҗw-{I#}m[+״5K& &]GvP 7_R06SOlb6i 䦔}Cƭ-ͩٹ9fwmun5ǕipJsl?3nB+) ;$)הOyn2ufxLw5o|:nuY֦5zY_l#AU? WA> *q& 7ƃi(o\)?{wqJ=F[m&CDaa+hoTTqD3uae@i5rAE\ݭnS˯Û5Y0cCUt gd0bGfڥtr'@uWc:SGj˂  99p@iFE?&mJ31AwM?y0rQzS_H\)=^UUu:M|TSp&y2j8 緷[K46V#" cjK kj6 \VkcG_}8LX9n.ղTFFc(Zgt~;h])Zlrħ}|4GJ!.rcV>[NV`5H҇Gr/$%ʼny(!?t14hf'w/Z!fNLA,z?]),-ТZ3þ,#K}v\?0ĸ(jbsg> +C8 u)Y,j]M1Dy^ sG09:|Qz۷F^wy_eU`:MyWyfu h!fv34 aAY3<}Cū/l+:{JDrn(oU0 Gڟx56! YO$GUUU7[6,s[Xz8 I>d2jFw˙ꏦT)tl)y - .Zjhҿ~e8~ADK]ڔzv9rKUEr=Jf ĉG/Zv߯To;, aS?^Vk>SUŹhg[dzʕVy;_T*0kMUCGYM> :(&àZ<,38%ڟ]'ө|eujN BҨQꋏ"%_]\57+K'/'/ƴټY._,l^(2ah&}rIJɍkjT LNj4!.a3+l|F=}jFY$!~.v|&DDl-_Smc>%tZ@@daqprN BY׊zzo7>12!ψS{45q(ɪpEv%6Z43^ukέK> stream xڭVgT[֦K*J MzMzi! IHBAQzHG@"ҥEYfGzw9~~9+\lƦ*`#D  h\_PNIR..5"@ D` ! @TVV @.=K^~~?=R`Op@C,|`\ '( P321h p {:  >!' p0Wkh!, {  HFcP4c3 P8 EwB&D!ƠA((V5V'U ņ'l&p4h$ 苭Cixp?Pg X,'ߺ"0ߧAC`NBbؚ 3N*kQtN~'1/x~ /|`!- T߉?"DNܿjo `_@@w(oh ߁`1Rᄢ5>1r8a `=F_bf.P%A2󛷰.__YX1fH,a JŤeR2iрFOAA}-n?-ۿhA-1`b+ Dz؆i^q"ɇge`^0?x!,7+* F J^tjlD\[qI|+` ,1U5TخzƖegk)/&J.G[QĻ'^ߑ8T 8/mnIZ?=fs6n G˽hBQ/uIh3oXbeHDψqiréH_Cqn\oi2\ܕg䠣,\A؞:!Q~%OoCMU&Ci5y7fߎR@^{GmXLĝ+zPEěIh53ʙ^^)bG{v/Νc J53˨)x0q:%PzTi+Er'hLe[,Ϛ^9<dS!sKv eH8&͸{` =VqP׽HȘh(XӰs+)ތ&p#XC^ ^\/\t&TC5rVHZI:f.9gxKg%oF˛GeNYxSxyϥ8o|6~q ȡ童Z{ _1+ߛqxO5hg(^)]=}D'PteLgfRa<[9ON|tPD~{HwRͤDW1Dzj#mh*a_vG9em_\`9=_\6E^s OPkixNy Hc'ZwQr#/FxQ"y*-ŗԔu2+\98rz!}jG͢bAo2c"+oN׊9)5nS;op_t!8]U9p4*炌!D;U_nppC ڇe'5e}g*b,J#69yzC-wA$t^ U6O֎%t#LkQNFT&=(_a,ۙa4dP&23I;ߺw`@-jM] ̸ƍOjg.NO4YYŶ7?J:zOXa{.0AW]W[a+k"Ԧێh $Zr.)KD-okuW 9 ^E&a?nһ`I r*bSź;;Tg?I~eHU`Pe~ePF<`.Aa76A/ɗŒ徙;)"ɯ;YߡQr75!c7N)2ݺpj;ǩnr:]|ŗfC{wtI/i og]I7,tPq2J©-$}0ێ w06brRƱm}^2\} hvtTt{/9+E7I z^B;}k}8$kG>\_C2ؕ}k%ƧFˏipgP=?=I0;\m¢OFV鼅d6vI.obKiZqf %7:}S5g \M0JOGc3#)mKh`*#gvIě,r^y*FL(:CYIL\Ҋ c!o l5#*%\}Kbqw$pGTT?ZLJЦb\;95ӥAN qOkWWş5I֖1%c">Y/#;^cn0w꜖ Q/"kKOiKV `ԡB%ݾtN3H9撮)d7)}cD'<05=z̫(Zd,K_rHHhGc2N“Ąb;=9n4($<o'':'^c|mL4@Ip]ӝ#2t\+uQ>WOn8ۓ T_˂ M 75MNG8ؓCKP]/JiG BH i2! Fm XcZ ߡf(|VKl7-]Xxo**)Ʒ Eu<\\EhvN/1 JOt2~".λFލ4  gke湃7-JCDKi?g]+'P/ɥ;V!vۆG=wnڋxVHؤ€i~6{4EKǹ/b( 7d*aVC}}si˩k:K #\/dP,n7vQyGz`{Β(TwKyZ"V048)F^FeLjbn쎏չq %#;3 a͚h/fQ ʔΏ}|a"A6J!V7'GW@2 {\(c&ӪEČ}jsYa_ʪASuqS,ג6FtGodn&~d3;{}`(ǵy2Ŕc+vY2JߧiUP&7sh 5˘+CvN w;>tEi#>_ߦg|TI~U}v?Gp/ؿI? 0NuDKTI}$mR9عv)G \T=}mrek$q]{|dE.SnR;TIYFbZ 0y7j7ea,ɞCp^<יA=:Jb(.11g[%CӡӮ|T&TJ7|awa"-fM8 o1-wW_Ђ[xf u<o͞ϷKty#,^\ͰUJ[| }JU(,ZxP;MGuyu!e6wm_$U2܎"!;`g79'޽`^L _ Yڇ xݗi8{HI)թ/OL^ 3 .v$n)AdJ\O^*z|pG#xDEfSu"_*UL`$L1ߦ2I.-M1mٓ5EƝ%Y2 ޛāW?;hAaےo 9Q6f"`Mc?X+,N!j ?n[wO~<=$'nnPOϑ#%F/ Sv$w@X Tk8_EjGO2j7uk4лɞT8nW3ƅKZMx{m=k[+|1~ɺuOHjxoۤ\ׂ]D^&yxI endstream endobj 339 0 obj << /Length1 1612 /Length2 17549 /Length3 0 /Length 18389 /Filter /FlateDecode >> stream xڬct]%ɎqǶm;;mΎm۶m';c'ӧ}~\c\֬Y5k{)OZAc;C1;[gZF:. ௑TVل fb 1101999aHvf %5Jjj0ߝNf/&v6&!7418L-M r q95@ cadbdB 0sX{054'XNm&F&h&6NNN3G[=pXYC_FSsrv2rwͪ "ovؙ43r:X:Mܝeh0p6/ſh8Yؚ'_t?o[{kݿ g'kS:F96gP$mM _ gf(009M SO[oMv_s3;`o; ;n`ca_LMGo3m @o9oeW56q5迚 ed`/>es #+Zo%WQUw꿢ja,E-sx=L 9}kYgG wߒU|s_`Dmq8:U_'oנq[e;aLh 1ؗ6*rVԆ5p}{,JQ[\S ouS§_YdcP=ڛRT-dvy'v-G#yG5JmхRWx~AxD>4>:2{ C Mm|NhǭTJwg̙FcX Lp$<4}^/gȹg.:xq?X3@4@ rMg& Ռm(Ͻ=Yo%m?xH`趃Hˆҥ#:ǯoP,辜I^qτlJyǻ7'rZ:wZ:Tۛ]`qdFt hnK8=-*-廫կL_((Mwrz8-ײ0)3RX s*d(|I~ lP?!]#Iqj>EA#ߺ߲H-⦊Vv5tu@?k1?|Nh` "3LKOj?)ڨexy̪HijV(Uʢ8anIVB] ȵ+6[ME=<1hX?NMHx-Sw|e2$;AԶ;X+%v-J;dT!ж(=P,1إ|S=+%8ofo b9^XL!?y(0+7 ˆ[Hj$:1Jj:%&͋AsB<)Do'x䌲"YQ0 :ɼ5=^P*&n[_VOY[ߌ9f@ޡ汵eO[}lw|jlַuP8.TPk8TQ-oRqJ-nq%yZ~'Z',Zhl_sL^w-mO=">`od>>v,FᲳ(zH}2K**sta*pj9ɚ(>.CN=o&l=bׂiXÉ1^}mq(r[{B?Ԅ#V(-Tܢvc>~1Y#]7"8hG:zOU A8$ gMUQ &|SD,E6 )ԽbO1 /BYUԅ|iMT=B'kE=Eyz2 %l||FtA?To4fOY d 7^pTu!ZprB =\vRҴ}9\D˧%sf?p<"8LJ $hЙȥ 5Pv>^w [י?Dۿ ^Q(e!i؎tg0/WdA^ISPjw\V Bݬ>Cr?'N{&SRq|:??W_ Ӎa':3 eoa21^7K<)ΟmWCaE,B&# th Pe4p\"܄ B+~yjrɣvdqKvpF4}_ǮEԮ3$bcf@ Rd 8YJkQ]Y[pyus-緎Cɠ!kq9إp,X=RMXhDA*9Id(ܴ*y]F[30A3]xB N/*N+ /݌Q&W~x`S%Ӣ]k}&->?>*XRԛK\(:w9&'!d6mClB3aX+Tńq2Er\`r.*!fP74.z kݨ7K`bF} U)Q 2FZ^,[ 9 DfCQؖ&5kAUp#g98 Un \d%xoπSpfL^f6ekGN>NW=u;Mv ;%pKڦ\'wRŇu~:OFCe#w}uM`IE 2mLBz|l'%ԙr L%o^{H0m{z_RhƍYj1JlD59AF׊ aghuّ(SEg~EO lVմ㰫VfB<>o/`P^- k0A})~!)rGnΟʹdxS1ń@xd(pEٗ'ۉ0jc0j?Eign=֡ȟ$TGuf"LS><JF_7AAp%@? gR|,qu`J)wzq9%?m>P ^_(nNT};Q.(,'+5:6N~_#s8P/%CpdnjC@%Fvl豾[ڀP&FKm8L&.lӖj*AA5cf@(r:NO[W  h jFu,o̪֙!*)Jw[Rx+`W%+3I3v Bk6TBlZIɅP4*vk2ҿO>r4u،k\/4WT~γmuf.`Xve(u]ic,|$!O 49YI)+|pՔ#Ty5dZdIM't6Kw:l27||i}cmQdEOjB pJ6̸%χ#X8 GT 5ցm_Y@{ZS?AO~9qΚ{]u3>ĩ ^{QV0F?y@to~$m_se&N~L5;Y#EHeUvddXv Hhem'9(ocQ8h55 wxNOsg2k.HL(dSG՚-ކHЪnaKou3%~fϛ#Z jϞ!vA9W.`^ƥȪ:S0e$!PphgTY寗~'[8&ZiOo*$11>y~{E,]foh 2 Ki6#-O.qUkj3{,9q mT5!~- >\F,g -u&/I*290&[~V87ee ꝫJ*Y>`dzjrsm7_qR ﷵz HȘD2|N[0Yaywz$Xٰ*Iѻ) l/| XkF %6sH{I9j_TrLfTm :0R9v%.<̠q'Fߛ$J`Dv6 3@f㭶wgx WE~M̒?A@< |R[5Nx gh4<~hzp E~`p1Z s-̻ߓ[;ߋИbKc]EYmΏ:мVT6 ΋ ы#0h7"*>lg ]&9+ӡai\5ul'v-7۝SQ&8](}PQ `;Նzi)Rx(̓hw //]#IsNM^s.¥6dʄ we-upӥ+8OS"VN|HR WģD3+NbO@P%?p2ewC ~ X‰*S AHf!X@w``fRmV.cKp΀rZ G@`Ar]Μy∎[~w1FOZsshhf(番S"]t"-Qeulx!{Et[:qIDT lIc>  $q-!덛KWڊbƤk}j$*֠Qa&d $INh:$FU{[}Z`M5O#IGJ 4(rkm>ҊyU@mtkuS&^~ G~"P-S=2imۧg)'21'ޯ~B;P32-rdZ;Ư Ԟsw7g:m]Xޑ况w٨iUG )Fx9Sh݆聎rb8n2-\QzUe,ʣqƥ~E \?+h}l|&9HXkX[i`qX qzk&޸!&'yH_RܲltiY.GЍ 'c>}X׫S|(5Js&{l.rdiJh7ʾo;Ƕ.ApӗNoQxp`{c|r֞O]᥈ ;S+ Sr*Ǿz 'o .<Ҹ;UnlML|av~Wcv-iZfNY\_xm&QrP2M_k1AÂda-|+s1՝9=x/ոVWrl'%8T*u8_Jm_#Eo7哄ed 鏅)\Jʘ_"J݂Gg8<]s8;`~7 ΜbAꐙЈh|qv|nz8հй!jBN}H ]g.͕L$R^!~X?jiQ q,vQDeSe9vƲx3Eۿr$oAg ڌ\hPk3TY5ҿ.dwhUiwQ\TɈC2 m;-ja@1\yG2B)kB\~;9}6FYUkIiԩvSltV>r?;<1yV5_L9xռCKUbn@ gØΰo^M>_ca>ﴈ Ү%xjvbԠ;Wn_Ǵ( *yM5~Ø#y3&]4&ˆfq.0۴/ΐ9n]\k4Yk{B$QqI\")E 릅4sr9}tGI AYaQ[8 F6`2b ߦZ03@DC¯(DiNZp{35 R0Ih/1QjC@Y!xA8ϰ[q"AnjIJ湐 F騝DH\yس5ԚCT-@+̂I֖D xﭶP6|l\-{_}<F} Tl1prx7Z`C;K2pd+ƅ:HbKrcAV\È5OPZo r@l?QMoIAF*R-b(TyȓXw; D|^b E' 'nܑ=i2$R9,[P̺Rs3Cwqr'v3\YCSY2_|)W+@/x\ij,wq(b-6j'As%؛bT3sMiF5V˒?^+Kt6y3 )2,VNFOҸ=s4HZj$;<93+n\+߼y٪4͗]~QFR\>$fb +D: Ab>Tv!c8^aa1Ɔj=$r0u5Z8I ͟ O kݞ3?CHϓtk]Y Cdo)ٍ(47yVc#T&ބS;rv(mZolƕjDgNXj1B'X=/I0 ?k%/FnrW'UY%⑂, X9{NjU)m_뢞.]0*zߝa6NRmmBk%BG4F3Ē7)F1O#Ljdj/ |A`?a~#UuKVtqtatH~K0;}6Q[yX당v]^i_7a~72 i`pS)\DTb6m&K٢/i20hXy3G|e5M,ձ D!_;&ݰYMI/E^(KRGOJm!Nzɸ+=r`CZlQ@2A1/;mJq[]H,c^{(d_1nŸo_3T7P?3 ((m5^6Ȳ/.f) ۩, F 0hM̀:SVC.wsz3"er}WY`* Ȭ[3m s>Fhg;P$} Olݻ\0ed~R(*xg!Ψ1c4 E+FftӈށV)C#Y ㄔ&ˇϲl($BpmYˆd{pqmL5"0CJ8\$|+@&M;0E˜E<Ax3 ;븒͞4X SDW#mp15)owptB/+3jApz_:](uGǡl# t)rɰאAjXPٖy}WqUUOډ~ bm,Ph#wqBi3ȿmڻ`vhQKz/_VRQkCmT)2w$M.JT39v'N(eI3+zkٟء]vc,j缩6+ZZ -!%^,~s';JE 냧"XvT?ٙ[H>޾1тcZIK1"8SA10Q}U$q2a+F"O\>&-&RY`\c>K^%d4ZW8T7'jGݚoKb2$hXu09 RA76dy6oO\6ZrhαDS<3;m%M! ;nF«tv>^-[rFo-K͸ѩ\_KxK|.bߺ, l 13:jqc rnzv*"*jtvc5 Yy&Ht-Kw6|^N8.e=։hl96`X[Ax) ;pТ8B?ÕCKDa[vL Kl6f0t3j!tCg3mGjIG:4crzF;R/gkNvX]%8O`^D0;o7ǣ-MdVy Jvgˈ[DO mw5}۹u%/ 4q7Sb~SN 葡SuQ#`z}Y"$~/h紆D]YV:v7 `fjw` w:㦽Ɵ/`(m@uI?N-u2aE /)tZ^u~=ϓr ?)uI8`">~tuX4Cdָu tBI"DOA p9w!J8z 0ςz})8nO˟_<+1"@%W${OiKz W>.4`(Nlѕgp"zX}̀\(zs i^4T >0oM {yԛこ~=YfoC]ob~sn{n*L7y]mQ`G=DwȰ ⋶j`-$?-Z> Ү3[ _{t|uOMۄr%KLCKW42̞N)mZ,FAdzxҎ[s۶\ͺԖi:b 3 #tDI@.#6$ِP~!]x/3ZF;",_3HkVjc_M4v[JSmk`GäyVuhf}rt",:I"(ǁP B4!M Nlh*?h1CmE#a/I.$Ao UvvC Oݙ_?P9EIL2TB.p1312TMWi_Օ-@[T|N%Q7$aBfY`RINx Zz?6k_ xQhjqNxoM~Uk!s$DH},ceo^n< 쭥V!uDX0<mNsFcɍe֐14=V-Yr'l݂&C/n| W12"y`,oZXde)r)gSuiy'ACx.6nnWb}ytlab tG~<&+xw*.KPVjTL4aPf{ (\=%<6RaE-ѵ5ĿtM2tI\c56/9pN3Ri&G?9 vMEkoulDiJVwcI!."OibA0 CjS VsyDXѯhc[3BCaBsN*7pR0x יOYXw{ L *dJ4 Xޙ8$BnlAdѶ_F[\vkL9 *R5 ؜QbdRbp!ϐo]Co \USI ?x<_Sv;x A*4rZ8?|{~$2M2sI11<{<m$?z"U\MɐGEíp]*~-=;Dr,i,Jmdp?pKx p q8΅_'灣WU%y6n)UD[bʩJW) )u|u' 2q8&c>: tdTTُqܔpK9WO!($V/=کx*9 O(Grdm,zZ͵>D*amPl10eIn`c/a6?`s %R Rn=>%1ũeod֠|;Q (AbZj'B_}t1DmL\Hx4Var Rx0On2Y U[D? wpk2S ^`A>//1ᆒ%g9`{}YR9-!Cȍªr]C?#h#!q9<-qIIQ vʅ`+tnߖ`Xq> Bq3NJ\ /u8=eho&yHig:+A_2?Iyq-޵xIjS6qa^sTvb 6iXTrgANuP\4[/Ƙ^)Hd4k3k5+\/E5{#v]X}3uz 1;g: 3ۤKRt05~؅Ƨ&q tb@S73>?{>0bR(߽} lɉʭ(5En@/L*qm&i!=z쥃v_*$Ӳ"׊!z8-/ Q n$:&,ob{O =N*sDK5׌enǜs@<&FY1-RjAGt1=CY̼G2lqTLTX=CpM~o@IK25l8HaW|S,Tkyl!:VC{(?q{Z{>Yp-uP*ՃB28HSqW^zYy >O#O=Z#1Y{u4W6OiW'l ~>j3g3뒥4snLD D1ZNw3&:`kl146vAacyOd41[^=Xۃ{o0:zx0Ekfq&ƃ Y/j{/FQ@x 2 %W.9z ].#i}#KBp{ۏhZĚGYT60C-/M,~Vzc[siRt-¡ jkzY\(%<ΡSE8aʘ1428(;~9Mg5 \GY/v\e/[,~(SG:4%UP5j)NXT^>*hCzc`6m[hۯD|7 |ر~xԿ6.}PhTW(aK|V^pESHE߹Bwᵭz4q0f${h4PvO % |8<Ćd`Ǯ!S4ڭf4ml9 *D!~+ȏ>|u%&`SL{JCN]-3]jRTQDP%q)};Dl4>u 5N撚$7\Gl$βOO.EąRS$Dq0ﬔ&.1,4͙S8:e"5;;zW@ʸ䞭Y Cj(]wD7OJxڼƪZ2F[<)36ߪb'/3oC3 0Qa0X )#G'$0ZF5to DȀ(8KBؤP SἃOEܲQRͼ:ҧ()'ކ1  f uGg@ʊ}IgW}7ڋ9$ K 5ׯT`Gw#9~S:1庿+ c5c[Ĵm Gau% ez5> N$@RVl{MFߡ 4"[.xɼE6D0hˆǫ#0鸭vc%c-"W$OVL( Phb2]}AS;zv?@=?Y&tOSoF5%5m-z蘈2Km1d{ r wu%:bPǜHFӮaPTЯ) > stream xڬct]&Vl{ǶmT*c8ضTlbbUPͯsNcqkk(ITELR.L,|+;W U W OI) 4vr0v4f ) O wpttШh3hz,T?܀v@{׎@ 0*Hh@{-@o)9+S=H 0wp0u74_,QrZuzQ1vV o`ll.+{S[W+7wWB-)9\@V.Q$?AVf/_Zc+{O, hk7_0Gg @ cg3[ /?:[Ǝv`ښ3i7=VDzFB^Jivϥ}Y>l[TEwrBMNn@f2ShEm(.Ieҷ/DӝΰnȾi qX]M`uE'TIG?Fz s(q|SNH]<M?_ܸwP Nۢ\j6{CrXRf)tPf+)'%L;=r=E6dMrE][J"E 4*+0I.:G5h>I}*Á֐?gE8]t Gl[.M@q3- n^+N7΢@#30zE{B˕EK<.b"[Ώ Wl`͐/}ÇͣJ`<6~:[P}| )Q$j)P4:RN@Aݮ~jm<*a47>Bcۀf7b{3Pi%\$0BS - GMStD߈>w-7tkݧ;h2ĉ4t)Xn+G@®왍XE  LʿԠ@: uVU},1U~&I3ɣ 1]r7Z&#Rə4Z0R|U>58awe,ONO)дFT s [F]>ШHڒ i1lj;rGn~TsO"!aRR{gxIwzN[JD /13QS;e0k(/xk5Gܦ4&%=B =kh*6IzaF]LZ\+|>:?ӨbO4USDdHkF<+QW]U"\~f\ãKSGg9u^ c_Pf$1#v/V'ыe؆FJf"(OɺF a˦g鱱oݥ⠒?kYtve͞Q g' zdņˀ]o.\wW0L6ߜ}td4ʓ?'HR;~c|3Vi%Q$,i Mnsxm v 'hLn*} !r*a^p@n>A^"($s^dӻ·1z'xsPÅ@:hTo%ryk7\l|dzIdӪJ/TGX7tykU/ L@4uI^KFQC$:Vմibs1ԧX7#>u9Ur-Dqub97Neq.䂲 jf>|*qhqg+ l,5:Vf,Zd=gJ‘A7b*7 ?ӊNTD ļv[W5D60̧Ϲ w511A50rz Z Ua3Y8uidggIevj BO𥣾߰)B:O%` Ee*DhkC%o[ɓJӸW=9-Do<[aDAeb4=?>g"r@9% wb {]=?EvK~Xp8n`X3C7[P?pa]rKQ=0CJq( q6 zrrPu/"v?c]^ IgK,ciC҉к+űҫBt^#Pj)?CҶ'xCEҍσN[ ?[oj½{$NM[A;wHT$_ߜ܇WQPKJtbVl0Z%ӷ[gbmeSv!FpA:rC1Υb;#?M]Hdvkk&T<:P2HB3ha;4Ÿ '"M#x9!T!@62(W0UtSœfԑxcs;0)*_.%Eb16 Sw< yI:@b>C| ܌KFJaDI֨:ټG(\kZ {2 G /ډVZ埢5t0(N$Hl~IxM-/`٥&-Y$R\Y.|(Ri0kFz$;1͐iԞG'H +i6ѹx $N'K*?j'B~ o&N&NJg5C|0(Sl+3Ih D] DVp&ijPȀ O/j3cz='B?]~j@ǎ.7h!qŇJ2)mM{v,CI<|+{"}umɌ<^^oNBis8[,ǫUMВ!=0NH ΡjЌ|~|?f5FuCӪt ZO'[l׌7ey5 FM*!l o*汸!Ծ ɄDQ?t^$bv eHQc$BHM "~S`{3`NH9˒x#& g-R/{L;iΛfC*H -\eC܍:?}|MQ c^eG*Xz~b(ֲzO=}&hVXBbqNaCۯ #h)j'^jѸEsЯA)x5M 8yUٍ6%Ӡk6y 0V"箽x\[bHhBL7SlM*lU;=R+QC0]/ u:BV~Yy;*2r j)H$QXuB 0#mN{tDw5ieQy)œX̲ItO'T}2̲ J +`%sCDy7[`>h,5iŵGVopŃdF0:wZuI(uݣ؛ҴX+qj=%I&Dw^exFV}Iyΰ"ݧOͶ=DUN9q2RNu~`W&xcwj̇!r!^v ,g3kSߵusRRJ|j)1%Ƹ).V(pWG/F?h(=߿pE䓷A(Yf!D˻jHnzsxޠSdnE 3fڲ%b'Ld"~߁~ҥiHByͯMaa2lW1}{Ác֤+:*5-Qqr<)3" bW!%}"[x &m"$8Fa%ܶ6L cbM2DܹhAGYUz+,kvuj(dCʥiTˣV6}{N`k;u^U'Re匧 Z3;rQ%tdޱbB;FMzgu"B$fe$aG(XR-oy({leMU6g5%{IHRȓ*3+: vpIzN^1`/>'f$| ofh>ЧҶEN 7Xǂ\'ɷGk_1jQV /Iq6̯ ;Ce(r17G$ӣK% "%mR]ƃ I`#r➵ "+qbZxi9d>` aZiR&!@`"*4A*m-\u{Y.ͶhkdPWP rQ*!T߹8C|hxd-eoKr&6l 陯*XCvJ::X e`djvuD=U3H X~O[DY@9/j=ޮpP6̇xSрX=Cm ~UԶG3qYV;;D8hPG[3gZE<'.wl-S G[dZU{.a˶)f.v1c{/bG-)2طڍg>;C0<7nf47s-W;bn٫ }ý;n:kp6XL$:3{R׈ra3H>hg ^t ^ݔ\C)P$C\ z PfړHCB}Rھ59VB;[9UٳۑN4$y#]; ōvt;jNֱ֞fК ~_Dph8H'HEZi?_=Wi7 Q5H6I¢wO_^-c"?&kJ ~*Kw_.R"nZdMŇ-.zD?ZB!T*j]ȵkN2amG陟} 07Jl1DFdumZ (Cra湥F݃2'$0)mb+5eprCK}_W5@}hyeKVѫR#S D r$}. D*Wb-brft2.4 ‰v4[A6Df,w]*#d;bc*?qݣfbU~’ 1u 9%\<*;h3VHf)o5Amza5mwnĴqJF>ouvSo]mѬqn8"S^5i}Ѫ;é!kB, T[467SvqZ. 2R)beLvЀ)čunIok~wS^zGӍ !iI::h*ae 6{jpB.ysQzq+5So6Ap;@}vꊳUbZ:9DȃgLrZ2&/x٩q!uڇ00mW=TWr~]9ϓ܆ul; 3\3"$Y~Má;PG3Oz;AtieCo{\޽қ%DxP;0Sz>;vd_L<_SAe-qBWm:lPȢ-A3@(gfْ+ׄUI7"FOOnSNg+?;hWPF2X+6>~п'/NM}'t(#iQ59Jpr#k`fzU?̙ '0ԂO~B{3:q)_<,@3E|֪u¶AS ϴg4On=^J4KR\H8A$-<1ys8ίkbN;[>ogMeFßέ!GCԳ4&Yg S VJ{B K\͜SU\uC!f>Tޯyi5Xh`U*%)l8‘Q&D\e>5d^שvb{} lEYyh< :"2?Bg{L.HnV$|\W)bK+܎J̍1s!1C<=_85#^TϬ;~LvF[M:j-u{"GW!S2}jhٔ)Ř5 C~yAwƛ0-=Anj\s4sv#7t{Z l ɺoX=9*iT[C B/1Σe.k+ƿ+W lj֡}*}r3RcE=S; ;d48$=1~lW=Cǵ~ٲ^]Lx/ pP֪zoHMh)N-s}tp@gVwzѣ'Bj һOFV3N+i󘍯k#HdJέ`VWN[QEj.6qo"C{OBK%uó\mwAhVcQc[1hWj}t|]XqJ`p.ŔǴn$6hcņUPZkPc\8Әr&)%&X/fMKoJSocȃmo{+@g'EpaI7[w1R10ÐQBYY+(-nGr#t9H-`gwؿs0V?PKu$nD6"$eܙ&G~dH\{FuR;iV<*sŽlsq) }\ h$@^x5.5KIx\fU՜ߍ}`^^l%>/]6oxͻoZy7y4BP9We|>8F߂J`i\ V#ov#zyRv[nG]=94$Kx$7>V 弭14{o( MꌜXG ̤uLW޺19Kۇ>>|'eQCGz=gp/)=)jO)og(T GLgz7a}!38M' $u<gJiA\™PՀH,ZFDq_ԊX241~y+y[ !nZ~3e}yvW)͐^T|&zkrh#%o 9!7GsOtXAiVEA-5mFxg9f 3:Z{} u+:3pkYeJL@oIN]Ů%>#*ېUyEzEp^Fxd6okD} {X_0b˸$#p\8d\*CIC]Ǧ=1^rh@tnI ^Vau4^HY9͚T2A]l^..nbu+)k`Ԇ2UW,|ZaQE E(euZ>[%E(eLqh"RQ- sTNnXYrl TFխ? whsպ?V\(iʠ10szH5.Z3؛G4BͅJzQw?b?Ǝ6>E#O?\=_vy~n(,;-"m&3*DI;Tw}``cCKs~h.CT%de=Zp nHHg!uηb)PeW?zIU8"uű T'\Dxuf?~PyWYɄ]k Yͦsy3𓙗f`A <}r21j"@e"0`]PN6og YƒyAɓܥ_\EEF~L~xGs]vm."zn[*SKT>>8ò,2RA@~T*h"sO Ǩ+jE%E!B:txm2]oK҇ńF su2ioȫ$"RʌZsi R\~[>ЖELZ–vp qf:cԇ7h+JS{eSRmch{_5݆McXjX-ǼDCݳsK$w.>u,g(ZE*8Cܺht'6a#ErhœH? ;% ʵjƫi8]/qcfSg09IC=WI\ Øx|qU Wsbt*0_hI;^W,)ndήqJ=Y~%hn;`u\lǘ5Hȑ|~4̣0!efw2ފ~=tlDQ1M!RU%Z2~#,>ntA\N*Uө#MKwk4Uf$~O*7T9,&ck +G6$& sxdG/.׵?򺇛W?,p}U_k2.߭xᰀ5JW1ڲũz۾'*$禵v(.# |류jl |^ 66e< S6ɖ܃Hm,XWrFg-S IT4PXt{א\||(r-H?2gE0b$%0)@ ".Kϻ{ P<@`DȝBׂ[IN3 wЮJ}p7 ]%RؓxxWw !7,8X,uu Z妱2fc".j|FMsp HF 2] q8Y6$|XbyVucNP>g fvgK{x5#7$cEh4rroB| Ky=l} rO5_? KlX|翚@l=o~E &Z!y"&31ݪ %&m1dt‘wIC\[k!dIn%!?n^TzJ0>cɵZ=j\K/2UᛧXyq(~u'`'CېIFiY9-X}{rq'Q+>o:gXT%>s:96ٺhGd085߼U6!lJBjV|Kp!Z\BsjҔwWtGx%s)ЭW H~9aN{,x8#F!Edk3g8OA.7>ҿDo}xhTJ }^%Vů5=CC4p;[+o]K4J~`j]*FCX9yCEQ%57sdkiqP:tp wvNfĜGj_W9 >Δ妔M. iZ@ T*2N:%R iM+e >(wrykV'BNkB\љAħusmfL%2USz'J02AI&C]Vحe]h@zB֍"n5bXTBl1ב]]~hJ5_MtUEzdѓkKobY4TxAkBʙpӐA 2/ţH6UJbij, )'V^'IފIiRdOKbMNOqMkL՞2n&ߤ\2PpPx^ m q6F+'$ [X0ƚ&(7wP[Z~qZa֐@4PeT^E/mќ: - j  2f;؝|_P^j5NM e}VWb!1,>R{f@MTY1kwRf%輈I0C[@eB֖xV/ zRbNp[epeG"|"5C7"[:5]t*Lz`}hC d!}x6'|Q`z03=$k:?6 ~OAjsjOPepf/ײ AEɄb\Jȟ⽹c7Қ, P{Ьz(VPe7_ڀNi#'MUL5+lZB^9++U8Y}Ҫ˒?rڬx^4ڹ{$s4{s. ]. R6MFYl56 14x=Y~g_Lh1}. vF,A5[f y)~˙njv_bi"k S̓Er“@RV0dmujc+Hd'& DJ̭nE>xQYX ;ڔ?T:U'_?HOjFvc(d&iz^9/yJ/#^}Q_T~[A~R10%5gHQ'uJ4D`DcFIgߍ}D]'*St ͤ-q͋ Rw|AK*vL*: f̘3uJv{ Eak^4Rꨙ*,6B]r~b[֗E`elFZQgfvCMj=3wbѓnyEoL]K ۾do}|ԇ>&o ÌV5e[!C*5x)Ҙ}Xg|geiTbًK|wU恎R9ܰ#ji-QdAiL-_{=O{c0ѯtf?ߘ7:k?CT̔C^uFpwMw kŚ!`C"PAXc}JRomImb$7lXruQir_cPhdԯkչGاmZYw}4$.앸䀀G~)n~𝏴Yh'Ul2} jx gP{R2DLpBrraO/uvr6YpktdDqkW&7#|oo[[],ȿu*JLUX$8g2$_&2doa׵tĉ(II\v:Sxtx ߮/u@@j:-{8GqkA l1mSjiHi%λґѽ>DN[72!ݘۆ2$(J0%1WWabU\VLͻ> stream xuSy<[di,$;Ofl1ml!yј"K&Qn5[i![)KdM!͒p#kxG}?9|HGe# 4'p(( PsQ?haBQT`2x'`"j0Cpg d\ 1@T)M  TGǁB 1*gVHqX* ࢠt|2)Ha !"I@HfٍE08n?JBP S@P3Ƅ+@Gь?B#`T hi`aA* S0OUwS:I7 002~0 *dw8T2:mPT24SlkɸP E [ϽelLdH*Ïhjښ 0u4VDp%|/1? oUdK $0M_7_-ss)5;EG8*ˁ]>?:T6"` G1ǝ1HqgۋD npMO?}R( }@槔f4#`G*(2/`Fdx]{?@< !ÃDnLݘJ#_h9Ф4 x*,Ͷ§4n|Ѿc7(wgaeK3K>rJǸ^_ "AtN垞-{SX$3& KW L㈂k'$KoT9=ogG?o0Dgqo|rz$׃Uz~VccE_1#F z+÷/AT;ǟ+s _(1+,i;ZR9+e#Gߊ cŹy24kcouu տ"-a=b=j]>1(4!ؤN*I&{Hbť`}3On]:ZcP#l(OI甚͕v\u0t5lH2-u~ݘcC;ָMR6og. >帾P  !Z ?_w(9Q4֗ܩ:KB]0 o, L$m&8T80%g eʯ$1]n/uɐK=u'ńĶUقV_+}/^ѷe=Jz@hO:<E0,TĮp}!_?zhEغûz_/hwfk|by/ }Z˛A?Wo$P]ԳuR4Wv'pb&?;] <t=gM^jOC'GdH4K R' + =OX=b{*GLz&f>W[떨\N'Fi{+v,QO8]CJ ZrўaBgd-=j<[xv+u.jEWW_FIީ#&X#z8N,\mՁ$<+EVG}l*!uK[;ND8Bu]%QytuꯚY M:V QxH9mp;sD h9ej%akz 3'DR/:y ܴv/͕ßɴ˟x7ݞ[_ִrɊixe8=Dמì%Y%#񓷮B?􍫿Zb<.:QT)|fJVrz&G]qBRV;`¤v5}P iBZEsϲyT ؑ12I/x7qGh?5o|6!)llZK? NKz`~s8ثxj+:*O-jǵ`s:/5mtsdtⳒ4}Kj1ǎ7ZFߌpCW$$V wAJDT< ;t74_L|CƵsm̝*J!(ק/<+b ~I5t.`#= .5P]9=_|9atTM2OЗW[lU|FkVu0Uq +q[ӊ'X٨AɅ4ܺ옱lnQɳ*ʦ o.ݙvU+^Gd_sqo;$F4gA்oL*>6?+\tɵ K^-_"+@@ᝃ(_"-%fPD{ŧiESjYK#Ǿ5E@mfک0Q?zt|ftZI;G΍&!FV;\Y(T6!\Y]pkf}ݖ7޷U&TuB#Y6.|S z_l+gS<oܦ$WQ]rbFAd,A`^?p1L"w{5}H(L2q0L̨#|OuL^mW^-զzvڲg*N,mLs:Otx] YMit8ݖIqU]w endstream endobj 345 0 obj << /Length1 1626 /Length2 14332 /Length3 0 /Length 15171 /Filter /FlateDecode >> stream xڭweT]k&ww''8Kpwwwww }ro7=z^kOSo)HT ['Ff^ F# 4sQP: ,@bN@^& 4Xxxx( ;w 3s'& $C@h : vTN@5 - TPHm%g#k c1H099A&'G!hl f KE:X8:yX8 m 5v6 )o@v?6t),*I܎K_%ts+`bhgm'`vpv5z'̟u_u m,֦p,r;mfa ׬Hۚ,MCtA & [kw I'%2?Bq󿇖pV03%ch grbhcarwkM?hE@&v2Ӓ/fhafdGh(a4Qp26Zru[-o:5s c+ۿG5w<\6T3NjvRA&y+ ``cgsd/R_gyC' 7?u3]~u0 FϤ/3VA|AiN9Ób_{Y J A=a<5Ӽm?OehF{zyd4}\tLz%iQ? u85v&U_?Nw9\>a!bv4R&z깆ǧˎ3I:!Itr7pm0~zvSsӑYe7ijO7ڠ`bYS}c#%bs_,\kNep'!XC\:IԳz\Ctd=,3S- [em+uY/z11d{ܘ+GL«QA$W$R;cjV9?5qxcǒ3ohj6\.ϪH*D.g[4cZ1UFأE9 ճV-aᰧ-V16n*6>?q' ~ѝK +X_Av8H#(R.kݹ1ΊU/Jã}T%N҈W2ZqAy%ѝX!_-y2u)sh1,{ `OQ?HCfl@v]ZnF"tsSQ@(2f,c+Η.]66c 縑knnpl3ڠ#g\cp/3UPO *!K(~Wy\+ec°E;=ˢ5(;2p^ɛ[&ʏ+_ 0LPךu6ЄٽLH~sotZ8Gоq@Y,"r+kx|E2S|Jkg* ӱ_.XH "Zy rk$ aiɰ)tX Ǭ8ZcJPQb/ws=yz(xZ3~iǩ*΀-=.ɧܭνQiSj"oe[V+!4^' !7`*O.AQO($`ps"NxRFtx U&'UdyNV M'8VḒI #!aM5/_6 P+O[hۍs z_akbt&Hu'4w9 Uah1Awei 1iv Ndr MgH~!g/Xuj>t]pRAĵ ?jS}jFT%~akVheJ5X0uu@EaŜsS48O]=HÖSMRq6UHX&j&d_Id@923.8V84A B/izEɔFBή`봕nhEƥ0bkˁ牴m׿*499jgq'j #4S*]IxTEO,ZQɶJGz2Fnvw<GvZ lQTpvsg JjNOSy$hi c}޹b3=&hy^%SXV+:D̈YLE;q v!Q](dkEySy.ւܡ WԄIWyO@s!P~n?+k1ΟR IV1 5tk6~!-2bZ1WJ AK u5qpt> I^&E4BG!6{(ϊƹdMeZ} 1sڃ&P1UqΰEHRѬ BjO n#C~GeZBbV d<2Mx9vJR~c`rIB K;3!x5T)|숨lSPۣYJ vUUF2:s vkB1hV;[E4BS5#6M*ΟLb?'POTx)xi\R54(ГsmwYIԞa׏':;o67^ -eqBdj _iP v~ 8"sLJ KzU < H%,LlaԈDzN"jsY نԵyă-v-oѱ5lˡ>igg[fއ`ևQrhKуt+I";N,[e?㸄SIL )"M>RL`ȃn(Na<C,<-q-uc6/@:;įkrz֞OĶhf_陁\oӑ%ES]iӄ4.qץ?וoH  KBְT ;>H~)pKLәn3a|_%tgb^^1zL"в2.N:Jh`$y{%Pt7f)߂6ѪAT';v\ Ӆe!,-1aԣ D pY<y.LqpOČHG_PDGdWO,S .U41%l{UE_`7+uЇ&Qfphod19d8W>B&Tjgok  Kf+S~CE/iNr QAnξ^6R\Q#I#GYŜl:>CG*2Р=k _ɣg.߇+-Ml#]E|J*wR[QlOlur:FncZO3 &k‰Žw!7 _c*mrIcđ&UzgӉ%phq9;V¾)WBU Zvf(e uZ3]ecD\--.¸E @ٜ{òɒBf#,Wvt?D.>2ƶ]? M*Búq*/&46G!/ :߰!xsq9z"Ua+O$^_ۮʔFW`s$"-2ǐ8GtgWFYB^n# 5rLh=\W^gGXm|^ҝ'`Ҕ`e[c1w,ڒ=?3 ٤T>Fwfm\|,QŧHT[GuFxq&Qkg6*;X!jpRp7H Z5'-2B^O WrY%xC +7P?. Xm^Suկֿ0,p^|#Dk&.&RI EJO."H SnGeOjݾSsgEJ|􄱫r|x̗ sS ]fb!O"Dȭ`}#ᛡ TEW}I0P` IK,~k$! # ~nnI)6eAU6?IXI3y\GXFn2k`o HDj\k|"*eST~Pt[D+՟C_cYuUfv}#dMJ;`#ʥ'4$zk`6lq.i-%o* Sٺ?)tO &`m5$hq5_1tf-{dzx{ (nt%]>d*e-OxQ3 KwVhboGhfXSu^pD|8P _gHAiDc;zF|/n=_ S7xW:/J`BL[t%jg݂W%1Ʀ yk;Ɔ0| , +8t@>ө.1M@7ϤIxmܐ/‚y13ljΰ>D bd'$f/YK܅K<6ewz~L# Zf:*4Ϙw?WaPM<7\e}r)wz,Jp?㈺7 DQg>]eqƴ-@.=0~lv` yA nI&rJJH։ݔ'1 m>^Q+846.EǾ8>F5Ԡ[޺4"C[AGH`YHq⁻Z|dTWC3˧y dr~Ƅϰ>\fozumwSߺt&%uiۤfZ5z"=<Hq ͵)(sن}Ov cq5GB6LLA/Yȡ=:j›(V]E^ # MؑJh"(fq@qcp}MsN޹y֬yw%1fLAenX(=}aa 74;d |bcIdƸēeE#'E=u$q;_܅Qc`ǘ鐁F~WL_|7mIR@~h=ì 铤9 Ye- |4#J]uݰ?7J{m ?AOO_%¨$W&߫ &U[Peyl,0q0,7ۼxl~*lQ8uD>vǍ0\`Nb0TZ\J2Zw}ndWsrƎ6+9܍+F8",tNg,r8ûҥAYxݍ5jlZVm+nf,ive"Y43t/K]'5DTWlg?r%Ӑt SJ bOz!—b' /-HJnHgv^+{66'@_8%= r逽ńtm1I+sYJtW?/5gwNN|)}j  -2t# ā^IJ/'V|*aWޏ(˧$⣩ Y, (0;#/}-gLO wJ8jbҺ(6XWzWYI+mgˇ-Gy4x$7J}pF/;-RuA}eӶ`Af\T+dq :FE9buV^"5T׻R>Y_T3/? (3 cE]#Cxر6z#?%g?P LᾏLJrL>#1]w !IƮ ;h?vд{o˃W3u|eeO]`g\xJl._㷞L/IDo/~M[X_\a^ʐ& nswq(\Y!E{ꦻ%C YGϱ&0wsFwoahVX㾲؅/yZI%  O 㰔!d.WuҎ4EQboEU]מ]{0NR%/oZ W: k}{ff036FVK=ⵂYУVψ\D('u)K~'6x~86 uq gxYQpTC+:GNթV}Wh)3:(PV"H ;"m4 }Ң؃4`dNɇPܒ9I,zڪ/p怏AQQ"rKa`!M6-{J.?.RWEq"=L,sfy<X8Um[l u25AaRAA w=0"!9uK $A"?q}lVxJTF(^nl~9ovp {>eVk/l3eHޙ:i*Vf? h_>B"9'/5-3j ZA3!Dm]Aۉ>V:WNpCAՏ͒`O 3zW~?ѷ_ F Zb@ſx3 X0̽qqQÈp?U_"pmd%޹u\o@[)b]0/Y館%5 cԽЉU&9jЍp%DA:sU)ϤӕC_")a "ldDi P=~W{@Nd=j%n@L[.f\άO,f1I%a:NfR jn ]9Vj@չ~jw*N=q;␚}_B %gu˯[oHΩƼ -r ;TXiK{L7J4ixiɴrlmpN*nr7c 7^'a MQd3U=sg0F< tM؀TЩ񰖈k7l=8?lcWR$T[}*I>1"XTޱ.7 Qp &dHN6a6>Jϓ0;-ݩ.Cw~L1-\=ГHxxje#EkJ[抩͓ï:"wcxs~BHwO"|yXA^H XV}U[OOJ>["Co6'03ڬSAV}Pu)ēX neiqCsD_^o'O1z)2ӡD D1uJ"+*T@/{cߑ\x,M.XRT#z&o;^WTU*KY|r4*W0ɨUݧ\QdV_=ȡYd0:F̧V}WԾ{eNnXèOQ8Ofa5T=p!H bځxc CGIgqA1_'s5Do; o6+RyZn)V{*O_`^1&f!A{O }`R|3v2H>& w7Q[EqTP vo>qԗ~]0~S;hrwcdј1#2Fx)Z|^}A- +0 c:VX^ /2 dqGbUį_ ɚ$}vS.=z\`!uUr>Gd*^C-$fvFZb>mnHt`a7xZH ֣rReϊ/ JfdXڐ]?kRME4.$I+bk.F1[('ӪΌNˁ|Fp?F,+]6'"b 8)0'PFa)~-|3e]5WNW=sYfۄrj;0Rb-ir1ōԍ"wW0Iؤ47ă#H;;VE MU{M-bd2$~^ } mg.'^x3-~;ajP愫7 Ia /CY󩌩p8|i.ou%{ƽ.)-p1xjmꭖDRLjR~"ʫ996ҩR~i_<{̓u)s;X%ѦMuI*Xy fބƃ d(R5ЮyD%q% ҂ svWINOj(N>h-]8UB?W$A1T[ByqO;S(麃_@M7tTUJWY(v#9h ĵŅbx{FrpuMj lYS/}1+^qJ]3eR#e.LPWg4ƪĞ/S+FN.)H )LޖHOPb7ڡғyO{i>Ghn"KZ8 wK4cG"|@҄=G6:mn괐2d,fN)kCR7ʪg"_P=oiB㽰%Q(WT 3q❃rZu# M~RGŠ9(l!o2淤s&Oi'Ju6 㞐]KHPA4h oWYU'n]!KÍӷ*,-@ a$$-2{SQ:I2tW! ,O{{fpݕ"P}z@ 2h}Vp֟Q1K"]"rU$02$ s$LcJWin#5ȣoys̥M}%8-K\ Y/Lh[-hq4W;6]N` uSSpTEvV#8 p(D)Wxv5h8х'{m(5[ez,߈i`}Ҫ[M~TLKIVCVg|641=oY%ܐfq#{mT8N%\hA *Y&kŔ3q^qUAsډJz?69蕉{BgLJl=T!`ƎÛaCh O/<$og[,=kxF3~HR轕^WLkqasX*<\DEݢxHº`>?̒OgZ=_<ÊdT@)#鳑>D/ फ़ [S~ۗs{ 3Ӱ^ntY5107ǷI.YQ#6 J(B%jW*$<& -SLfDɪ]j^t rn!z@,kR}T;f(\lPR@Y` I0XesOs'x%spx|ނiInj|:03L9j+'&ATtکӚMM,>c2$V!?^j.DډjG4laXQ#~5?ƪ[? N ̺nyS$M\z0P28)nd 1c`WS[8CԴp4߃{/[$+]i8^yslDQ͎Y}ёdOFulMuMDqi~#б.J(IWBܜ:؞JY)n4Nm Ngnu|],Tt7~manvf0D(?n \dz+:EsFbnAmeNro:;Ue=D:ϥ JqV h'b#i'.CFuFJ.G66,jAc4XKSOՋ+<|]ԋ,E -i;5`+IhAhr j WVq\Jdr1Xff?yϼ<*QSNMP7. vJ ^!D\/vSJT&CN4cN/LhI-\k}q ;^8j1MM {*.T1' F`KZ|t!eKFE}|fSfgZՊN5ݖ q6~lѬExopub. ޼xPXa!q-۱wEKh1^8Z OMUv8K=Nz> stream xڭVg8-:KND6fØ3EE"{.Q"|#9s;w~\sw]/?* BbRJ!gv3D+a]<  ~~u,GQ<\ 8A:E89!sS aѿ,g.ϟ!pBO8q8 pFƖڀ9 G&=(Q80Fg \80p(1g(c8@',' PP Mp#`2c4b<@jN3 ڑ CC=Zh(@<8 CM `!PNU `N, 4O_`0H__^ )iBN( I͋. HI<0bp :aB`pG!OH g*D/H_"Oܿk//};iq# = v -7l +@ؿ{[FWE9*.یi!0c 8Be7GX$'n An9#3%( h|:`=i9& JM IJE9Y#/< ܕ:FEF ASO b bZ<8MB]RS4Jvan>GD+R:yʂlIo^nc /,a[|>u߭192+9LLm)8dy=ah/b_1V䯮 į||ղC޶.C r?q;cݫycUAivxSvce; eMml&iijYBvҢ*onScQU :F-tiiRz=Z_bKL2}usB1kwG]mϻ]7dG)|UC/W>8oZi:|HV=#}GOX|akxցRSMELsK1]lRG`ծD5xb/\Z{_SúT37T Xwz덕A>Vɓ9`d:0eT};k6ܨnTDut`:PS@0( p_2jŃ6)=J0}rVT9Z8XH. cVYE{X׿y Uԅ( 6to饵P4nҾ Xrx./1ob'˴ddludd$~ҩk UsnݳuԽ])C0{zSߴ4:w8J- a"RkϱίdxSʭGsVgAbF򭸚XؒǤ0 U5+v@58_2H61˅2 { 㾸"ǵ$}3m,<"PO67fJA#bˉA6/X ;ߌuθN|oCgݾcWtzuCs8k/Ó΀HP##)Cٲz;m"sL;J\V/<#I0V"3XsZ`i{uɕ8v8y6%aRǃG5+ 9:",L5~$eOkhXF`laMA&@F|f hvdok'K4ȓ$0f1U([coF[T@hpcs(mR="_6ɤ:ކϠi4`߰Ifـ:4m \%3L6j׭wMMD;Y* 3C]/d}4q*1 .warNrHkATtl C\RR-'a2d73ݝ$3E3S.BFm˛Dv h,]S)1,ow\I5&|=6m- i6`Ɋ7wzu5xr{*m;e<898f^ _h|:XۢlVW^xvH' |JoN Yksf{׋ɝ-$7P 5 ]DfH:Jzj6& ڨ'Xoͯ\ë(|(w]|ѢQvͷ *K{eVD*YȊʇ *#nXrM]EFy>COS72#vbgx%1h񻰉䩌6%B%P_f_ Ft'xG\9E])ӛ+#]%Zv4B'ݘ,4d/LǏPCr=޺^~6ɐJa_ twqy6(_6}Fi`a"1mIUi"=6yqw|:)nߥÒKJQ S,]8g\WmeŊj0kP ='H$^qHLbAj9mL0_RYY{۫od?քaOZ`wָ(}-L?g`Ʊ;-A ڴehBGYkD';-M )m~fKA~=)k2P6Ϥ(Ϸ%`Dɦ_7GL"9jy ޛRGr"+X584?zT|\Pt ĺ.ƺ$.O!L o }9P$"jE:]ܠl兮͂u1M"T~ {Ð-d{Urwұ<Ưm܏9*az?WH1 JOF`{8Eco;w<.tnml|*5}W͸}VKؙ{D"vmul嬽5l[y+JFx-DBR" |suP^і)AѫC,6Qd`b&6z̼ձW)_ .%z l:Ȟ\kz:T\O,R?o{"V\XCzk+f& bHwj~g[! E/rGr]N[YISS{Z F`cBvLSֲHﻘ,"O0ZF])x{QEٔ~J0A% rjU?, k,TFk|JvV5p38J1֥o\֝cH:}\%M)^VQ= h'!\z@ƫVizqIJ郔y; bWOK\r?wr` (1e\ƶECVK_A <^uU ὜k%"b\@X8iOgւ8r&KϋIJ|z_Oˉ40FA&:'>HSI8y[D1ň8}UMshz2=!#wbώZ-̋M65[ZGuF_-^b6nDʲG@ԒWυjNEV޼ι'o}; <{ijjsO%OGi/g|oz+_moZS#ᆌcq'=.ES^n绞!-7 p'\'+?i~!75OR1鈈))Y)Pr,iA9Һ/i g9 )i"Gםv x筛J'hH8B7XyKtzr w}S;2C?ϛ&zgH\ţ[+ ~AYT}).Es3/ܥǎmQhuDER2Qr:41S+iaL,WqOz5q$S%'t&FR cS= Eѻގ EK\GS/L2Wibϝ>R5beGKAMP^,rEaIl?_wXzj68Na\I,-cd(+h~|ޔbkIrнG{~gO8$d͑hǓ._.̬qRթ@sQwE~tVgJƺSy/&Xk6kS@ '\܉ Yվ8!* j _UpYU9qB iwj ii rO:* lا/Oi_*I/Wg3Kx6\h>U)E)\UU^5p0uXD9(Co$U/]=NJ6ȕbn0m3 Bwja D%nލh(?s4䳪u;eN>硡qkfiGWTTLr>WRg~>cIw zI;e/4/o0;i$j*Fþa8@ܨ}OۋغG ZK6х4?|)R?IQx ydffjɋEk7 7qһ|F*)=:X!K?ݯ728AQvB0T%+0;kH@>2y.dҗ`"߫cbiޗ1ȰSB6).H;)Ha}*bfAMs7a}ĄYғ|+y=E7ڑu/;4bwc؋_H;z~? endstream endobj 349 0 obj << /Length1 1630 /Length2 18911 /Length3 0 /Length 19744 /Filter /FlateDecode >> stream xڬctem&vvTm۶UmvRmRTlVӧt{uO\׼kMAJ/l41ڻ330L\Uv @n9zsKW_9;^Ŝin37(@O'+.*uMjZZc0_Og+K{n@;s{׎ +[s$JRA inodl Pr52Y;S,N@{3Jsf% 08;Zu305wGEp0wrv rX:ۻ `eojjO%kaWL ldUILy|7v'_5h hOIu1w{`f`k7_0'leo-l͝;Y'_Y\m-Y4uY-7suӿDPM ho 03cT c῏[or_pU0;1Kw,[cZk;߶[B+g +s3%+ cۿ=\/j+Ծ[CUft+F5e9u ͂ApQtFh?=\z.oB,lbϳ@oL_`MfiԦNNI[5pk@SLzI1~fP&⢀Z`F.w{](C4gҙoñ~,[ʾ4B_2"ԭo]Ae1׋r;:L{*P]N0܊0ȟL1QAK>D9H-o|ڼxX ^cl3O#&OW7N꥜6Zduw/eWbǸ]tKV"/a&exY08$:q5eUF U8+e bOT *!lD3) &.LemhNm}=A F3ǃͲ{0MR 岰q ~l:H&u#t'zU9"i}Q)ـk6oniaQ6H q#h2@ -lOej`]:8υQv`&{rSТo``)U(`}ܲ k0z>B\[SAJ26gܠr6،jAM (Wxyl?(O(4cxe}hj$ȪFKrjP C=5P<0XAZ(b—Ś5QVf*8!yBP`f ~uOI5/bY =b=7,ia.Q j A)ʅW䯆,*tP"-dgq1`UrO͘7aV-O>XeϦ.j蘡U3FT(ifM9?r1hblI"&~C|rRO񚦮)OU%װ3srlv~ƿKgNR;b2ol6e&[fgeM[34 ǎ`6ysUѴTw:xaEW{,:^}/bɪ6v'! -b6; B|C%m+p: Ph- 'j Ixİcq >`;߹ X{U+cz_+[;s3'-=WBA36^.7ߵ6Lyc39GUߦޣSR:44x 5V<5 #i|e뿠Z&8ѕtbWᦚ<4&N ܱW󿓀2' YM]!xRQ\Tʛ!ÃI fF<}<לTj-,iIAþ)yjg9Nౡ7C㖦0O3q鎑?2:1Nǰ1'}2nM68͈kv<@CZDRYBbXQ"IK86`#+؟$/mBˌСcjb'uؓW 1\/,y(ڔ`B7c_|ݭ0Ț} jf3,'PuDäSL<=x:ky[6;I q92"~K\q>@)l(&bGꘓl1kdS]֕ qT|nI粇ԚG_G2*M mo\fiVevL7kEī!R!q>PWlYqk_D^ñ!ΰ|8[&gy(*M%\xjM\~ -8%8ʅ޵i b]aϘAcּoY@RCԳx!]Ek\픮zq[8-9[C ~u1Dꏻe餂u~c^?̓Y>H b}Ek"6r!ʠ ߸-L"->ZɞDD1.“gp Xr";ذ3UiQɶJ)CI|l >*'9om;lvD]Oi/{ݖ4[ u!۞♤#zW}P3o MQ^3ƤitO WF;G$;iļWB_3KClmZ?D8~bn,aV c78"BQ}cݰMՁf:60S5-6)9Z"O0m H_a:],KNO?;Yhwa⴫o|0ci@(~"3*:, gkyFFjǬ'Ѓ5l'w{JKNdi?7fAGUD'܃:8)+.^jPKa2ռZ9ӮHczԛE޻(z!Hxspq-ZK]\԰itEn>X1`aI,7Czg'=(,ڵoNZe؋?w,B69#  Wt[#0;D5|$Wޢ޹@nD,mdȜ2<], zlͩo@xi|fE;K:WYLӍ% & w6>wI0Ca7'#0E~T+%~ߧ&]jXlKDCU蔄h0CX:E[h}%oq;7'*RoY8}a sZ`| .<)Ju2%a.dR2l6  dr').UF(E^5Pݳ_ @{ ŘG{;p6NlE; h{3D!tdzge9{skds1²%^><B^Rrڄ7Dq(ސeG5t"w'5Y~(cDxrE\0d"nd1u8r)i c#E9_^ G]0O@R/L`#m#,cx۷E+|Jy6;s]Gxcwa'!/\$.ArZ)&| 0;ȖX-!J7/DZ[9"-_ pur1e5Qs^E` f*CҘi{]k͡<%V VOxvUEGl3,촪.0B;mP†I3K#{-OtWtN Ñ$>xզR`ÝEѧWd/_*=4{0нY+'FS:*Sc.i-䬲k4b6{\Zް,bG1'ϠN!?xBB0RWО?3 <Σ~lB0-64%խO.jwe߆DyfR5z پ(+%L< raYMh9сŘ퓓m`f=r։QE5oHJRb˂aDIK 5 YxW$s]ߍbF bW@W"g^pQ3)7D2S5;skaX\N{xn^rp{ZKuبqMCshS(ӊ}jvJ ߛ$ ľ:0M)5p>s8~:~:}jEHwOIC0)gP2%m~uJ@ʴJl`sC i_@U I ۰@y'a|ąBݩ_]SPoiaZMu/*hVʉyσJ4k;뷫y<1è ['Au`XrATY_+ri\;,f~kqzj$HxugX h2$*^K fm/CN i48qMzPa) 'Q|0CUY`igq.IM{''OCD)utƫY2(qW_!sO["אHjehXɷt)Juʯ%kKۮ}郍?n;+~E1JSz Qs jktb;EH\zbyL9ۖ3YEX{l_MG| tClUģN"!ەUcؐ0G2>NT2]eÄ`8[pYr@N-Տ"P}p:w U ΂\$TrrP8vt=Y#:T/4m2n2QsJ|M3@8Of,Դ΂!M>I7sOAk'+= 덥ѡVޅXh4!4F:ћ%^H>+?e'Xu+..Vln)dGzB6Cs7Ih͖f0FD8(Jf S1wGŏ 8)>y7yv$!$8=w ͒GiީpUs=Fh$r?17b7|ŲRseA`RY&nFD3/B(0|uV &wg;z?sOdio/1ȽygH(I4s~._lJr'>uӕSD^-MSj:Z^T߶F[+J(ߓQINN ht0oV/ ζ9urWB2uXy>ŒVrCxF%>j4#t =+_dn槊diPt{$@u?4dav %^CӫpҢTR=4+]\FAPUCZ6o|h #+}d}:îoe]pɎ/f|q@'U̶[ZJufH' rk45 K#A )FzLWj9#|j.}$].$+xP i :7P'-?:N`]ݰg[(YMenĄ3o8_Il@;^WDŽxmdρ:a e6ZªtYNOk-Dj7rhBD` X2e:=<6k>y rH5Zj?|j1DV)o[%,o% 0KtDQd!C(nXiMJmEf i+τ:0B 8K§-ѺTPc6+(={;}$@?GWT[x;XagIdCvtܟBOoq3;uI_Hx|7˟]$J(6UimTsC`сc PQW1ȨW._!hp~N9ҿ;>O.53^6c{\iwp؉4d0# ,Ve ">ZgVJgA-BȯPZhj߂a–_IwQRzT糭89ƹ}k ~>Ah# Dqq?\LUnUv+5MDud<γ?zYKۓ{2#b v<)Ykϒ>"ې{g$[>:یPt>ƥѴOG=9`+&OҬlQ/k0 s4{@76xScH,r)^wZnM]=nT& u,T3:W@?0[ mz>&̧IGZ9!h(L 𬯺QxJ@Y Q=hPV">qEA&6ZGlӍy@V81:")KrЮazc4 <> Ы y] H ^ދ=|Q|[ ©)WNC/`NRgK{a.:=/3fsSii} $ |朊,}Tq ٦4\R`,1+үyH؇6qُ\{1Φ/}ee,i5[ 3(ƕaЈ_"t1Zg eU|qqs+bJkJoV?F??;@ rBU*_=ZxV^θ5n])yվϟf!RB wՁR[g*1KGYY)lY( ZᝮP=%V`hA|3kFHt 2(>V; ,K#BVOQ:ܝLy?$tJVmc>(K7 P?m$SXع3*c Nӥ5"uɈ;?٠ߘq-ZqRX`}N΀:~LWTtF% e5i 7nvXOi&h]vEJ$S|P'M!kp PB(ˎl[Wm:J*;,=XEVd=2K"ކfvL##+DF?YH[B]ӣTKb"a z=Zy )(!1zt;X.%z|N"Mu[_gKqK_ &pvi" =b]q;Z QC=NP.klo\eZHTE,#DL٢, C;C0 D`e [KIՂe'NW̋5i/?be~j.RX) ![)0( gt?86A ~$"td )X[#57=@QJ 'V=2:Y!:aNIyаfa$hۺ8d0$BY_kKd`(<}.ɓU>|y8ZΈn^CKosCp# lG>8/+7umkm i&of @~]A'ЦQI^ WuG욡w~kjR"哔4vs_7^Yoc`B'bP;T І\imHIc f3 XRgPkJ8zD16V oSNT M `R-99EĴ$]U6%dKٻexHP:[洂_g=O70]\UwHW/Cãj gJWF ?͘ گr'\d[UO `ߛ)~'8+.bѦ#R=E)S2RΡ 4Ⱥ1h1n\\^=e5w)y07*FBZt]mS4w{귣d.͖M3Sٺ|[4PdMğ9w_h p&ywfqn^d,a  MNޫ79aFܢǐYb+؞p%_B^ۆTiu/X2`ώL*VXU?}xzq*'~7i]eXU Iύ`3e|Aɑ~bmX14Fjx;̷<9oTQN!5(,{׷)[@u M*KkQpUqBhZ4:$5*nؠa3vz]\[\U/tS",jA}jzhN6=w$=(wiBw!oYq ʐǻߴhH_P]ad]`Ў[w(ZZ H4~*YӶv $X s82M QڢUSڅ6ڋSisV3y\MY SGAZ <&~)=2jRYŊ>'`AɍytQv/̓m}:2ؤҧoM+s]u*.bw1z}ג%C~K1AY(J8"fGGM?UxV}Ƣ/:UM&wVZ;WhE% ]kouܣ:פo"є{wj S{`Y/ 4=p9Q|ӂ6&,q TGkLBY{-Qxgߔ呯n9ڥ KCGd4~۫"'ٲDԝ߇ 70p Z|'l y7cީ B$=1hN6vx~Q2m)"{fpg*ʐE7BŤ+fntJIG#̾QJZN9'wc[JSHewʰ(;n{3tu>0YžH6hmw!NΈ'']eTr_]X(h']Sң5Pbֲ0$U,_h;U` Zgpȿ1h\#ߨS;IOb'5)`f!Q cYHR@D$)gP\E=]:*I2ky&q?FKx\4_p"lʹz/ 8S5UiY. ${^ǹ>*la}a6o/jlN])爆1_G0hcPE:t%DA߹]rU2F\9FtЂV˟nƏ<4N2g-R o}X~y?DYh6<8nՂ%blxX NS,{"]Hv.NPK݇Ny 3: `oU}Kq#]$p2|ilD!Ԥ."& ݖ˻tX'4FH}][V||72Pq/|=DEOX][ZzxhzQ,'X6Q s(&|굃!k;hKľLrCUílX=W 5h}2DH=vġ-F8mFBc}تj(Y f$uP7r(lcucV>$y"t2X\)շE.NJo%dKS_}y lcj/q:,* !˻gO NUǰZڌ(<\lvt 6&FSJd!kӐqGxpx8골 C0ՇMVs٦Vh/GV=~D$v SAUy58 %7) Fv| [wQe_Sv´cgY[O=4ܞ i>,N[F%҃<~:Y]^+d2a*o0DqI~}3Rn= B[LlTF5`dsU@vh”i$}ş* ؗy1lIlKT47fHJCGxi\+*sj6= O 5lQv^> %~2(Ҍ0S7)8AΏ?AѤOPk|ov'fiuΊBlH])q0iNvL; Va94iL27籘{9Yuou&NyEw7D qӣWRl|\BzPs8@&v5)Z͍n7HGcSp܃{D=B]RQLWTej-d9eCQ 2Ƿb{ P8+\xk},78u3ŊCM}mx8⑏tȺqS-:OK dR2y;BfD+/r{U m[bӟӽ}*v|Q)gv*1H8gp\ ;_l#О'CJXYg#\BBWڻ&ì0dIJ,90T{T1d 4SWڑ@39u(̎} SG?MS /";v:,KJ䜜QlmXUQ"x7,W~ A Yȓb=ipO`t#ItA\r.`a2T- tYV Sv@DԉY^_߹c,4#k3xor,2O J z8QPૼhWIG3qnWR6LK.6"&EcIqZ+eJaYd09oP(ۨj7/ Ԃ }V]U{ 0G*y[??6|6x5& }\(hO( Ga`i(@hf$xkkh%ݦz^`B6t|='8ܫTٌEL ikmSB\U1vQ<\Y؈֛0:@QVw< n=+lbbc-Lqe`a|GE2K$S/":,ЀA%"ND&nڬ (=z>^MbA^^8 g%1/҇*Ij`k2q0N5]9+fI^`ވ'pE\6P-|ں_l:7CyF.x%Ȧ`̀\p`} \eKQ(5F.D+ ,idJ(^H5CZc[Bo77ĜMTf)1d*{IsP 89cЗg؂AP,P=U샥4E4Mq`ϥZ';IsH$HU6cy(^5^t! $eWΥ ZOh :C#3pE Mĉg\jjh?!t+FVso42?MfҚ/ag N{m\,qGqAk 88r=ID(9D 6$ڼqwȀwڪz5J㆔{Oi6U؄y5Fu=Yr/"^'Ym פ<&bVc!y"Lh{y2QJvړ|@uAF7 -U ;U:c*v.GTGx;'U+ƿaA.y $u_= ^]Fh޴3:iW+ܣ~ ̇U}SlMLxȟw~e{i//ޅKfFڈ'< w=ղ'G=fK㎕)Ѷxd}`Dj0\9O\'9uBk[h 0y9|qk}PHzW(x=#SSÑW וHst1cې7&SkqOa֝J\V(=L_UxI\s NkI78Dhm6W~“eQ{"}Qл9sKN1 xs.$q"ȴC˽S9{{o&Al\^"1 ߅[#C`eniWp~B*#%Ta; R"<:=CB ?ZĤD); #*Ri[5.\k0t U]JWC ĤӶ~1A0͢2pp  ۘwglŦusLl*XS/wcw;|Y.t*&6m+ZN-W٪؜֒25r!cՙ b CW*ڸF-4T$t+=z" oN^XӰEڢǻ`A,lZ68`iK os"P@Pu^{*šy!7ct0ZBbF{sx+?K^ho a>3scy>??N/2!>:4Rt7q A @J"OQ=e6q2'ɢΫ^54Xf{>Ƌ,뿋,ZiQ~|ݝ7O:=z%ebaMKEBJꍕƞڷIcwC};0㫶}٦+s豼>jF+h_ζŸxh67kQN5bڗ& +^hR" XW3ǐ:sk-j@D`0z[t@Z\#T)f0লBE?llRR TI&$Tp IlGu%KJ(^gTܕVd$ֽEƛ^f^KFy2jv/?hDbe"*])x%oUսx7t eZȎP#v1ys&"xXfvu ,o}-Fe>Zm9S~ޱWф3cS^: 07ˮ^ g)(vw ;G`$c.aŃ5n mlu"O'5S`g7`atPr F(?6gc&ȟ+%i|2K3d qZTNT&O@A)7h\Z5Z8r,%ƱP3hgR$f pxî6x@9e-o3 Ck:w7WtBmjqkS30I,ZI>l|"Xa{ rs&|~8vݭ7qyŖ֧a,~k|m8-=ʊܠ5_d"Da @i?y71}]d/&ei5{ 4]?U|~:%rӕ6A46A&T}j%ƒԋ.vu4󨩻ܸҖh9:b1x uPNM`셩Q4 674Yרݍ:EocY4T~;mAgzOZFgQ )Eyކ7BG @$-1=}à!TIwpO &hl}SL,:6o+pP Y C1rh)4>2}P\5eAJ&uͼˌF \p Jb( D@KzxRT`A v tX8"Gr{ʢAzl291]*^a>Zƭ1=0 帿)ɑkQ kRlfK"jДUAũӠ%җ3E,~> T7n.s3pg!Lw'^+# gNRJ[n .nDSXd*.V2AuA 5c-w r]$R14YpɰRՐdaƜ SPj蟦-&T?s #q/ZU0'TF-[IguȮqOVzA:sY>df/~ P@Vb;dz5f=jOŒmF endstream endobj 351 0 obj << /Length1 1647 /Length2 13507 /Length3 0 /Length 14363 /Filter /FlateDecode >> stream xڭteXݒ--hi!w Nw }gΜyνg~]jU^TIA$iof`ad(X8*1]@;ƁHA!-ā`/@d XY,<<<1{'Ks 0Z]E_\D#- {[   -@EAdrzoB gis68LL-j͙K8;L,@& z` 0wځl3q1w98ٿ{ؾcdJ`g'K0=?[v|f&.7N󎂁v0W.c2\-U= dt29;Ӽsu;_:8xm` v٘1"46Cdk^,8s9}A {@S{;) I@?SOW_O<Ԓ.66 @Ǟ/}-௅cim-m<w)Db``Ydd 6m/o).o_jpٙ{mvVz 4M;ߟ#+#D,:N]fFff?:_s ڙM\{wߏr \7 JLM@86WwoT=ׄ06Ny,;Pu?`Svp2hF{]mp2kmO(<Mu9_cs@5IDo-<>L<쾂%ˉC&&=nL^a]\P_\<ʧ~jk4Ҏ$6E6gIP4U쇫ۂþ5I("ȋP@Xmk*p̯i"S]NvI4U 1~&2.?AD}C7TjQS=>7K=1=Px機Ǿ)L ^Lc6.?kkE%P* z=곧)䗄d|lPbIlkźIp?w3Fu3![^Y@K-d=]Tjp|VL H.۳VE mƐLs=,~ YQ?&q\cLVlp427xc{+ݻL*xDJ"ȏu況Qpno[W*g!a,S )iR \3/p{/=cvb >CU\>o ػP\`kC0S$$X/^d=ӶJ]*FU|,6';x88gKwD/a<ߵ:AU?Q`?_j@F\;EiH;"*ʞ%+"?ٸ 4oiHKn X/cWNOHhNOds2;6b!9Bi6M|[fF|1 tXS,f4MnmGsߐ*pAD7OnS<niv3#qWf$cNѩ{?SDkX1ap\{a`}w+^B@CKB uT擮֯ZT-~JWOf͢{G Jiuā!WP6{ w(D7۷Xm1˱IzŸ`nW odL>uiKl@J)h)HDpП ކ ^83Q~aUӔ\mNt?0o\D~zi'}/:xO;G#f#4+M _Ls<:te^%Er.5Q)Oa",`J^pӉngrKL[Q(`Ph౐s(͒>uq7/wN'A7EaǍ_/&ku?'D)h\ĭ](cx5å5-Q͸ǭj R }/=ސ. :='췩b(M :Y#\EZ ɢ\xVʞZ:XM{kNZZ~8 Q!8k;pF)4p16'P~{8*t9 勳p"e, C k]pRȯ x&GMgK,9Ũ C#C_:)r.egwV3t#tiܧ+?y~E.eM̈́iɍuS8D_x&'fqJ]M{vN7ۖ2?nXdlīlaLpR|7f ͡c'?х~-cȽ;o %m(*H]Pyɟ fMd]|Z6(,MNVhsڨڶ[ ?b5FOJg'G$92MdC\! 3}`q+p!<׈!,s"bpB=z $mwEM)<⡍#p |xTcy @2 +% 9Hß"CU׍ sx9Vf\Xd-KCz-C-|qP UC}<ykЋVÖz>i Kq{-4fgXHL$bZ*A㨊Ƥ8j[!25~H^GUEѓ9*y6fÆ(x~ƱWR/yKwVB֐'c.udy{S?ta=NKmkU%tls<(1B@h08X$3ۺFxgB t+̣R4a 5҃e(;S!MՈ#aP.=`fnkPepK!vS ?@-ӱIK y'jl"B7`*aot)\V|A\Q ]-D.qxbYn B]ojb[_>xeԠv.*lwFعܽqIJk:}%=|II0nta~٩k|ovl0xo 0!n<:a+O[,#4~YTKAdG6(H:-.#?d=+uf48f#8]tw+˓2-YgcznQuSj ;I{v{H'\s9kcl{:;DH8ꮿj?®]ٛ^=!sHJ>BoΠS|>㞻N|Nlo|Br}w%^e*̓= bAw-dzek#"݀20}Š{~JK8%'vQ,pu?g_+ u;SZTSII23V7ȷLgG,ܤ6qH `h#r3e2:BJ$rgͺ1Ad߹d&c ju-eWS]VrXQC.# bzadF~5iZa*B>Z++_ qTwx਀Wڐp"%3眬NiUFr2=Ƴyf@Wt6+^k5X'_"@?Ԩ~!VcnsN\-2Y+qFv 7Jr4uF~'9=3Fny"x%Fu*(Ű`[vwK\ 0ߋ B8~o;s(;L%հlW~>ʟAwf8{n`/_T.bvįd[c:ly>U/N}$R KC[?6{:Ee'v|;i \?^2qS 8R0v  ܩ։갻\t,*3Va=EFD`,u+/<_m61ԞLĿ5r궵{x[ c] PFvsYwF^f ׈yE_?l!Z}/R{]Fy[άdW{l}uԱz+ص}J3x7!-Q;o"ADض`d3U "TsJUj%dwX. ~o#rcl`CNqoU\w[2hw DOC5( `? Q-gf5[}Wg$=Dr2 )Dן0J`$2GJQۛ? q k}}(Kisg)Jxvj=3R ouXC9>8LOһ̿2b5 +u3dCg|͵l}W cUCJTKu<қidH_Y}GIaXn始j2c*`%/ֺ꜁(?P8׸г#m1бmqߢILVrսwڔ~5 ;ToWS0#N zFhLeg1v(jyݥ"ޙZO֋1zA>![t2ީW4̼@d]1MM[gvIYib ڸX)_KgoLA>6PɃϑД̒e(o`=+ >^JV;a`,9QG~5TJn}xqX[E[0V^hP_`54wR^Krb„8eD)10-ʃo{E3{j%W=ys„CBadV/ߥw:w]1h@T h `,Mݪ65nR9Gkx;1ij~ D㺱zw4] /ƭK[]A[㛈^ù5)oǿ?.QD5im7m #w1-*kDm_D t}7*:Xp\|(\cIN;ęǸј7Bw%vt^+$0W;&:vuD17,/쁐${}ǩ}FX4"WuKuHU1.tv1 }6L+EBXCͮglQb7l'm%# h=FesrI^ ̵>fwpCF$j=hr{T;sgƁ͖?%3yb٪[ 9^V{qa^Y N"/-&e*ĿU'Ls^R%E6s+BT= b Y6͆7 n .^b|92Wڤe6עʈwW8d:9ן_0 J􏋒GdJ_l)N7e??U5[Pf~@VRG8y7 0~|!pULGu/o>Z+V[Vs ^d481WTZ)UvK#$=/^>Pmp/}I԰W =/,k 1E. =(]Kaphhp7<0RAr8ꯙxSGgqGYШ>|BGmT!Je$.. ڏZ1 m^_K2Tˣ:)N)NixZN5Yv.+O~U}ZfX;U]ˠc^CeUKfOOw3uEGڈ?פ Rs|ԻZ@k\}Ul>4GwZ) QBK-t.a0T)&dւf G7A<*9I9|6(QK쏖ƳΌUVMy'(шxDz.eZ \&6S]W-Q-/2aލ$ZVj'J:h u.fW$@4ȵTUl6FItsr+EMvLA}n/ѝH;r+XJQ+Eʃ& ,INF47_,pp~&PXI1.}-ʢӀ38j L#eEJ sXѦV䗈1"7AFYԀZ>Xq.,IIx)r7=1͇7h<ٸiR$z$?iLUןrfleusXEpYx_7k*0W3Qdh49sʓE2yr@]u=fS` >=bV릏m3CAz' ~6Duƭy!7%|FL؄$ݛju L8>iaGn,D ~1>ͭmƒmZ~U֭ia;G)楯[yG"ʬBD. xBqtVT/bkϙ,ȫiͽH S lz-,AP\O%f#iD3パ^JlaƸb9E̋JE"# =e0ɫBvMu3KkLLNf:,-;+|+_ !Ɓ7BdQ1'}K(r”\}h%n6tA(8xѢmm3AڣkwNMpsL`ms$=xX1.%U̒!1ݭ:&QH`7s8A^ oIGiɜ-&X[\a ꫄ʟQ".^O+1hK_E!AebVARˣQEf]x_tS9bOvGID۾:0d3VHvҐ h RMCg Q;SPdIMM4:^l$GETVp}d<$jH>$܌>PJ*6F;V<׺1'V\s2L+& g`R2FGs†iY L𮤾wozcNOx-hf׊]ݧtҕ2SHU}.ldC?]\ T ncZ4 p3ʀۛx6LܲDdK(d>3E.WSQ)^IFnӶfbiٮՙw@(9HG ThSJflف]i,3H >BC?priDGiE:5 *L[%B=SEZ(*hR3ZekWMCiJR?8kԨ)8XנQ4.fCa cduI2\ .ʥg7L"=ӝa띋֐qpM#u&k*=`NENr㑰2J d)]lPNSXM (ٌ8ȼ+>խa&j.eORpWuv@BfTaS;(n[Wo.UvtQk$1OqbHtH?b0Rр[4ġ(f{!hATTpNbo3'G<䟅Ө?Ы@ˆk&=HШݯ,wP̤Wdo=oOH 'k;Ⱳed~|I2K%>m`2;^mqˏ7I\kr"99|rqC"Ƀ}6}`ʠ wُyO+%9,ۜ+4U'r|tq̴Zr)HPȢg7ׯ>![S:VN_VC+#z3^2x_\.:c.v-]4,Mq}|MAx͓]&QM{]xYz DW )Iϔ{^0A,h6bLE<9VFz" 6edOoaÿ>ޞJUfϞ੅Yu_`7{tUOC. 4#&%a0 !_E˙Wm% fxw}#FM|;# x8W)PV4mfrm~Ib}IL՟p؆I[2`زm?/Ob"uv4Mڣ` $\zݟͫc B*pٵs59<\Hw{Y4±I 2}J&r@# 0UůRtk8񟇬R&|t)+fDrfQF`(m“%d8y]_S7F&AeY+Joaڵ/?p zJ%{ Z7,!?@&3XQ;O0? % 8ŞFc9kH}G(JEljxrGzVVPulEވҫ>'7^]G;R ;m<].OVZDl~mH!9:C&\.㟼{iᦓuN"ZaerFl 5GѺ V,^OdXY*2an`b֛m:;9 Y^b [8[i3+pN*6p>&=]b375w7`2lGJ]'_l9 <v|/ FϭsY&T 'gnLT x/:_mUGl@ FDrK㗭YM]];AZ_BAt.e `dϣRIm(-eCD)D!tUD۠pb+DCu<:HS]V<N(0ub 9:H_wKP+6,T/kk2g[mOL<،J3>a-EI؄nڛ̆@y(H%7.R/ZDbAL$&-i[4~.YJ7]VU:B+WHX 㜲2X7VZqUp[t n+{8!Bӯ)Ԇj n5a%_7e|U!pI࠻zI'HokՖЗ07*< 6i_g0^jVO#|:ȮZiwPznV(ƴ\fn\bB>FhLCGʓp47eF]gDJc]l+ h V0`Ǔ"иҼtt[=f6M2dqijȰwpe=4}iEUZ` ^q̧fA0-Nگ\\YȘ<2FAulPRB48XG! N){Ri8a ~n_˕GAvx?3·#E !C;7W^Iqǂ@AC҉͂9CW6LіwR#JB20u&þB BWN%A0I4\I,l; Ru7PV kI}%CtFaգ!} <;뻗j+Z`Dͥ Aeʇ%/:\5C(fvU̞ I К@Aj>dMu^r=Gh7$ a\\|d2ڻBDZ2߲9-̾tT-p9g>p'*QS|_բ%U0𽽡-G_gBW^gst$Ld/gGAUNKY0HjSP 9ϻ|TJVb`'&2'  ۏHI= O|9WpY\[Ι\4շ S ?o߻/<|tud^=Βr_܃V;/E= \K8IVct0(Ət(5B_BR0_뿽2鄳11 oM* Ω-0%K@&_zOVCݎb>}؝.$bqy.˯ @n>49(jn̨e+u53$ ].3šT,$">d-ЮE.Ml N;AS%B]bn*}M۸9n6MD6q]HxCu}/6jLLqy_ 9U=;ó,,c~D8oR/D_<։eq2d+J@u{`e}g`֨ԥ_7}${m!mdJ#,yJ):PGWE̮[γBߧk+zwN KZdsB[2Z:V'k9-rRi>>ֹח !(T}*IF_ޛNuM(jO|qAOn$",bLcd5}OL|_̸1ڴ;y |DSl\w]>ZP|`L/incHUL+ tK;b(%ր˥w55ꚈY}MAgGXB> endobj 324 0 obj << /Type /ObjStm /N 49 /First 415 /Length 2422 /Filter /FlateDecode >> stream xڭZYsH}ׯj TMMUxe+ޝ$,1A`Js{A$d!assnQĨDp1 wH' 8H_!{pD"2cH> aX0O Nn#ϑp$A8HHR$\# OD<l`Sl= )އ\:xG 0UOzr9אk)r]#\s>E OC9" OH/ z:R<_H|Gx. 0OJp3 3O=oޞCҤ,z.Ҭ/3Ϣ"zpN"JhAV.T$yW:#E,2&,ީ>=/V2<2٣Z8:UJR0r!JX[)r:.2P:V`^*yRpyκx.R|[wO^:zjOY/~V j$ &*뼪K+ԻE3B\(WYZ|wpr|e(ZT QXߗ2 Wo_M}bhmhuV$֩|==jJlC )Q:֝Hr@⺽۠ZQGM5Puz FbWgcj+b"v(]杏0oNe:GX i*H$ZwZC)o!ޒJ5Գ>SoKsBj+TdP2 sXiň9\JU.S)W(UlL*v[a}])h}+aѡ姅hBJCR%1e$ߋf#g[ 3fj'rB_Vڶ%Yev7EM=eR)Q5: *28|>, P=eVzäSQ兊 >*ѸHͯM'g~m;pZ-v;|HorETi~珏o.5XEd]Н :فVtwy]6-^wr$:.iwn9^s[vcsN7;λ7#|x%0!{Ml};yv\ӌDVMe׿yv6u/a_&QĽ%E~e7t֭u7#k;hZj.-QL|eMVl[y##l{o-ܴoM<ɏpjap6GE=VjG]g$aiRיZX8_j١.i 2 e}]m(́{m~i XۉَLgCX{G!- i1rB,Gdz};Q a즦Bd 8r{t`𚜨kjn,70v,n+};OT1KZ ;/Ե~/`vngçU5XAQʇِ3ԿK %mZ^mLQ{L ~1XM\4>: 7za jd endstream endobj 358 0 obj << /Type /XRef /Index [0 359] /Size 359 /W [1 3 1] /Root 356 0 R /Info 357 0 R /ID [<866874FDE9C2DD2296FBF5EB971B32E4> <866874FDE9C2DD2296FBF5EB971B32E4>] /Length 964 /Filter /FlateDecode >> stream x%YlUU{o<1ҖNЁNPh B:RJ 8E@yP|QCc$`L`LH$>1|Y}-,YJRJI)$2{ſU|ix ^-YEJR$ +]H4 I`.jo]E`mijn_Hed9YAJR =j62v%2I|Bd{#'Gy))nM \a RIH5ђRKZRO֑4-6uO@ZH+i#l$H'LIK:V{]|i=dtBCd;AzN솝->ۓjHO >jՒ2 \%elG>ՋZ2Fþ^v}ڃdsA =LuSdviؿjOjY #[9,nDk'ƪ3hоθx0t.0v"e9$~WmM'X p]NQBZΐ8C[/*Űsrƽ0({j9^̿TsS{5^\׷tN7rY-Ni]eʼ82ނyK-m+2ށ!>xoBk̛3/-a輋0=ރЩauf!R-2ދ0dgHA~GyH?‰D833>LGO?@ L"O& gg,›&(ʖCXj-Wu Cq:H‚wTDMOJCr䌪%H4UH^V䟍2 IUYH\Q5U9HQKIi&x۷k endstream endobj startxref 386276 %%EOF msm/tests/0000755000176200001440000000000012774212430012212 5ustar liggesusersmsm/tests/test_base.R0000755000176200001440000000004612357463053014317 0ustar liggesuserslibrary(testthat) test_check("msm") msm/tests/testthat/0000755000176200001440000000000012774212430014052 5ustar liggesusersmsm/tests/testthat/test_analyticp.r0000755000176200001440000006713512350247250017275 0ustar liggesuserscontext("analytic transition probability matrices") fixq <- function(Q){ diag(Q) <- 0; diag(Q) <- - rowSums(Q); Q } # avoid namespace faff nsubj <- 50; nobspt <- 6 sim.df <- data.frame(subject = rep(1:nsubj, each=nobspt), time = seq(0, 20, length=nobspt), x = rnorm(nsubj*nobspt), y = rnorm(nsubj*nobspt)* 5 + 2 ) set.seed(22061976) test_that("2 state analytic P matrices",{ (two.q <- fixq(rbind(c(0, exp(-2)), c(0, 0)))) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=two.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-3)), c(0, 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-3)), c(0, 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) ## 1,2 (two.q <- fixq(rbind(c(0, exp(-2)), c(exp(-2), 0)))) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=two.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-3)), c(exp(-1), 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-3)), c(exp(-1), 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) }) test_that("3 state analytic P matrices",{ ## 1,2 (three.q <- fixq(rbind(c(0, exp(-3), exp(-3)), c(0, 0, 0), c(0, 0, 0)))) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-1)), c(0, 0, 0), c(0, 0, 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-1)), c(0, 0, 0), c(0, 0, 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) ## 1,4 (three.q <- fixq(rbind(c(0, exp(-3), 0), c(0, 0, exp(-3)), c(0, 0, 0)))) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0), c(0, 0, exp(-1)), c(0, 0, 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0), c(0, 0, exp(-1)), c(0, 0, 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) # 4,5 (== 1,4) nsubj <- 500; nobspt <- 6 sim.df <- data.frame(subject = rep(1:nsubj, each=nobspt), time = seq(0, 20, length=nobspt), x = rnorm(nsubj*nobspt), y = rnorm(nsubj*nobspt)* 5 + 2 ) (three.q <- fixq(rbind(c(0, 0, 0), c(0, 0, exp(-2)), c(exp(-3), 0, 0)))) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, start=rep(2,500)) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, 0, 0), c(0, 0, exp(-3)), c(exp(-2), 0, 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, 0, 0), c(0, 0, exp(-3)), c(exp(-2), 0, 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) ## 1,6 (three.q <- fixq(rbind(c(0, exp(-3), 0), c(0, 0, 0), c(0, exp(-3), 0)))) nsubj <- 50; nobspt <- 6 sim.df <- data.frame(subject = rep(1:nsubj, each=nobspt), time = seq(0, 20, length=nobspt), x = rnorm(nsubj*nobspt), y = rnorm(nsubj*nobspt)* 5 + 2 ) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, start=c(rep(3,25),rep(1,25))) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0), c(0, 0, 0), c(0, exp(-1), 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0), c(0, 0, 0), c(0, exp(-1), 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) #1,2,4 (= 3,4,5) (three.q <- fixq(rbind(c(0, 0, 0), c(exp(-3), 0, exp(-3)), c(exp(-3), 0, 0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, start=rep(2, 50)) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, 0, 0), c(exp(-2), 0, exp(-2)), c(2*exp(-2), 0, 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, 0, 0), c(exp(-2), 0, exp(-2)), c(2*exp(-2), 0, 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) # 1,2,4 (three.q <- fixq(rbind(c(0, exp(-3), exp(-6)), c(0, 0, exp(-3)), c(0, 0, 0)))) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-2)), c(0, 0, exp(-1)), c(0, 0, 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-2)), c(0, 0, exp(-1)), c(0, 0, 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) # 1,2,4 (=1,2,6) (three.q <- fixq(rbind(c(0, exp(-3), exp(-6)), c(0, 0, 0), c(0, exp(-3), 0)))) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-2)), c(0, 0, 0), c(0, exp(-2), 0)), analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-2)), c(0, 0, 0), c(0, exp(-2), 0)), analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) #1,3,5 (= 2,4,5) (three.q <- fixq(rbind(c(0, 0, exp(-3)), c(0, 0, exp(-3)), c(exp(-3), 0, 0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, start=c(rep(1, 25), rep(2,25))) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, 0, exp(-1)), c(0, 0, exp(-1)), c(exp(-2), 0, 0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, 0, exp(-1)), c(0, 0, exp(-1)), c(exp(-2), 0, 0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) #1,2,4,6 (three.q <- fixq(rbind(c(0, exp(-3), exp(-3)), c(0, 0, exp(-3)), c(0, exp(-3), 0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, start=c(rep(1, 25), rep(2,25))) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-1)), c(0, 0, exp(-1)), c(0, exp(-2), 0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-1)), c(0, 0, exp(-1)), c(0, exp(-2), 0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-1)), c(0, 0, exp(-1)), c(0, exp(-1), 0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), exp(-1)), c(0, 0, exp(-1)), c(0, exp(-1), 0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) }) ## FOUR STATES #1,5,9 test_that("4 state analytic P matrices",{ (four.q <- fixq(rbind(c(0, exp(-3), 0, 0), c(0, 0, exp(-3), 0), c(0, 0, 0, exp(-3)), c(0,0,0,0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=four.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-1)), c(0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-1)), c(0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-2)), c(0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-2)), c(0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0, 0), c(0, 0, exp(-2), 0), c(0, 0, 0, exp(-1)), c(0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-1), 0, 0), c(0, 0, exp(-2), 0), c(0, 0, 0, exp(-1)), c(0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-1)), c(0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-1)), c(0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-3)), c(0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, 0), c(0, 0, exp(-1), 0), c(0, 0, 0, exp(-3)), c(0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) #13569 (four.q <- fixq(rbind(c(0, exp(-3), 0, exp(-3)), c(0, 0, exp(-3), exp(-3)), c(0, 0, 0, exp(-3)), c(0,0,0,0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=four.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-2), exp(-2)), c(0, 0, 0, 2*exp(-2)), c(0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-2), exp(-2)), c(0, 0, 0, 2*exp(-2)), c(0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik, tol=1e-06) ## no convergence with analytic, in 1.2 or 1.3, but matches with fixed (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-2), exp(-2)), c(0, 0, 0, exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-2), exp(-2)), c(0, 0, 0, exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-3), exp(-3)), c(0, 0, 0, 2*exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-3), exp(-3)), c(0, 0, 0, 2*exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-3), 0, exp(-3)), c(0, 0, exp(-2), exp(-2)), c(0, 0, 0, 2*exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-3), 0, exp(-3)), c(0, 0, exp(-2), exp(-2)), c(0, 0, 0, 2*exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-3), exp(-3)), c(0, 0, 0, exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0, exp(-2), 0, exp(-2)), c(0, 0, exp(-3), exp(-3)), c(0, 0, 0, exp(-2)), c(0,0,0,0)), fixedpars=FALSE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) }) ## FIVE STATES #1_6_11_16 test_that("5 state analytic P matrices",{ (five.q <- fixq(rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=five.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-4),0), c(0,0,0,0,exp(-5)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-4),0), c(0,0,0,0,exp(-5)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-3),0), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-3),0), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-4),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-4),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-4),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-4),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-4),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-4),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-3)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-3)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-3),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-3),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),0,0), c(0,0,0,exp(-2),0), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) #1_4_6_8_11_12_16 (five.q <- fixq(rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,exp(-2)), c(0,0,0,0,0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=five.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,exp(-5)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,exp(-5)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-3),exp(-3)), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-3),exp(-3)), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,exp(-4)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-4),0,exp(-4)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-4),0,exp(-4)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,exp(-3)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,exp(-3)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-3),exp(-3)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-3),exp(-3)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-3),0,exp(-3)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,exp(-3)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,exp(-2)), c(0,0,exp(-2),0,exp(-2)), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,2*exp(-2)), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) #1_6_7_11_12 (five.q <- fixq(rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),exp(-2),0), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,0), c(0,0,0,0,0)))) set.seed(22061976) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=five.q) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),exp(-3),0), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-3),exp(-3),0), c(0,0,0,exp(-4),exp(-4)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,2*exp(-2),0,0,0), c(0,0,exp(-2),exp(-2),0), c(0,0,0,exp(-3),exp(-3)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,2*exp(-2),0,0,0), c(0,0,exp(-2),exp(-2),0), c(0,0,0,exp(-3),exp(-3)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,2*exp(-2),0,0,0), c(0,0,exp(-3),exp(-3),0), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,2*exp(-2),0,0,0), c(0,0,exp(-3),exp(-3),0), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),exp(-2),0), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-3),0,0,0), c(0,0,exp(-2),exp(-2),0), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) (sim.mod1 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),exp(-2),0), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=TRUE)) (sim.mod2 <- msm(state ~ time, subject=subject, data=sim2.df, qmatrix = rbind(c(0,exp(-2),0,0,0), c(0,0,exp(-2),exp(-2),0), c(0,0,0,exp(-2),exp(-2)), c(0,0,0,0,0), c(0,0,0,0,0)), fixedpars=TRUE, analyticp=FALSE)) expect_equal(sim.mod1$minus2loglik, sim.mod2$minus2loglik) }) msm/tests/testthat/test_models_hmmmulti.r0000755000176200001440000000764112670000012020470 0ustar liggesuserscontext("HMMs with multivariate responses") ## Simulate data from a Markov model nsubj <- 30; nobspt <- 5 sim.df <- data.frame(subject = rep(1:nsubj, each=nobspt), time = seq(0, 20, length=nobspt)) set.seed(1) two.q <- rbind(c(-0.1, 0.1), c(0, 0)) dat <- simmulti.msm(sim.df[,1:2], qmatrix=two.q, drop.absorb=FALSE) ## Bin(40, 0.1) for state 1, Bin(40, 0.5) for state 2 dat$obs1 <- dat$obs2 <- NA set.seed(1) dat$obs1[dat$state==1] <- rbinom(sum(dat$state==1), 40, 0.1) dat$obs2[dat$state==1] <- rbinom(sum(dat$state==1), 40, 0.1) dat$obs1[dat$state==2] <- rbinom(sum(dat$state==2), 40, 0.5) dat$obs2[dat$state==2] <- rbinom(sum(dat$state==2), 40, 0.5) dat$obs <- cbind(obs1 = dat$obs1, obs2 = dat$obs2) dat$dobs1 <- dat$dobs2 <- NA set.seed(1) ## Bin(40, 0.1) and Bin(40, 0.2) for state 1, dat$dobs1[dat$state==1] <- rbinom(sum(dat$state==1), 40, 0.1) dat$dobs2[dat$state==1] <- rbinom(sum(dat$state==1), 40, 0.2) ## Bin(40, 0.5) and Bin(40, 0.6) for state 2 dat$dobs1[dat$state==2] <- rbinom(sum(dat$state==2), 40, 0.6) dat$dobs2[dat$state==2] <- rbinom(sum(dat$state==2), 40, 0.5) dat$dobs <- cbind(dobs1 = dat$dobs1, dobs2 = dat$dobs2) options(msm.test.analytic.derivatives=TRUE) err <- 1e-04 test_that("HMMs with multiple responses from the same distribution",{ hmm <- msm(obs ~ time, subject=subject, data=dat, qmatrix=two.q, hmodel = list(hmmBinom(size=40, prob=0.2), hmmBinom(size=40, prob=0.2)), fixedpars=TRUE) expect_equal(hmm$minus2loglik, 4387.58552977954, tol=1e-06) expect_lt(deriv_error(hmm), err) }) test_that("HMMs with multiple responses from different distributions",{ hmm <- msm(dobs ~ time, subject=subject, data=dat, qmatrix=two.q, hmodel = list(hmmMV(hmmBinom(size=40, prob=0.3), hmmBinom(size=40, prob=0.3)), hmmMV(hmmBinom(size=40, prob=0.3), hmmBinom(size=40, prob=0.3))), fixedpars=TRUE) expect_equal(hmm$minus2loglik, 3767.11569380418, tol=1e-06) expect_lt(deriv_error(hmm), err) }) test_that("HMMs with multiple responses from different distributions: non-default initprobs, different probs",{ hmm <- msm(dobs ~ time, subject=subject, data=dat, qmatrix=two.q, initprobs=c(0.6, 0.4), hmodel = list(hmmMV(hmmBinom(size=40, prob=0.3), hmmBinom(size=40, prob=0.3)), hmmMV(hmmBinom(size=40, prob=0.4), hmmBinom(size=40, prob=0.4))), fixedpars=TRUE) expect_lt(deriv_error(hmm), err) }) dat$dobsmiss <- dat$dobs dat$dobsmiss[1:10,2] <- NA test_that("HMMs with multiple responses from different distributions: missing data",{ hmm <- msm(dobsmiss ~ time, subject=subject, data=dat, qmatrix=two.q, hmodel = list(hmmMV(hmmBinom(size=40, prob=0.3), hmmBinom(size=40, prob=0.3)), hmmMV(hmmBinom(size=40, prob=0.3), hmmBinom(size=40, prob=0.3))), fixedpars=TRUE) expect_lt(deriv_error(hmm), err) }) ## not tested: different number of models by design for different obs dat$obstrue <- NA obstimes <- seq(2, 147, by=5) # times when true state is known dat$obstrue[obstimes] <- dat$state[obstimes] test_that("HMMs with multiple responses: true state known sometimes",{ hmm <- msm(dobs ~ time, subject=subject, data=dat, qmatrix=two.q, obstrue=obstrue, hmodel = list(hmmMV(hmmBinom(size=40, prob=0.3), hmmBinom(size=40, prob=0.3)), hmmMV(hmmBinom(size=40, prob=0.3), hmmBinom(size=40, prob=0.3))), fixedpars=TRUE) expect_equal(hmm$minus2loglik, 3804.03972787726, tol=1e-06) expect_lt(deriv_error(hmm), err) }) ## analytic derivatives options(msm.test.analytic.derivatives=NULL) ## censoring? msm/tests/testthat/test_utils.r0000755000176200001440000001341712724255727016460 0ustar liggesuserscontext("Distribution functions and utilities") test_that("MatrixExp",{ A <- matrix(c(-0.11, 0.01, 0.001, 0.2, -0.2, 0, 0, 0, 0), nrow=3, byrow=TRUE) me <- MatrixExp(A, method="pade") res <- c(0.896703832431769, 0.171397960992687, 0, 0.00856989804963433, 0.81957474998506, 0, 0.00094726269518597, 9.0272890222537e-05, 1) expect_equal(res, as.numeric(me), tol=1e-06) me <- MatrixExp(A, method="series") expect_equal(res, as.numeric(me), tol=1e-06) ev <- eigen(A) me2 <- ev$vectors %*% diag(exp(ev$values)) %*% solve(ev$vectors) expect_equal(me2, me, tol=1e-06) }) test_that("truncated normal",{ set.seed(220676) rl <- rnorm(10) expect_equal(dtnorm(rl), dnorm(rl), tol=1e-06) expect_equal(dtnorm(rl, mean=2, sd=1.2), dnorm(rl, mean=2, sd=1.2), tol=1e-06) d <- dtnorm(rl, mean=2, sd=1.2, lower=seq(-4,5)) expect_equal(c(0.260110259383406, 0.108097895222820, 0.0558659556833655, 0.160829438765247, 0.343919966894772, 0, 0, 0, 0, 0), d, tol=1e-06) expect_equal(c(0, 0.5, 1), ptnorm(c(-1000, 0, 1000)), tol=1e-06) expect_equal(c(0.139068959153926, 0, 0.156451685781240), ptnorm(c(-1, 0, 1), mean=c(0,1,2), sd=c(1,2,3), lower=c(-2,1,0)), tol=1e-06) expect_equal(rl, qtnorm(ptnorm(rl)), tol=1e-03) expect_warning(qtnorm(c(-1, 0, 1, 2)), "NaN") expect_warning(qtnorm(c(-1, 0, 1, 2),lower=-1,upper=1), "NaN") expect_equal(rl, qtnorm(ptnorm(rl, mean=1:10), mean=1:10)) }) test_that("Measurement error distributions: normal",{ expect_equal(dnorm(2), dmenorm(2), tol=1e-06) expect_equal(dnorm(2, log=TRUE), dmenorm(2, log=TRUE), tol=1e-06) expect_equal(c(0.0539909665131881, 0.241970724519143, 0.398942280401433), dmenorm(c(-2, 0, 2), mean=c(0,1,2)), tol=1e-06) expect_equal(c(0.119536494085260, 0.120031723608082, 0.0967922982964366), dmenorm(c(-2, 0, 2), mean=c(0,1,2), lower=c(-3,-2,-1), sderr=c(2,3,4)), tol=1e-06) expect_equal(pmenorm(c(-2, 0, 2)), pnorm(c(-2, 0, 2)), tol=1e-06) expect_equal(pmenorm(c(-2, 0, 2), log.p=TRUE), pnorm(c(-2, 0, 2), log.p=TRUE), tol=1e-06) expect_equal(pmenorm(c(-2, 0, 2), lower.tail=FALSE), pnorm(c(-2, 0, 2), lower.tail=FALSE), tol=1e-06) expect_equal(c(0.347443301205908, 0.500000000140865, 0.652556698813763), pmenorm(c(-2, 0, 2), sderr=5), tol=1e-06) expect_equal(c(0.00930146266876999, 0.0249300921973760, 0.0583322325986182), pmenorm(c(-2, 0, 2), sderr=5, meanerr=10), tol=1e-06) expect_equal(qmenorm(pmenorm(c(-2, 0, 2), sderr=5, lower=0), sderr=5, lower=0), qmenorm(pmenorm(c(-2, 0, 2))), tol=1e-03) }) test_that("Measurement error distributions: uniform",{ expect_equal(c(0,1,1,0,0), dmeunif(c(-2, 0, 0.7, 1, 2))) expect_equal(dunif(c(-2, 0, 0.7, 1, 2), min=-3:1, max=4:8), dmeunif(c(-2, 0, 0.7, 1, 2), lower=-3:1, upper=4:8), tol=1e-06) expect_equal(c(0.120192106440279, 0.139607083057178, 0.136490639905731, 0.120192106440279, 0.120192106440279), dmeunif(c(-2, 0, 0.7, 1, 2), lower=-3:1, upper=4:8, sderr=1), tol=1e-06) expect_equal(pmeunif(c(0.1, 0.5, 0.9)), punif(c(0.1, 0.5, 0.9)), tol=1e-04) expect_equal(c(0.468171571157871, 0.500000000120507, 0.531828429094026), pmeunif(c(0.1, 0.5, 0.9), sderr=5), tol=1e-06) expect_equal(c(0.0189218497312070, 0.0229301821964305, 0.0276311076816442), pmeunif(c(0.1, 0.5, 0.9), sderr=5, meanerr=10), tol=1e-06) expect_equal(c(0.1, 0.5, 0.9), qmeunif(pmeunif(c(0.1, 0.5, 0.9), sderr=5, lower=-1), sderr=5, lower=-1), tol=1e-03) expect_equal(c(0.1, 0.5, 0.9), qmeunif(pmeunif(c(0.1, 0.5, 0.9))), tol=1e-03) }) test_that("Exponential distribution with piecewise constant hazard",{ expect_equal(1, integrate(dpexp, 0, Inf)$value) rate <- c(0.1, 0.2, 0.05, 0.3) t <- c(0, 10, 20, 30) expect_equal(1, integrate(dpexp, 0, Inf, rate=rate, t=t)$value, tol=1e-04) x <- rexp(10) expect_equal(dpexp(x), dexp(x)) expect_equal(dpexp(x, log=TRUE), log(dpexp(x))) expect_equal(dpexp(x, log=TRUE), dexp(x, log=TRUE)) stopifnot(ppexp(-5) == 0) stopifnot(ppexp(0) == 0) stopifnot(ppexp(Inf) == 1) set.seed(22061976) q <- rexp(10) expect_equal(pexp(q), ppexp(q)) expect_equal(pexp(q, log.p=TRUE), ppexp(q, log.p=TRUE)) rate <- c(0.1, 0.2, 0.05, 0.3) t <- c(0, 10, 20, 30) stopifnot(ppexp(-5, rate, t) == 0) stopifnot(ppexp(0, rate, t) == 0) expect_equal(1, ppexp(Inf, rate, t)) expect_equal(1, ppexp(9999999, rate, t)) expect_equal(pexp(c(5, 6, 7), rate[1]), ppexp(c(5, 6, 7), rate, t)) expect_error(ppexp(q, rate=c(1,2,3), t=c(1,2)),"length of t must be equal to length of rate") expect_warning(ppexp(q, rate=-4),"NaN") expect_error(ppexp(q, rate=c(1,2,3), t=c(-1, 4, 6)), "first element of t should be 0") set.seed(22061976) p <- runif(10) expect_equal(qpexp(p), qexp(p), tol=1e-03) expect_equal(qpexp(p, lower.tail=FALSE), qexp(p, lower.tail=FALSE), tol=1e-03) expect_equal(qpexp(log(p), log.p=TRUE), qexp(log(p), log.p=TRUE), tol=1e-03) expect_equal(p, ppexp(qpexp(p)), tol=1e-03) set.seed(22061976) q <- rexp(10) expect_equal(q, qpexp(ppexp(q)), tol=1e-03) set.seed(220676) rt <- rpexp(10) set.seed(220676) r <- rexp(10) expect_equal(rt, r, tol=1e-06) }) test_that("deltamethod",{ ## Example in help(deltamethod) ## Simple linear regression, E(y) = alpha + beta x x <- 1:100 set.seed(220676) y <- rnorm(100, 4*x, 5) toy.lm <- lm(y ~ x) (estmean <- coef(toy.lm)) (estvar <- summary(toy.lm)$cov.unscaled * summary(toy.lm)$sigma^2) ## Estimate of (1 / (alphahat + betahat)) expect_equal(0.206982798128202, as.numeric(1 / (estmean[1] + estmean[2]))) ## Approximate standard error expect_equal(0.0396485739892983, deltamethod(~ 1 / (x1 + x2), estmean, estvar)) estvar2 <- estvar; estvar2[1,2] <- Inf expect_equal(deltamethod(~ 1 / (x1 + x2), estmean, estvar2), Inf) }) msm/tests/testthat/test_models_misc.r0000755000176200001440000001731012661577631017613 0ustar liggesuserscontext("msm misclassification model likelihoods") test_that("cav misclassification model with no covariates",{ misc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars=TRUE) expect_equal(4296.9155995778, misc.msm$minus2loglik, tol=1e-06) miscnew.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, deathexact = 4, fixedpars=TRUE, hmodel=list( hmmCat(prob=c(0.9, 0.1, 0, 0)), hmmCat(prob=c(0.1, 0.8, 0.1, 0)), hmmCat(prob=c(0, 0.1, 0.9, 0)), hmmIdent()) ) expect_equal(miscnew.msm$minus2loglik, misc.msm$minus2loglik) }) test_that("cav misclassification model with covariates on transition rates",{ misccov.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars = TRUE, covariates = ~ sex, covinits=list(sex=rep(0.1, 5))) expect_equal(4299.38058878142, misccov.msm$minus2loglik, tol=1e-06) }) test_that("cav misclassification model with covariates on misclassification probabilities",{ misccov.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars=TRUE, misccovariates = ~dage + sex, misccovinits = list(dage=c(0.01,0.02,0.03,0.04), sex=c(-0.013,-0.014,-0.015,-0.016))) expect_equal(4306.3077053482, misccov.msm$minus2loglik, tol=1e-06) misccovnew.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, deathexact = 4, fixedpars=TRUE, center=TRUE, hmodel=list( hmmCat(prob=c(0.9, 0.1, 0, 0)), hmmCat(prob=c(0.1, 0.8, 0.1, 0)), hmmCat(prob=c(0, 0.1, 0.9, 0)), hmmIdent()), hcovariates=list(~dage + sex, ~dage + sex, ~dage + sex, ~1), hcovinits = list(c(0.01,-0.013), c(0.02,-0.014,0.03,-0.015), c(0.04,-0.016), NULL) ) expect_equal(misccov.msm$minus2loglik, misccovnew.msm$minus2loglik, tol=1e-06) }) test_that("misclassification model with no misclassification reduces to simple",{ nomisc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = twoway4.q, ematrix=matrix(0, nrow=4, ncol=4), deathexact = 4, fixedpars=TRUE) simple.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = twoway4.q, deathexact = 4, fixedpars=TRUE) expect_equal(nomisc.msm$minus2loglik, simple.msm$minus2loglik) }) test_that("misclassification model with obstrue",{ misc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars=TRUE, obstrue=firstobs) expect_equal(4165.84711809003, misc.msm$minus2loglik, tol=1e-06) }) test_that("misclassification model with exact times",{ miscexact.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, exacttimes=TRUE, fixedpars=TRUE) expect_equal(4864.14764195147, miscexact.msm$minus2loglik, tol=1e-06) }) test_that("misclassification model with initprobs",{ miscinits.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, initprobs=c(0.7, 0.1, 0.1, 0.1), fixedpars=TRUE) expect_equal(4725.9078185031, miscinits.msm$minus2loglik, tol=1e-06) }) test_that("misclassification model with censoring",{ misccens.msm <- msm(state ~ years, subject = PTNUM, data = cav.cens, qmatrix = oneway4.q, ematrix=ematrix, deathexact=TRUE, censor=99, fixedpars=TRUE) expect_equal(4025.42265024404, misccens.msm$minus2loglik, tol=1e-06) }) test_that("misclassification model with two types of censoring",{ misccens.msm <- msm(state ~ years, subject=PTNUM, data=cav.cens2, qmatrix=oneway4.q, ematrix=ematrix, censor=c(99, 999), deathexact=4, censor.states=list(c(1,2,3), c(2,3)), fixedpars=TRUE) expect_equal(3811.69640533587, misccens.msm$minus2loglik, tol=1e-06) cav.cens2$obstrue <- as.numeric(cav.cens2$state %in% c(999)) misccens.msm <- msm(state ~ years, subject=PTNUM, data=cav.cens2, qmatrix=oneway4.q, ematrix=ematrix, censor=c(99, 999), deathexact=4, obstrue=obstrue, censor.states=list(c(1,2,3), c(2,3)), fixedpars=TRUE) expect_equal(3822.04540210944, misccens.msm$minus2loglik, tol=1e-06) }) test_that("misclassification model with no misclassification reduces to simple, with censoring",{ misc.msm <- msm(state ~ years, subject = PTNUM, data = cav.cens, qmatrix = twoway4.q, ematrix=matrix(0, nrow=4, ncol=4), censor=99, deathexact=TRUE, fixedpars=TRUE) simple.msm <- msm(state ~ years, subject = PTNUM, data = cav.cens, qmatrix = twoway4.q, deathexact=TRUE, censor=99, fixedpars=TRUE) expect_equal(misc.msm$minus2loglik, simple.msm$minus2loglik, tol=1e-06) misc.msm <- msm(state ~ years, subject = PTNUM, data = cav.cens, qmatrix = twoway4.q, ematrix=matrix(0, nrow=4, ncol=4), censor=99, fixedpars=TRUE) simple.msm <- msm(state ~ years, subject = PTNUM, data = cav.cens, qmatrix = twoway4.q, censor=99, fixedpars=TRUE) expect_equal(misc.msm$minus2loglik, simple.msm$minus2loglik, tol=1e-06) }) test_that("misclassification model with no misclassification reduces to simple, using hmmCat",{ miscnew.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = twoway4.q, hmodel=list(hmmCat(prob=c(1, 0, 0, 0)), hmmCat(prob=c(0, 1, 0, 0)), hmmCat(prob=c(0, 0, 1, 0)), hmmIdent()), fixedpars=TRUE) simple.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = twoway4.q, fixedpars=TRUE) expect_equal(miscnew.msm$minus2loglik, simple.msm$minus2loglik, tol=1e-06) }) test_that("can't mix ematrix and hcovariates",{ expect_error( misccov.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars=1:17, hcovariates=list(~dage + sex, ~dage + sex, ~dage + sex, ~1), hcovinits = list(c(0.01,0.013), c(0.01,0.013,0.01,0.013), c(0.01,0.013), NULL) ), "hcovariates have been specified, but no hmodel") }) test_that("data inconsistent with initprobs/ematrix",{ cav2 <- cav cav2$state[c(1,8)] <- 3 expect_warning(msm(state ~ years, subject = PTNUM, data = cav2, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars=TRUE), "First observation .+ is impossible") }) test_that("various errors",{ wrong.e <- "foo" expect_error(misc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=wrong.e, deathexact = 4, fixedpars=TRUE),"ematrix should be a numeric matrix") wrong.e <- 1 expect_error(misc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=wrong.e, deathexact = 4, fixedpars=TRUE),"ematrix should be a numeric matrix") wrong.e <- cbind(c(0,1,2), c(0,1,2)) expect_error(misc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=wrong.e, deathexact = 4, fixedpars=TRUE),"Number of rows and columns of ematrix should be equal") wrong.e <- cbind(c(0,1), c(0,2)) expect_error(misc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=wrong.e, deathexact = 4, fixedpars=TRUE),"Dimensions of qmatrix and ematrix should be the same") expect_warning(msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars=TRUE, gen.inits=TRUE), "gen.inits not supported for hidden Markov models, ignoring") }) msm/tests/testthat/test_models.r0000755000176200001440000013362212667316323016600 0ustar liggesuserscontext("msm simple model likelihoods") test_that("simple model, death",{ cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE, method="BFGS", control=list(trace=5, REPORT=1)) expect_equal(4908.81676837903, cav.msm$minus2loglik) }) test_that("simple model, no death",{ cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = FALSE, fixedpars=TRUE) expect_equal(4833.00640639644, cav.msm$minus2loglik) }) test_that("simple model, covariates",{ cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE, covariates = ~ sex, covinits = list(sex=rep(0.01, 7))) expect_equal(4909.17147259115, cav.msm$minus2loglik) }) test_that("autogenerated inits reproduce crudeinits",{ cinits <- crudeinits.msm(state ~ years, PTNUM, data=cav, qmatrix=twoway4.q) expect_equal(msm( state ~ years, subject=PTNUM, data = cav, qmatrix = cinits, deathexact = TRUE, fixedpars=TRUE)$minus2loglik, msm( state ~ years, subject=PTNUM, data = cav, qmatrix=twoway4.i, gen.inits=TRUE, deathexact = TRUE, fixedpars=TRUE)$minus2loglik) }) test_that("data as global variables",{ state.g <- cav$state; time.g <- cav$years; subj.g <- cav$PTNUM cav.msm <- msm(state.g ~ time.g, subject=subj.g, qmatrix = twoway4.i, gen.inits=TRUE, fixedpars=TRUE) expect_equal(4119.9736299032, cav.msm$minus2loglik) }) psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), control=list(fnscale=1)) test_that("psor model: covariates, constraints",{ expect_equal(1114.89946121717, psor.msm$minus2loglik, tol=1e-06) expect_equal(0.0959350004999946, psor.msm$Qmatrices$baseline[1,2], tol=1e-06) expect_equal(exp(psor.msm$Qmatrices$logbaseline[c(5,10,15)]), psor.msm$Qmatrices$baseline[c(5,10,15)], tol=1e-06) }) psor.nocen.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), center=FALSE) test_that("no covariate centering",{ expect_equal(exp(psor.nocen.msm$Qmatrices$logbaseline[c(5,10,15)]), psor.nocen.msm$Qmatrices$baseline[c(5,10,15)], tol=1e-06) }) test_that("gen.inits with missing values for state / time",{ psor2 <- psor; psor2$ptnum[13:14] <- psor2$months[7:8] <- psor2$state[7:8] <- NA psor2.msm <- msm(state ~ months, subject=ptnum, data=psor2, gen.inits=TRUE, qmatrix = psor.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), fixedpars=TRUE) expect_equal(1179.95441284169, psor2.msm$minus2loglik, tol=1e-06) }) test_that("exact transition times using exacttimes",{ msmtest5 <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, exacttimes=TRUE, fixedpars=TRUE) expect_equal(3057.85781916437, msmtest5$minus2loglik, tol=1e-06) }) test_that("exact transition times using obstype vector of all 2",{ msmtest5 <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, obstype=rep(2, nrow(bos)), fixedpars=TRUE) expect_equal(3057.85781916437, msmtest5$minus2loglik, tol=1e-06) }) test_that("exact transition times with death, should be same",{ expect_warning(msmtested <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, deathexact=5, obstype=rep(2, nrow(bos)), exacttimes=TRUE, fixedpars=TRUE), "Ignoring death") expect_equal(3057.85781916437, msmtested$minus2loglik, tol=1e-06) (msmtest5 <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, deathexact=5, obstype=rep(2, nrow(bos)), fixedpars=TRUE)) # no warning, inconsistently expect_equal(3057.85781916437, msmtest5$minus2loglik, tol=1e-06) }) cav$statefac <- factor(cav$state) cav$statefac2 <- factor(cav$state, labels=c("none","mild","severe","death")) test_that("factors as states, death",{ cav.msm <- msm( statefac ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE, method="BFGS", control=list(trace=5, REPORT=1)) expect_equal(4908.81676837903, cav.msm$minus2loglik) expect_error(msm( statefac2 ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE), "state variable should be numeric or a factor with ordinal numbers as levels") }) test_that("factor covariates with factor() in formula",{ ## Should be no need for users to do this. factors should already be identified as such in the data frame expect_warning(cavfaccov.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ factor(pdiag), covinits=list(sex=rep(0.1,7)), fixedpars=TRUE), "covariate .+ unknown") expect_equal(4793.30238295565, cavfaccov.msm$minus2loglik, tol=1e-06) cavfaccov.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ factor(pdiag), covinits=list("factor(pdiag)Hyper"=rep(0.1,7)), fixedpars=TRUE) expect_equal(4793.20440566637, cavfaccov.msm$minus2loglik, tol=1e-06) }) test_that("factors as global variables",{ state.g <- cav$state; time.g <- cav$years; subj.g <- cav$PTNUM; pdiag.g <- factor(cav$pdiag) cavfaccov.msm <- msm(state.g ~ time.g, subject=subj.g, qmatrix = twoway4.q, covariates = ~ pdiag.g, fixedpars=TRUE) expect_equal(4793.30238295565, cavfaccov.msm$minus2loglik, tol=1e-06) }) test_that("factor covariates using existing factors: inits are given to contrasts ",{ ## Warnings could be more informative here expect_warning(cavfaccov.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ pdiag, covinits=list(pdiag=rep(0.1,7)), fixedpars=TRUE), "covariate .+ unknown") expect_equal(4793.30238295565, cavfaccov.msm$minus2loglik, tol=1e-06) expect_warning(cavfaccov.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ pdiag, covinits=list(pdiagNonexistentlevel=rep(0.1,7)), fixedpars=TRUE), "covariate .+ unknown") expect_equal(4793.30238295565, cavfaccov.msm$minus2loglik, tol=1e-06) cavfaccov.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ pdiag, covinits=list(pdiagHyper=rep(0.1,7)), fixedpars=TRUE) expect_equal(4793.20440566637, cavfaccov.msm$minus2loglik, tol=1e-06) cavfaccov.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ pdiag, covinits=list(pdiagHyper=rep(0.1,7),pdiagIDC=rep(0.1,7),pdiagIHD=rep(0.1,7),pdiagOther=rep(0.1,7),pdiagRestr=rep(0.1,7)), fixedpars=TRUE) # OK expect_equal(4793.13035886505, cavfaccov.msm$minus2loglik, tol=1e-06) }) context("censored states") test_that("censored states: final state censored",{ cavcens.msm <- msm(state ~ years, subject=PTNUM, data=cav.cens, qmatrix=twoway4.q, censor=99, fixedpars=TRUE) expect_equal(4724.26606344485, cavcens.msm$minus2loglik, tol=1e-06) v <- viterbi.msm(cavcens.msm) expect_equal(v$observed[v$observed<10], v$fitted[v$observed<10]) expect_equal(v$fitted[v$observed==99][1], 3) }) test_that("two kinds of censoring",{ cavcens2.msm <- msm(state ~ years, subject=PTNUM, data=cav.cens2, qmatrix=twoway4.q, censor=c(99, 999), censor.states=list(c(1,2,3), c(2,3)), fixedpars=TRUE) expect_equal(4678.23348518727, cavcens2.msm$minus2loglik, tol=1e-06) v <- viterbi.msm(cavcens2.msm) expect_equal(v$observed[v$observed<10], v$fitted[v$observed<10]) expect_equal(v$fitted[v$observed==99][1], 3) }) test_that("intermediate state censored",{ cavcens3.msm <- msm(state ~ years, subject=PTNUM, data=cav.cens3, qmatrix=twoway4.q, censor=c(99, 999), censor.states=list(c(2,3), c(1,2,3)), fixedpars=TRUE) expect_equal(4680.66073438518, cavcens3.msm$minus2loglik, tol=1e-06) v <- viterbi.msm(cavcens3.msm) expect_equal(v$observed[v$observed<10], v$fitted[v$observed<10]) expect_true(all(v$fitted[v$observed==99] %in% 2:3)) expect_true(all(v$fitted[v$observed==999] %in% 1:3)) }) test_that("first state censored",{ cav.cens4 <- cav cav.cens4$state[c(1,8,12,22)] <- 99 cavcens4.msm <- msm(state ~ years, subject=PTNUM, data=cav.cens4, qmatrix=twoway4.q, censor=c(99), censor.states=list(c(2,3)), fixedpars=TRUE) expect_equal(4846.06045097812, cavcens4.msm$minus2loglik) v <- viterbi.msm(cavcens4.msm) expect_true(all(v$fitted[v$observed==99] %in% 2:3)) }) test_that("piecewise constant intensities with pci",{ cav5.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE, pci = c(5), covinits = list("timeperiod[5,Inf)"=rep(0.01,7)), ) expect_equal(4906.01423796805, cav5.msm$minus2loglik, tol=1e-06) cav10.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, pci = c(5,10), fixedpars=TRUE, covinits = list("timeperiod[5,10)"=rep(0.01,7), "timeperiod[10,Inf)"=rep(0.01,7)), ) expect_equal(4905.61646158639, cav10.msm$minus2loglik, tol=1e-06) }) test_that("piecewise constant intensities with pci, cut points outside data",{ ## Make sure works for pci outside time range, with warning expect_warning(cav5.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE, pci = c(-1,5,50,60), covinits = list("timeperiod[5,Inf)"=rep(0.01,7))), "cut point .+ less than") expect_warning(cav.pci.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE, pci = c(-1,50,60))) cav.msm <- msm( state ~ years, subject=PTNUM, data = cav,qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE) expect_equal(cav.pci.msm$minus2loglik, cav.msm$minus2loglik) # degrades to time-homogeneous if all cuts outside data }) set.seed(22061976) cav$pdiag3 <- cav$pdiag cav$pdiag3[!cav$pdiag %in% c("IDC","IHD")] <- "Other" cav$pdiag3 <- factor(cav$pdiag3) subs <- cav$PTNUM %in% sample(unique(cav$PTNUM), 50) cavsub <- subset(cav, subs) cavsub$maxtime <- tapply(cavsub$years, cavsub$PTNUM, max)[as.character(cavsub$PTNUM)] cavsub.extra <- cavsub[cavsub$years==0 & cavsub$maxtime >= 5,] cavsub.extra$years <- 5 cavsub.extra$state <- 99 cavsub.extra10 <- cavsub[cavsub$years==0 & cavsub$maxtime >= 10,] cavsub.extra10$years <- 10 cavsub.extra10$state <- 999 cavsub2 <- rbind(cavsub, cavsub.extra, cavsub.extra10) cavsub2 <- cavsub2[order(cavsub2$PTNUM, cavsub2$years),] cavsub2$after5 <- ifelse(cavsub2$years>=5 & cavsub2$years<10, 1, 0) cavsub2$after10 <- ifelse(cavsub2$years>=10, 1, 0) cavsub2$after510 <- as.numeric(cavsub2$after5 | cavsub2$after10) test_that("piecewise constant intensities with pci, with other covariates",{ cav5cov.msm <- msm( state ~ years, subject=PTNUM, data = cavsub, qmatrix = twoway4.q, covariates = ~ pdiag3 + sex, deathexact = TRUE, pci = c(5,10), fixedpars=TRUE, covinits = list("timeperiod[5,10)"=rep(0.01,7), "timeperiod[10,Inf)"=rep(0.01,7), pdiag3IHD=rep(0.01,7), pdiag3Other=rep(0.01,7)), ) expect_equal(448.122802051545, cav5cov.msm$minus2loglik, tol=1e-06) cav5cov.msm <- msm( state ~ years, subject=PTNUM, data = cavsub2, qmatrix = twoway4.q, deathexact = TRUE, covariates = ~ pdiag3 + sex + after5 + after10, censor=c(99,999), censor.states=list(1:4,1:4), covinits = list(after5=rep(0.01,7), after10=rep(0.01,7), pdiag3IHD=rep(0.01,7), pdiag3Other=rep(0.01,7)), fixedpars=TRUE ) expect_equal(448.122802051545, cav5cov.msm$minus2loglik, tol=1e-06) }) test_that("piecewise constant intensities with pci, with uncentered covariates",{ cav5cov.msm <- msm( state ~ years, subject=PTNUM, data = cavsub, qmatrix = twoway4.q, covariates = ~ pdiag3 + sex, deathexact = TRUE, pci = c(5,10), fixedpars=TRUE, center=FALSE, covinits = list("timeperiod[5,10)"=rep(0.01,7), "timeperiod[10,Inf)"=rep(0.01,7), pdiag3IHD=rep(0.01,7), pdiag3Other=rep(0.01,7)), ) expect_equal(449.691983558378, cav5cov.msm$minus2loglik, tol=1e-06) cav5cov.msm <- msm( state ~ years, subject=PTNUM, data = cavsub2, qmatrix = twoway4.q, deathexact = TRUE, covariates = ~ pdiag3 + sex + after5 + after10, censor=c(99,999), censor.states=list(1:4,1:4), center=FALSE, covinits = list(after5=rep(0.01,7), after10=rep(0.01,7), pdiag3IHD=rep(0.01,7), pdiag3Other=rep(0.01,7)), fixedpars=TRUE ) expect_equal(449.691983558378, cav5cov.msm$minus2loglik, tol=1e-06) }) test_that("piecewise constant intensities with pci, with other censored states",{ cav.cens <- cav cav.cens$state[cav.cens$state==4][1:50] <- 99 cav5cens.msm <- msm(state ~ years, subject=PTNUM, data = cav.cens, qmatrix = twoway4.q, deathexact = TRUE, censor=99, pci = 5, covinits=list("timeperiod[5,Inf)"=rep(0.02,7)), fixedpars=TRUE, method="BFGS", control=list(trace=5, REPORT=1)) expect_equal(4754.41981265159, cav5cens.msm$minus2loglik, tol=1e-06) }) test_that("piecewise constant intensities with covariates in HMMs",{ misccov.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, deathexact = 4, fixedpars=TRUE, pci = 5, covinits=list("timeperiod[5,Inf)"=rep(0.0001,5)), misccovariates = ~dage + sex, misccovinits = list(dage=c(0.01,0.02,0.03,0.04), sex=c(-0.013,-0.014,-0.015,-0.016))) expect_equal(4306.29865288466, misccov.msm$minus2loglik, tol=1e-06) }) context("output functions") test_that("qmatrix.msm for psor model, defaults",{ expect_equal(c(-0.0959350004999946, 0, 0, 0, 0.0959350004999946, -0.164306508892574, 0, 0, 0, 0.164306508892574, -0.254382807485639, 0, 0, 0, 0.254382807485639, 0), as.numeric(qmatrix.msm(psor.msm)$estimates), tol=1e-03) expect_equal(c(0.0115942726096754, 0, 0, 0, 0.0115942726096754, 0.0196169975000406, 0, 0, 0, 0.0196169975000406, 0.0375066077515386, 0, 0, 0, 0.0375066077515386, 0), as.numeric(qmatrix.msm(psor.msm)$SE), tol=1e-03) qmatrix.msm(psor.msm, ci="normal", B=2) expect_error(qmatrix.msm("foo"), "expected .+ msm model") expect_error(qmatrix.msm(psor.msm, covariates="foo"), "covariates argument must be") expect_warning(qmatrix.msm(psor.msm, covariates=list(foo=1)), "ignoring") }) test_that("qmatrix.msm defaults to Qmatrices in object",{ expect_equal(psor.msm$Qmatrices$baseline, qmatrix.msm(psor.msm, covariates="mean", ci="none")) expect_equal(psor.nocen.msm$Qmatrices$baseline, qmatrix.msm(psor.nocen.msm, covariates=0, ci="none")) }) test_that("qmatrix.msm with supplied covariates",{ qmat <- qmatrix.msm(psor.msm, covariates=list(ollwsdrt=0.1, hieffusn=0.4)) expect_equal(c(-0.121430585652200, 0, 0, 0, 0.121430585652200, -0.207972362475868, 0, 0, 0, 0.207972362475868, -0.257535341208494, 0, 0, 0, 0.257535341208494, 0), as.numeric(qmat$estimates), tol=1e-03) expect_equal(c(0.0162156605802465, 0, 0, 0, 0.0162156605802465, 0.0266727053124233, 0, 0, 0, 0.0266727053124233, 0.0364321127089265, 0, 0, 0, 0.0364321127089265, 0), as.numeric(qmat$SE), tol=1e-04) expect_warning(qmatrix.msm(psor.msm, covariates=list(hieffusn=0.1, foo=0.4)), "Covariate .+ unknown") }) test_that("qmatrix.msm with non-default confidence limits",{ qmat <- qmatrix.msm(psor.msm, covariates=list(ollwsdrt=0.1, hieffusn=0.4), cl=0.99) expect_equal(c(-0.171282667596986, 0, 0, 0, 0.0860880282792585, -0.289385121267802, 0, 0, 0, 0.149463467106753, -0.370756460718086, 0, 0, 0, 0.178889538008097, 0), as.numeric(qmat$L), tol=1e-04) }) test_that("qmatrix.msm sojourn component",{ soj <- qmatrix.msm(psor.msm, covariates=list(ollwsdrt=0.1, hieffusn=0.4), sojourn=TRUE)$sojourn expect_equal(c(8.23515751512713, 4.80833120370037, 3.88296221911705, Inf), as.numeric(soj), tol=1e-03) expect_equal(as.numeric(soj[1:3]), sojourn.msm(psor.msm, covariates=list(ollwsdrt=0.1, hieffusn=0.4))[,"estimates"]) }) test_that("qmatrix.msm bug for user-supplied covariates fixed in 1.1.3",{ expect_equal(qmatrix.msm(psor.nocen.msm, covariates=0)$SE[1,2], qmatrix.msm(psor.nocen.msm, covariates=list(hieffusn=0, ollwsdrt=0))$SE[1,2]) expect_equal(qmatrix.msm(psor.nocen.msm, covariates=0)$SE[1,1], qmatrix.msm(psor.nocen.msm, covariates=list(hieffusn=0, ollwsdrt=0))$SE[1,1]) expect_equal(qmatrix.msm(psor.nocen.msm, covariates=0)$L[1,2], qmatrix.msm(psor.nocen.msm, covariates=list(hieffusn=0, ollwsdrt=0))$L[1,2]) expect_equal(qmatrix.msm(psor.nocen.msm, covariates=0)$L[1,2], qmatrix.msm(psor.nocen.msm, covariates=list(hieffusn=0))$L[1,2]) cm <- psor.nocen.msm$qcmodel$covmeans expect_equal(qmatrix.msm(psor.nocen.msm, covariates="mean")$SE[1,2], qmatrix.msm(psor.nocen.msm, covariates=list(hieffusn=cm["hieffusn"], ollwsdrt=cm["ollwsdrt"]))$SE[1,2]) }) test_that("qmatrix.msm: unspecified covariate values default to zero",{ expect_equal(psor.nocen.msm$Qmatrices$baseline, qmatrix.msm(psor.nocen.msm, covariates=list(ollwsdrt=0), ci="none")) # missing covs default to zero expect_equal(qmatrix.msm(psor.msm, covariates=list(hieffusn=0)), qmatrix.msm(psor.msm, covariates=list(ollwsdrt=0, hieffusn=0))) expect_equal(qmatrix.msm(psor.nocen.msm, covariates=list(hieffusn=0)), qmatrix.msm(psor.nocen.msm, covariates=list(ollwsdrt=0, hieffusn=0))) }) test_that("sojourn.msm",{ expect_equal(psor.msm$sojourn, sojourn.msm(psor.msm, covariates="mean")) expect_equal(psor.nocen.msm$sojourn, sojourn.msm(psor.nocen.msm, covariates=0)) soj <- sojourn.msm(psor.msm, covariates=list(ollwsdrt=0.1, hieffusn=0.4)) expect_equal(c(8.23515751512713, 4.80833120370037, 3.88296221911705, 1.09971073904434, 0.616674252838334, 0.549301375677405, 6.33875136203292, 3.73961380505919, 2.94271599303942, 10.6989240349703, 6.18246967994404, 5.12363260020806), as.numeric(unlist(soj)), tol=1e-04) soj <- sojourn.msm(psor.msm, covariates=list(ollwsdrt=0.1, hieffusn=0.4), cl=0.99) expect_equal(5.83830234564607, soj[1,"L"], tol=1e-04) expect_error(sojourn.msm("foo"), "expected .+ msm model") expect_error(sojourn.msm(psor.msm, covariates="foo"),"covariates argument must be") expect_warning(sojourn.msm(psor.msm, covariates=list(foo=1)), "ignoring") }) test_that("pmatrix.msm",{ expect_equal(0.149287738928777, pmatrix.msm(psor.msm, ci="none", t=10)[1,3], tol=1e-04) p <- pmatrix.msm(psor.msm, t=10, covariates=list(ollwsdrt=0.1, hieffusn=0.2)) expect_equal(0.18196160265907, p[1,3], tol=1e-04) set.seed(22061976); expect_equal(0.12, pmatrix.msm(psor.msm, ci="normal", B=3)$L[2,3], tol=1e-01, scale=1) expect_error(pmatrix.msm("foo"), "expected .+ msm model") expect_error(pmatrix.msm(psor.msm, t="foo"), "must be a positive number") expect_error(pmatrix.msm(psor.msm, -9), "must be a positive number") expect_equivalent(unclass(pmatrix.msm(psor.msm, 0)), diag(4)) expect_warning(pmatrix.msm(psor.msm, 1, covariates=list(foo=1)), "ignoring") }) test_that("qratio.msm",{ q <- qratio.msm(psor.msm, c(1,2), c(2,3)) expect_equal(c(0.583878474075081, 0.0996029045389022, 0.417943274168735, 0.815694601537263), as.numeric(q), tol=1e-04) q <- qratio.msm(psor.msm, c(1,2), c(2,3), cl=0.99) expect_equal(0.376262194364283, as.numeric(q["L"]), tol=1e-04) q <- qratio.msm(psor.msm, c(1,1), c(2,3)) expect_equal(c(-0.583878474075081, 0.0996029045389022, -0.815694601537263, -0.417943274168735), as.numeric(q), tol=1e-04) q <- qratio.msm(psor.msm, c(2,2), c(2,3)) expect_equivalent(c(-1,0,-1,-1), q) qratio.msm(psor.msm, c(1,2), c(2,3), ci="norm", B=2) expect_error(qratio.msm("foo")) expect_error(qratio.msm(psor.msm, "foo")) expect_error(qratio.msm(psor.msm, c(1,8), c(1,0))) expect_error(qratio.msm(psor.msm, c(1,2), c(1,0))) expect_error(qratio.msm(psor.msm, c(1,2), c(2,3), cl="foo")) expect_error(qratio.msm(psor.msm, c(1,2), c(2,3), cl=2), "expected cl in") }) test_that("coef.msm",{ co <- coef.msm(psor.msm) expect_equal(0.498319866154661, co$hieffusn[1,2], tol=1e-04) expect_error(coef.msm("foo")) }) test_that("hazard.msm",{ haz <- hazard.msm(psor.msm) expect_equal(0.385347226135311, haz$ollwsdrt[1,2], tol=1e-04) expect_equal(0.385347226135311, haz$ollwsdrt[2,2], tol=1e-04) expect_equal(2.35928404626333, haz$hieffusn[1,3], tol=1e-04) expect_equal(2.35928404626333, haz$hieffusn[3,3], tol=1e-04) haz <- hazard.msm(psor.msm, hazard.scale=2) expect_equal(0.148492484690178, haz$ollwsdrt[1,2], tol=1e-04) expect_equal(haz$ollwsdrt[1,2], haz$ollwsdrt[2,2]) expect_equal(haz$hieffusn[1,3], haz$hieffusn[3,3]) haz <- hazard.msm(psor.msm, hazard.scale=c(1,2)) expect_equal(0.385347226135311, haz$ollwsdrt[1,2], tol=1e-04) expect_equal(haz$ollwsdrt[1,2], haz$ollwsdrt[2,2], tol=1e-04) expect_equal(haz$hieffusn[1,3], haz$hieffusn[3,3]) expect_error(hazard.msm("foo")) expect_error(hazard.msm(psor.msm, hazard.scale="foo")) expect_error(hazard.msm(psor.msm, hazard.scale=c(1,2,3)), "hazard.scale of length") }) test_that("transient.msm and absorbing.msm",{ expect_equivalent(c(1,2,3), transient.msm(psor.msm)) expect_equivalent(4, absorbing.msm(psor.msm)) expect_error(transient.msm("foo")) expect_error(absorbing.msm("foo")) expect_error(transient.msm(qmatrix="foo")) expect_error(absorbing.msm(qmatrix="foo")) expect_error(transient.msm(qmatrix=c(1,4,5,6))) expect_error(absorbing.msm(qmatrix=c(1,4,5,6))) expect_error(transient.msm(qmatrix=cbind(c(1,2,3),c(1,3,2)))) expect_error(absorbing.msm(qmatrix=cbind(c(1,2,3),c(1,3,2)))) expect_error(transient.msm()) expect_error(absorbing.msm()) }) test_that("prevalence.msm",{ p <- prevalence.msm(psor.msm) expect_equal(59, p$Observed[5,5], tol=1e-06) expect_equal(59, p$Expected[5,5], tol=1e-06) expect_equal(57.35294, p$"Observed percentages"[4,4], tol=1e-03) expect_equal(49.96882, p$"Expected percentages"[4,4], tol=1e-03) summ <- summary.msm(psor.msm) expect_equal(summ$prevalences, p) p <- prevalence.msm(psor.msm, times=seq(0,60,5)) expect_equal(63, p$Observed[5,5], tol=1e-06) expect_equal(63, p$Expected[5,5], tol=1e-06) expect_equal(50.70423, p$"Observed percentages"[4,4], tol=1e-03) expect_equal(41.46338, p$"Expected percentages"[4,4], tol=1e-03) expect_error(prevalence.msm("foo")) expect_error(summary.msm("foo")) ## lisa edwards bug - can't reproduce # library(msm, lib.loc="~/work/msm/src/1.2") # library(msm, lib.loc="~/work/msm/src/1.3") # p <- prevalence.msm(psor.msm, covariates=list(hieffusn=0, ollwsdrt=1)) # b.age <- sample(18:75, size=nrow(psor), replace=TRUE) # psor.contcov.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, covariates = ~b.age) # p <- prevalence.msm(psor.contcov.msm) # p <- prevalence.msm(psor.contcov.msm, covariates=list(b.age=10)) # p <- prevalence.msm(psor.contcov.msm, covariates="population") }) test_that("pmatrix.piecewise.msm",{ times <- c(5, 10, 15) covariates <- list(list(ollwsdrt=0, hieffusn=0), list(ollwsdrt=0, hieffusn=1), list(ollwsdrt=1, hieffusn=0), list(ollwsdrt=1, hieffusn=1) ) p <- pmatrix.msm(psor.msm, 3, covariates=covariates[[1]]) pp <- pmatrix.piecewise.msm(psor.msm, 0, 3, times, covariates) expect_equal(pp[1,3], p[1,3], tol=1e-04) p <- pmatrix.piecewise.msm(psor.msm, 0, 7, times, covariates) expect_equal(0.172773087945103, p[1,3], tol=1e-04) pp <- pmatrix.piecewise.msm(psor.msm, 0, 19, times, covariates) expect_equal(0.0510873669808412, pp[1,3], tol=1e-04) p <- pmatrix.msm(psor.msm, 5, covariates=covariates[[1]]) %*% pmatrix.msm(psor.msm, 5, covariates=covariates[[2]]) %*% pmatrix.msm(psor.msm, 5, covariates=covariates[[3]]) %*% pmatrix.msm(psor.msm, 4, covariates=covariates[[4]]) expect_equal(pp[1,3], p[1,3], tol=1e-04) covariates <- list(list(ollwsdrt=0, hieffusn=0),list(ollwsdrt=0, hieffusn=1)) p <- pmatrix.piecewise.msm(psor.msm, 0, 7, times=5, covariates) expect_equal(0.172773087945103, p[1,3], tol=1e-04) expect_error(pmatrix.piecewise.msm("foo", 1,2, c(1, 2), c(1,2)), "expected .+ msm model") expect_error(pmatrix.piecewise.msm("foo", 1, 2, c(1, 0.5, 2), list(0, 1, 0, 1)), "expected .+ msm model") expect_error(pmatrix.piecewise.msm(psor.msm, 1, 2, c(1, 0.5, 2), list(0, 1, 0, 1)), "times should be a vector of numbers in increasing order") expect_error(pmatrix.piecewise.msm(psor.msm, 1, 2, "rubbish", list(0, 1, 0, 1)),"times should be a vector of numbers in increasing order") expect_error(pmatrix.piecewise.msm(psor.msm, 1, 2, c(1, 1.5, 2), "rubbish")) expect_error(pmatrix.piecewise.msm(psor.msm, 1, 2, c(1, 1.5, 2), list("rubbish", "foo","bar","boing")), "covariates argument") expect_error(pmatrix.piecewise.msm(psor.msm, 1, 2, c(1, 1.5, 2), list(0, 1, 0, 1)), "covariates argument") }) test_that("logLik.msm",{ expect_equivalent(unclass(logLik.msm(psor.msm)), psor.msm$minus2loglik / -2) expect_error(logLik.msm("foo")) }) test_that("qmatrix subset function",{ Q <- qmatrix.msm(psor.msm) expect_equivalent(Q[1,2]["SE"], Q$SE[1,2]) expect_error(Q[1,2,3,4,5], "unused arguments") expect_error(Q[1], "Two dimensions must be supplied") expect_equivalent(Q[], Q) Q[1,] Q[,2] Q[c(1,2),] Q[c(2,1),] Q[c(1,2),c(1,2)] }) test_that("efpt.msm",{ Q <- twoway4.q expect_equal(efpt.msm(qmatrix=Q, tostate=3), c(Inf,Inf,0,Inf)) Q <- rbind(c(-0.25,0.25,0), c(0.166, -0.332, 0.166), c(0, 0.25, -0.25)) expect_equal(efpt.msm(qmatrix=Q, tostate=3)[c(1,2)], solve(-Q[1:2,1:2], c(1,1)),tol=1e-06) Q <- twoway4.q; Q[2,4] <- Q[2,1] <- 0; diag(Q) <- 0; diag(Q) <- -rowSums(Q) expect_equal(efpt.msm(qmatrix=Q, tostate=3), c(Inf, 6.02409638554217, 0, Inf), tol=1e-05) expect_equal(efpt.msm(psor.msm, tostate=c(2)), c(10.4237243422138, 0, Inf, Inf), tol=1e-05) expect_equal(efpt.msm(psor.msm, tostate=c(3)), c(16.5099104995137, 6.08618615729989, 0, Inf), tol=1e-05) expect_equal(efpt.msm(psor.msm, tostate=c(2,3)), c(10.4237243422138, 0, 0, Inf), tol=1e-05) }) test_that("ppass.msm",{ pp <- ppass.msm(psor.msm, tot=10) pm <- pmatrix.msm(psor.msm, t=10) expect_equal(pp[,4], pm[,4]) # state 4 is absorbing pp <- ppass.msm(qmatrix=twoway4.q, tot=1000) expect_equal(pp[1,2], 0.5) expect_warning(ppass.msm(qmatrix=twoway4.q, tot=100, ci="normal"), "No fitted model supplied: not calculating confidence intervals") }) test_that("score residuals",{ sres <- scoreresid.msm(psor.msm) expect_equal(c(0.0608163009112361, 0.187998750251689, 0.0143302186951471), as.numeric(sres[1:3]), tol=1e-05) psor2 <- na.omit(psor); psor2$months[psor2$ptnum==5] <- psor2$months[psor2$ptnum==5]*10 psor.0.q <- rbind(c(0,0.1,0,0),c(0,0,0.2,0),c(0,0,0,0.3),c(0,0,0,0)) psor.infl.msm <- msm(state ~ months, subject=ptnum, data=psor2, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), qmatrix = psor.0.q) sres <- scoreresid.msm(psor.infl.msm) if (interactive()) sres <- scoreresid.msm(psor.infl.msm, plot=TRUE) expect_equal(names(which.max(sres)), "5") }) test_that("observed, expected etc",{ ## two covariates expect_equal(get.covhist(psor.msm)$example$time, c(6.4606, 17.078, 26.3217, 30.5763, 6.4052, 7.6893, 3.3593, 12.7775)) expect_equivalent(observed.msm(psor.msm)$obstab[,"State 4"], c(0, 6, 25, 39, 48, 50, 52, 53, 55, 56, 57)) expect_equal(as.numeric(expected.msm(psor.msm, covariates="population")$Expected[1:5,"State 3"]), c(0, 11.7058415609289, 14.8078062584701, 9.50355791490463, 5.83372436779321), tol=1e-05) expect_equal(as.numeric(expected.msm(psor.msm, covariates="mean")$Expected[1:5,"State 3"]), c(0, 11.165395364321, 14.8732589026358, 9.67192721319246, 6.26754773418822), tol=1e-05) }) test_that("observed, expected etc with one covariate, should run",{ psor1.msm <- msm(state ~ months, covariates=~ollwsdrt, subject=ptnum, data=psor, qmatrix = psor.q) get.covhist(psor1.msm) observed.msm(psor1.msm) expected.msm(psor1.msm) expected.msm(psor1.msm, covariates="mean") }) test_that("observed, expected etc with PCI, should run",{ psor1.msm <- msm(state ~ months, covariates=~ollwsdrt+hieffusn, subject=ptnum, data=psor, qmatrix = psor.q, pci=c(5,10)) covhist <- get.covhist(psor1.msm) observed.msm(psor1.msm) expected.msm(psor1.msm) expected.msm(psor1.msm, covariates="mean") }) test_that("subset argument to observed",{ subs <- psor.msm$data$mf$"(subject)"[!duplicated(psor.msm$data$mf$"(subject)") & psor.msm$data$mf$ollwsdrt==0] expect_equivalent(observed.msm(psor.msm, subset=subs)$obstab[,"State 4"], c(0, 5, 20, 30, 37, 38, 40, 41, 43, 44, 45)) }) test_that("error handling: formula",{ ## formula expect_error(msm(), "state ~ time formula not given") expect_error(cav.msm <- msm(state, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE), "not found") expect_error(cav.msm <- msm(~1, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE), "invalid data") expect_error(cav.msm <- msm("foo", subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE), "not a formula") }) test_that("error handling: qmatrix",{ wrong.q <- cbind(c(0,1,2), c(0,1,2)) expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = wrong.q, deathexact = TRUE, fixedpars=TRUE),"Number of rows and columns of qmatrix should be equal") wrong.q <- cbind(c(0,1), c(0,1)) expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = wrong.q, fixedpars=TRUE),"State vector contains elements not in 1, 2") expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = wrong.q, deathexact = TRUE, fixedpars=TRUE),"Not all the \"death\" states are absorbing") wrong.q <- "foo" expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = wrong.q, deathexact = TRUE, fixedpars=TRUE),"qmatrix should be a numeric matrix") wrong.q <- 1 expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = wrong.q, deathexact = TRUE, fixedpars=TRUE),"qmatrix should be a numeric matrix") }) test_that("error handling: subject",{ expect_error(cav.msm <- msm(state~years, subject="foo", data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE),"variable lengths differ") expect_error(cav.msm <- msm(state~years, subject=foo, data = cav, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE),"not found") }) test_that("error handling: obstype",{ expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype="foo", deathexact = TRUE, fixedpars=TRUE),"should be numeric") expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=rep(1,10), deathexact = TRUE, fixedpars=TRUE),"obstype of length") ##FIXME expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=rep(4, nrow(cav)), deathexact = TRUE, fixedpars=TRUE),"elements of obstype should be 1, 2, or 3") obstype <- rep(1, nrow(cav)) obstype[c(1,8)] <- 5 expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=obstype, deathexact = TRUE, fixedpars=TRUE), NA) # no error: obstype for first subject doesn't matter obstype[2] <- 5 expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=obstype, deathexact = TRUE, fixedpars=TRUE),"elements of obstype should be 1, 2, or 3") # error }) test_that("error handling: covariates",{ expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = "wibble"),"should be a formula or list of formulae") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sux),"not found") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, fixedpars=TRUE, misccovariates = "wobble"),"should be a formula") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sox),"not found") }) test_that("error handling: covinits",{ expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, covinits="foo", fixedpars=TRUE),"covinits should be a list") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, covinits=list(sex="foo", age="bar"), fixedpars=TRUE),"should be numeric") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, covinits=list(sex=c(1,2,3), age="bar"), fixedpars=TRUE),"should be a list of numeric vectors") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, covinits=list(age=rep(0.1, 7)), fixedpars=TRUE),"covariate age in covinits unknown") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, covinits=list(age=rep(0.1, 7), foo=1, bar=2), fixedpars=TRUE),"covariates age, foo, bar in covinits unknown") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, covinits=list(sex=1), fixedpars=TRUE),"initial values of length 1, should be 7") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, misccovariates = ~ sex, misccovinits="foo", fixedpars=TRUE), "hcovinits should be numeric") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, misccovariates = ~ sex, misccovinits=list(sex=1, age="bar"), fixedpars=TRUE), "misccovariates supplied but no ematrix") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, misccovariates = ~ sex, misccovinits=list(sex=1, age="bar"), fixedpars=TRUE),"misccovariates supplied but no ematrix") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, ematrix=ematrix, misccovariates = ~ sex, misccovinits=list(sex=1, age="bar"), fixedpars=TRUE),"covinits should be a list of numeric") }) test_that("error handling: constraints",{ expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, constraint="foo"),"constraint should be a list") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, constraint=list(foo="bar")),"constraint should be a list of numeric vectors") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, covariates = ~ sex, constraint=list(foo=1)),"Covariate .+ in constraint statement not in model.") expect_warning(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, misccovariates = ~ sex, constraint="foo", fixedpars=TRUE),"constraint specified but no covariates") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, misccovariates = ~ sex, miscconstraint=list(foo="bar")),"constraint should be a list of numeric vectors") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, misccovariates = ~ sex, miscconstraint=list(foo=1)),"Covariate .+ in constraint statement not in model.") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, misccovariates = ~ sex, miscconstraint=list(sex=1)),"constraint of length 1, should be 4") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, qconstraint="foo", fixedpars=TRUE),"qconstraint should be numeric") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, qconstraint=list(c(1,1,2)), fixedpars=TRUE),"qconstraint should be numeric") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, qconstraint=c(1,1,2), fixedpars=TRUE),"baseline intensity constraint of length 3, should be 7") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, econstraint="foo", fixedpars=TRUE) ,"econstraint should be numeric") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, econstraint=list(c(1,1,2)), fixedpars=TRUE) ,"econstraint should be numeric") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, econstraint=c(1,1,2), fixedpars=TRUE),"baseline misclassification constraint of length 3, should be 4") }) test_that("error handling: initprobs",{ expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, initprobs="poo", fixedpars=TRUE),"initprobs should be numeric") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, initprobs=c(1,2), fixedpars=TRUE),"initprobs vector of length 2, should be vector of length 4 or a matrix") expect_error(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, initprobs=c(2,1,1,1), fixedpars=TRUE), NA) # scaled to sum to 1. }) test_that("error handling: check states",{ wrong.q <- cbind(c(0,1), c(0,1)) # extra states in data expect_error(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = wrong.q, fixedpars=TRUE),"State vector contains elements not in 1, 2") wrong.q <- rbind(c(0,1,2,3,1), c(0,1,3,4,1), c(0,1,2,3,2), c(0,1,2,3,4), c(0,0,0,0,0)) expect_warning(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = wrong.q, fixedpars=TRUE),"State vector doesn't contain observations of 5") }) test_that("error handling: check times",{ cav.wrong <- cav cav.wrong$years[3:5] <- 4:2 expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE),"not ordered by time") cav.wrong <- cav cav.wrong$PTNUM[4:5] <- 100003 expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, deathexact = TRUE, fixedpars=TRUE),"Observations within subjects .+ are not adjacent in the data") cav2 <- cav cav2$years[10] <- cav2$years[9] expect_warning(msm(state ~ years, subject=PTNUM, data = cav2, qmatrix = twoway4.q, fixedpars=TRUE), "Different states observed at the same time on the same subject at observations 9 and 10") ## with missing data cav2$years[6] <- NA ## report original rows before excluding missing data expect_warning(msm(state ~ years, subject=PTNUM, data = cav2, qmatrix = twoway4.q, fixedpars=TRUE), "Different states observed at the same time on the same subject at observations 9 and 10") cav2 <- cav2[6:nrow(cav),] expect_warning(msm(state ~ years, subject=PTNUM, data = cav2, qmatrix = twoway4.q, fixedpars=TRUE), "Different states observed at the same time on the same subject at observations 4 and 5", "Subject 100002 only has one complete observation") }) test_that("error handling: check model",{ cav.wrong <- cav cav.wrong$state[4] <- 1 expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = oneway4.q, deathexact = TRUE, fixedpars=TRUE),"Data may be inconsistent with transition matrix for model without misclassification:\nindividual 100002 moves from state 2 to state 1 at observation 4") expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.i, gen.inits=TRUE, fixedpars=TRUE),"individual 100046 moves from state 2 to state 1 at observation 225") ## row number reporting with missing data - should be the same cav.wrong$PTNUM[2] <- NA expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = oneway4.q, deathexact = TRUE, fixedpars=TRUE),"100002 moves from state 2 to state 1 at observation 4") cav.wrong <- cav cav.wrong$state[4] <- 1 expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, exacttimes=TRUE, fixedpars=TRUE),"individual 100003 moves from state 1 to state 3 at observation 10") ## row number reporting with missing data cav.wrong$state[3] <- NA expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, exacttimes=TRUE, fixedpars=TRUE),"individual 100003 moves from state 1 to state 3 at observation 10") # should complain about obs 10 obstype <- rep(2, nrow(cav)) obstype[10] <- 1 expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, obstype=obstype, fixedpars=TRUE),"individual 100006 moves from state 1 to state 3 at observation 29") ## absorbing-absorbing transitions cav.wrong$state[6] <- 4 expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, obstype=obstype, fixedpars=TRUE),"Absorbing - absorbing transition at observation 7") }) test_that("error handling: death",{ expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = "foo", fixedpars=TRUE) ,"Death states indicator must be numeric") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = 5, fixedpars=TRUE) ,"Death states indicator contains states not in 1, 2, ... , 4") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = 1:5, fixedpars=TRUE) ,"Death states indicator contains states not in 1, 2, ... , 4") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, deathexact = 3, fixedpars=TRUE),"Not all the \"death\" states are absorbing states" ) }) test_that("error handling: censor",{ expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, censor="rubbish", fixedpars=TRUE),"censor must be numeric") expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, censor=1, fixedpars=TRUE),"some censoring indicators are the same as actual states") expect_warning(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, censor.states="rubbish", fixedpars=TRUE) ,"censor.states supplied but censor not supplied") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.cens, qmatrix = twoway4.q, censor=99, censor.states="rubbish", fixedpars=TRUE) ,"censor.states should be all numeric") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav.cens, qmatrix = twoway4.q, censor=99, censor.states=list(c(1,2,3), "rubbish"), fixedpars=TRUE) ,"censor.states should be a vector") }) test_that("error handling: obstype",{ expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype="rubbish", fixedpars=TRUE) ,"obstype should be numeric") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=c(1,2,3), fixedpars=TRUE) ,"obstype of length 3, should be length 1 or 2846") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=4, fixedpars=TRUE),"elements of obstype should be 1, 2, or 3" ) expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=rep(4,nrow(cav)), fixedpars=TRUE) ,"elements of obstype should be 1, 2, or 3") }) test_that("error handling: fixedpars",{ expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, fixedpars="foo"),"Elements of fixedpars should be in 1, ..., 7") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, fixedpars=list(c(1,3,4))),"Elements of fixedpars should be in 1, ..., 7") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, fixedpars=1:8),"Elements of fixedpars should be in 1, ..., 7") expect_error(cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, fixedpars=0.5),"Elements of fixedpars should be in 1, ..., 7") }) test_that("error handling: plot",{ expect_error(plot.msm("foo"),"expected .+ msm model") expect_error(plot.msm(psor.msm, from="foo"), "from must be numeric") expect_error(plot.msm(psor.msm, to="foo"), "to must be numeric") expect_error(plot.msm(psor.msm, from = 1:8, to=3),"from must be a vector of states in 1, ..., 4") expect_error(plot.msm(psor.msm, to = 3),"to must be an absorbing state") expect_error(plot.msm(psor.msm, range="foo")) expect_error(plot.msm(psor.msm, range=1:6),"range must be a numeric vector of two elements") }) msm/tests/testthat/test_datasumm.r0000755000176200001440000000634412667316467017141 0ustar liggesuserscontext("msm data summaries") test_that("statetable.msm", { stab <- statetable.msm(state, PTNUM, data=cav) expect_that(stab, equals(structure(c(1367L, 46L, 4L, 204L, 134L, 13L, 44L, 54L, 107L, 148L, 48L, 55L), .Dim = 3:4, .Dimnames = structure(list(from = c("1","2", "3"), to = c("1", "2", "3", "4")), .Names = c("from", "to")), class = "table"))) expect_equal(as.numeric(stab), c(1367, 46, 4, 204, 134, 13, 44, 54, 107, 148, 48, 55)) expect_error(statetable.msm(state,PTNUM), "not found") stabc <- statetable.msm(state, PTNUM, cav.cens) expect_equal(as.numeric(stabc), c(1367, 46, 4, 204, 134, 13, 44, 54, 107, 127, 40, 34, 21, 8, 21)) }) test_that("crudeinits.msm", { cinits <- crudeinits.msm(state ~ years, PTNUM, data=cav, qmatrix=twoway4.q) expect_equal(as.numeric(cinits), c(-0.117314905786477, 0.116817878212849, 0, 0, 0.067989320398981, -0.375848825554382, 0.049084006577444, 0, 0, 0.137134030945518, -0.256747111328168, 0, 0.049325585387496, 0.121896916396016, 0.207663104750724, 0)) expect_error(crudeinits.msm(state ~ years, PTNUM, qmatrix=twoway4.q), "not found") }) test_that("crudeinits.msm ignores inconsistent transitions unless exact times", { cav.wrong <- cav; cav.wrong$state[4] <- 1 expect_error(crudeinits.msm(state ~ years, PTNUM, oneway4.q, cav), NA) expect_warning(msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, exacttimes=TRUE, fixedpars=TRUE), "inconsistent with intensity") obstype <- rep(2, nrow(cav)); obstype[10] <- 1 expect_warning(msm(state ~ years, subject=PTNUM, data = cav.wrong, qmatrix = twoway4.q, obstype=obstype, fixedpars=TRUE), "inconsistent with intensity") }) test_that("crudeinits.msm handles NAs", { psor2 <- psor; psor2$ptnum[13:14] <- psor2$months[7:8] <- psor2$state[7:8] <- NA expect_equal(crudeinits.msm(state ~ months, ptnum, data=psor2, qmatrix=psor.q), crudeinits.msm(state ~ months, ptnum, data=psor2[-c(7,8,13,14),], qmatrix=psor.q)) }) test_that("crudeinits.msm handles censoring",{ expect_error(crudeinits.msm(state ~ years, PTNUM, twoway4.q, cav.cens), "elements not in 1, 2") cru <- crudeinits.msm(state~ years, PTNUM, twoway4.q, cav.cens, censor=99) expect_equal(as.numeric(cru), c(-0.111798558088660, 0.122878533946307, 0, 0, 0.0689030388220138, -0.373978146793108, 0.0618112185064827, 0, 0, 0.144248713763056, -0.223471328446514, 0, 0.0428955192666458, 0.106850899083745, 0.161660109940032, 0)) cru <- crudeinits.msm(state~ years, PTNUM, twoway4.q, cav.cens2, censor=c(99,999), censor.states=list(c(1,2,3),c(2,3))) expect_equal(as.numeric(cru), c(-0.107299472349819, 0.134927714425074, 0, 0, 0.0697104852209013, -0.369584609077378, 0.0789635719132074, 0, 0, 0.158393403890305, -0.170075385659216, 0, 0.0375889871289174, 0.0762634907619986, 0.0911118137460085, 0), tol=1e-06) cru <- crudeinits.msm(state~ years, PTNUM, twoway4.q, cav.cens3, censor=c(99,999), censor.states=list(c(2,3),c(1,2,3))) expect_equal(as.numeric(cru), c(-0.112107245394208, 0.124370575094641, 0, 0, 0.0686998668421821, -0.370347934726264, 0.0659650781282531, 0, 0, 0.135425737325276, -0.238489128617530, 0, 0.0434073785520255, 0.110551622306348, 0.172524050489277, 0), tol=1e-06) }) msm/tests/testthat/test_models_hmm.r0000755000176200001440000002417212575520013017427 0ustar liggesuserscontext("Hidden Markov model likelihoods") three.q <- rbind(c(0, exp(-6), exp(-9)), c(0, 0, exp(-6)), c(0, 0, 0)) four.q <- rbind(c(0, exp(-6), 0, exp(-9)), c(0, 0, exp(-6.01), exp(-9)), c(0, 0, 0, exp(-6.02)), c(0, 0, 0, 0)) five.q <- rbind(c(0, exp(-6), 0, 0, exp(-9)), c(0, 0, exp(-6.01), 0, exp(-9)), c(0, 0, 0, exp(-6.02), exp(-6.03)), c(0, 0, 0, 0, exp(-6.04)), c(0, 0, 0, 0, 0)) hmodel3 <- list(hmmNorm(mean=100, sd=16), hmmNorm(mean=54, sd=18), hmmIdent(999)) hmodel4 <- list(hmmNorm(mean=100, sd=16), hmmNorm(mean=72.5, sd=10), hmmNorm(mean=42.5, sd=18), hmmIdent(999)) hmodel5 <- list(hmmNorm(mean=100, sd=16), hmmNorm(mean=72.5, sd=10), hmmNorm(mean=62.5, sd=10), hmmNorm(mean=42.5, sd=18), hmmIdent(999)) test_that("HMM normal likelihoods: FEV data",{ (fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, fixedpars=TRUE)) expect_equal(52388.7381942858, fev3.hid$minus2loglik, tol=1e-06) (fev4.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=four.q, deathexact=4, hmodel=hmodel4, fixedpars=TRUE)) expect_equal(50223.9497625937, fev4.hid$minus2loglik, tol=1e-06) (fev5.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=five.q, deathexact=5, hmodel=hmodel5, fixedpars=TRUE)) expect_equal(49937.9840668066, fev5.hid$minus2loglik, tol=1e-06) }) test_that("HMM with obstrue",{ fev$obstrue <- as.numeric(fev$fev==999) fev$fev2 <- fev$fev; fev$fev2[fev$obstrue==1] <- 3 hmodel32 <- list(hmmNorm(mean=100, sd=16), hmmNorm(mean=54, sd=18), hmmIdent(3)) (fev3.hid <- msm(fev2 ~ days, subject=ptnum, obstrue=obstrue, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel32, fixedpars=TRUE)) expect_equal(52388.7381942858, fev3.hid$minus2loglik, tol=1e-06) fev$obstrue <- "foo" expect_error(fev3.hid <- msm(fev2 ~ days, subject=ptnum, obstrue=obstrue, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel32, fixedpars=TRUE), "obstrue should be logical or numeric") fev$obstrue <- as.numeric(fev$fev==999); fev$obstrue[1] <- 10 expect_error(fev3.hid <- msm(fev2 ~ days, subject=ptnum, obstrue=obstrue, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel32, fixedpars=TRUE), "Interpreting \"obstrue\" as containing true states, but it contains values not in 0,1,...,3") ## can supply true state in obstrue fev$obstrue <- as.numeric(fev$fev==999); fev$obstrue[fev$obstrue==1] <- 3 fev3.hid <- msm(fev2 ~ days, subject=ptnum, obstrue=obstrue, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel32, fixedpars=TRUE) expect_equal(52388.7381942858, fev3.hid$minus2loglik, tol=1e-06) }) test_that("HMM normal likelihoods: FEV data: covariate on outcome",{ (fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, NULL), hconstraint = list(acute = c(1,1)), fixedpars=TRUE, center=FALSE)) expect_equal(52134.2372359988, fev3.hid$minus2loglik, tol=1e-06) (fev4.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=four.q, deathexact=4, hmodel=hmodel4, hcovariates=list(~acute, ~acute, ~acute, NULL), hcovinits = list(-8, -8, -8, NULL), hconstraint = list(acute = c(1,1,1)), fixedpars=TRUE, center=FALSE)) expect_equal(50095.8606697016, fev4.hid$minus2loglik, tol=1e-06) (fev5.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=five.q, deathexact=5, hmodel=hmodel5, hcovariates=list(~acute, ~acute, ~acute, ~acute, NULL), hcovinits = list(-8, -8, -8, -8, NULL), hconstraint = list(acute = c(1,1,1,1)), fixedpars=TRUE, center=FALSE)) expect_equal(49839.1627881087, fev5.hid$minus2loglik, tol=1e-06) }) context("Hidden Markov model error handling") test_that("errors in hmodel",{ ## hmodel with wrong named parameters expect_error( hmodel3 <- list(hmmMETNorm(mean=100, sd=16, splat=8, lower=80, upper=Inf, meanerr=0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999)), "unused argument \\(splat" ) ## hmodel with extra unnamed parameter expect_error( hmodel3 <- list(hmmMETNorm(mean=100, sd=16, sderr=8, lower=80, upper=Inf, meanerr=0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999, 3)), "unused argument \\(3" ) ## hmodel with parameters unnamed, but correct number - OK. hmodel.OK <- list(hmmMETNorm(100, 16, 8, 80, Inf, 0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999)) ## hmodel with too few parameters (named or unnamed) expect_error( hmodel3 <- list(hmmMETNorm(100, 16, 80, Inf), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999)), "Parameter sderr for hmmMETNorm not supplied" ) ### Initial values for certain parameters in wrong ranges. hmodel3 <- list(hmmMETNorm(mean=100, sd=-16, sderr=8, lower=80, upper=Inf, meanerr=0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999)) expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, fixedpars=1:9), "Initial value -16 of parameter \"sd\" outside allowed range") expect_error( hmodel3 <- list(hmmMETNorm(mean=100, sd=16, sderr="splat", lower=80, upper=Inf, meanerr=0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999)), "Expected numeric values" ) expect_error( hmodel3 <- list( hmmBinom(size=0.1, prob=0.5), hmmCat(prob=c(0.1, 0.8, 0.1, 0)), hmmCat(prob=c(0, 0.1, 0.9, 0)), hmmIdent()), "Value of size should be integer") }) test_that("error handling in HMM fits",{ hmodel3 <- list(hmmMETNorm(mean=100, sd=16, sderr=8, lower=80, upper=Inf, meanerr=0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999)) hmodel4 <- list(hmmMETNorm(mean=100, sd=16, sderr=8, lower=80, upper=Inf, meanerr=0), hmmMEUnif(sderr=8, lower=65, upper=80, meanerr=0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=65, meanerr=0), hmmIdent(999)) hmodel5 <- list(hmmMETNorm(mean=100, sd=16, sderr=8, lower=80, upper=Inf, meanerr=0), hmmMEUnif(sderr=8, lower=65, upper=80, meanerr=0), hmmMEUnif(sderr=8, lower=50, upper=65, meanerr=0), hmmMETNorm(mean=42, sd=18, sderr=8, lower=0, upper=50, meanerr=0), hmmIdent(999)) ### Wrong number of states in the hmodel, versus the qmatrix. expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel4, fixedpars=1:9), "hmodel of length 4") ### Rubbish in hmodel list hmodel.rubbish <- list("should be a ", " list of ", "hmodel objects") expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel.rubbish, fixedpars=1:9), "hmodel should be a list of HMM distribution objects") ## Death state wrong (not HMM-specific error, but no harm putting it in this file anyway) expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=10, hmodel=hmodel3, fixedpars=1:9), "Death states indicator contains states not in 1, 2, 3") ## Covariate list of wrong length expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list(~acute, ~acute), hcovinits = list(-8, -8, NULL),), "hcovariates of length 2, expected 3") ## Covariate list has rubbish in it expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list("should be formulae", "rubbish", NULL), hcovinits = list(-8, -8, NULL)), "hcovariates should be a list of formulae or NULLs") ## Covariates not in the data expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list(~acute, ~nonexistent, NULL), hcovinits = list(-8, -8, NULL)), "object .+ not found") ## Covariate inits of wrong length (just warning, ignores) expect_warning(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, -8), fixedpars=TRUE), "Initial values for hidden covariate effects do not match numbers of covariates") ## Rubbish in hcovinits (just warning, ignores) expect_warning(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3,hcovariates=list(~acute, ~acute, NULL), hcovinits = list("fooo", -8, NULL), fixedpars=TRUE), "hcovinits should be numeric") ## hconstraint has unknown parameters expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, NULL), hconstraint = list(nonexistent = c(1,1), acute = c(1,1))), "parameter .+ in hconstraint unknown") ## hconstraint has rubbish in (note character vectors are allowed) expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, NULL), hconstraint = list("rubbish", acute = c(1,1))), "parameter .+ in hconstraint unknown") expect_error(fev3.hid <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel3, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, NULL), hconstraint = list(sderr=c("wrong length"), acute = c(1,1))), "constraint for \"sderr\" of length 1, should be 2") }) msm/tests/testthat/helper.r0000755000176200001440000000301112667777737015545 0ustar liggesuserstwoway4.q <- rbind(c(-0.5, 0.25, 0, 0.25), c(0.166, -0.498, 0.166, 0.166), c(0, 0.25, -0.5, 0.25), c(0, 0, 0, 0)) twoway4.q2 <- rbind(c(-0.51, 0.24, 0, 0.25), c(0.162, -0.498, 0.168, 0.166), c(0, 0.26, -0.5, 0.25), c(0, 0, 0, 0)) twoway3.q <- rbind(c(-0.5, 0.25, 0), c(0.166, -0.498, 0.166), c(0, 0.25, -0.5)) oneway4.q <- rbind(c(0, 0.148, 0, 0.0171), c(0, 0, 0.202, 0.081), c(0, 0, 0, 0.126), c(0, 0, 0, 0)) rownames(twoway4.q) <- colnames(twoway4.q) <- rownames(oneway4.q) <- colnames(oneway4.q) <- c("Well","Mild","Severe","Death") twoway4.i <- twoway4.q; twoway4.i[twoway4.i!=0] <- 1 oneway4.i <- oneway4.q; oneway4.i[oneway4.i!=0] <- 1 psor.q <- rbind(c(0,0.1,0,0),c(0,0,0.1,0),c(0,0,0,0.1),c(0,0,0,0)) fiveq <- rbind(c(0,0.01,0,0,0.002), c(0,0,0.07,0,0.01), c(0,0,0,0.07,0.02), c(0,0,0,0,0.03), c(0,0,0,0,0)) ematrix <- rbind(c(0, 0.1, 0, 0),c(0.1, 0, 0.1, 0),c(0, 0.1, 0, 0),c(0, 0, 0, 0)) rownames(oneway4.q) <- colnames(oneway4.q) <- rownames(ematrix) <- colnames(ematrix) <- c("Well","Mild","Severe","Death") cav.cens <- cav cav.cens$state[cav$state==4][1:50] <- 99 cav.cens2 <- cav cav.cens2$state[cav$state==4][1:50] <- 99 cav.cens2$state[cav$state==4][51:100] <- 999 cav.cens3 <- cav ns <- c(cav$state[2:nrow(cav)], 0) cav.cens3$state[cav$state==4][1:50] <- 99 cav.cens3$state[ns==4][1:50] <- 999 deriv_error <- function(object){ if (!isTRUE(getOption("msm.test.analytic.derivatives"))) stop("msm.test.analytic.derivatives option not set") object$paramdata$deriv.test$error["nd"] } msm/tests/testthat/test_deriv.r0000755000176200001440000002536712667777752016455 0ustar liggesusers## depends on psor.msm context("analytic derivatives of likelihood") test_that("derivatives by subject: sum to overall derivative",{ psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), fixedpars=FALSE) q.mle <- psor.msm$paramdata$opt$par deriv.overall <- deriv.msm(q.mle, expand.data(psor.msm), psor.msm$qmodel, psor.msm$qcmodel, psor.msm$cmodel, psor.msm$hmodel, psor.msm$paramdata) deriv.subj <- Ccall.msm(q.mle, do.what="deriv.subj", expand.data(psor.msm), psor.msm$qmodel, psor.msm$qcmodel, psor.msm$cmodel, psor.msm$hmodel, psor.msm$paramdata) expect_equal(deriv.overall, colSums(deriv.subj)) }) options(msm.test.analytic.derivatives=TRUE) err <- 1e-04 test_that("analytic derivatives match numeric",{ cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, death = TRUE, fixedpars=TRUE) expect_lt(deriv_error(cav.msm), err) cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, death = FALSE, fixedpars=TRUE) expect_lt(deriv_error(cav.msm), err) cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qconstraint = c(1,1,2,2,2,3,3), qmatrix = twoway4.q, death = FALSE, fixedpars=TRUE) expect_lt(deriv_error(cav.msm), err) psor.0.q <- rbind(c(0,0.1,0,0),c(0,0,0.2,0),c(0,0,0,0.3),c(0,0,0,0)) psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.0.q, fixedpars=TRUE) expect_lt(deriv_error(psor.msm), err) psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.0.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), fixedpars=TRUE) expect_lt(deriv_error(psor.msm), err) psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.0.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), death=TRUE, fixedpars=TRUE) expect_lt(deriv_error(psor.msm), err) psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.0.q, covariates = ~ollwsdrt+hieffusn, death=TRUE, fixedpars=TRUE) expect_lt(deriv_error(psor.msm), err) msmtest5 <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, exacttimes=TRUE, fixedpars=TRUE) expect_lt(deriv_error(msmtest5), err) msmtest5 <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, exacttimes=TRUE, qconstraint=c(1,2,1,2,1,2,1), fixedpars=TRUE) expect_lt(deriv_error(msmtest5), err) msmtest5 <- msm(state ~ time, qmatrix = fiveq, covariates = ~time, subject = ptnum, data = bos, exacttimes=TRUE, fixedpars=TRUE) expect_lt(deriv_error(msmtest5), err) msmtest5 <- msm(state ~ time, qmatrix = fiveq, covariates = ~time, constraint=list(time=c(1,2,1,2,1,2,2)), subject = ptnum, data = bos, exacttimes=TRUE, fixedpars=TRUE) expect_lt(deriv_error(msmtest5), err) }) if (0) { ### NOTE: NUMERIC DERIVS BREAK WITH THESE MATRICES when analyticp=TRUE: CLOSE TO REPEATED EIGENVALUES. psor.1.q <- rbind(c(0,0.1,0,0),c(0,0,0.1,0),c(0,0,0,0.1),c(0,0,0,0)) psor.1.q <- rbind(c(0,0.1,0,0),c(0,0,0.10001,0),c(0,0,0,0.1001),c(0,0,0,0)) diag(psor.1.q) <- -rowSums(psor.1.q) psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.1.q, fixedpars=TRUE) psor.msm$paramdata$deriv.test psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.1.q, fixedpars=TRUE, analyticp=FALSE) psor.msm$paramdata$deriv.test psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.1.q, qconstraint=c(1,1,2), fixedpars=TRUE) psor.msm$paramdata$deriv.test psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.1.q, qconstraint=c(1,1,2), fixedpars=TRUE, analyticp=FALSE) psor.msm$paramdata$deriv.test psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.1.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), fixedpars=FALSE, analyticp=TRUE) psor.msm$paramdata$deriv.test psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.1.q, covariates = ~ollwsdrt+hieffusn, constraint = list(hieffusn=c(1,1,1),ollwsdrt=c(1,1,2)), fixedpars=FALSE, analyticp=FALSE) psor.msm$paramdata$deriv.test } context("analytic derivatives of likelihood in HMMs") test.df <- data.frame(time=1:2, obs=c(1,1), x=c(1,2), y=c(3,4)) test_that("Categorical, 2 obs",{ tm <- msm(obs ~ time, qmatrix=rbind(c(0,1,0),c(0,0,0),c(0,0,0)), ematrix=rbind(c(0.8,0.1,0.1),c(0.1,0.9,0),c(0,0,0)), data=test.df, fixedpars=TRUE) expect_lt(deriv_error(tm), err) }) test_that("Categorical, lots of obs ",{ nobs <- 100 test.df <- data.frame(time=1:nobs, obs=sample(c(1,2),size=nobs,replace=TRUE), x=c(1,2), y=c(3,4)) tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), ematrix=rbind(c(0.8,0.2),c(0.9,0.1)), data=test.df, fixedpars=TRUE) expect_lt(deriv_error(tm), err) }) test_that("Categorical, a covariate",{ tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmCat(c(0.8,0.2)),hmmCat(c(0.9,0.1))), hcovariates=list(~x,~1), data=test.df, fixedpars=TRUE) expect_lt(deriv_error(tm), err) }) test_that("Categorical, a covariate on more than one state",{ tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmCat(c(0.8,0.2)),hmmCat(c(0.9,0.1))), hcovariates=list(~x,~x), data=test.df, fixedpars=TRUE) expect_lt(deriv_error(tm), err) }) test_that("Categorical, 4 potential obs",{ tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmCat(c(0.8,0.1,0.05,0.05)),hmmCat(c(0.05,0.9,0.02,0.03))), data=test.df, fixedpars=TRUE) expect_lt(deriv_error(tm), err) }) test_that("Derivatives not supported with misclassification constraints",{ expect_warning(tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), ematrix=rbind(c(0.8,0.2),c(0.9,0.1)), econstraint=c(1,1), data=test.df, fixedpars=TRUE), "Analytic derivatives not available") expect_warning(tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmCat(c(0.8,0.1,0.05,0.05)),hmmCat(c(0.05,0.9,0.02,0.03))), data=test.df, hconstraint=list(p=c(1,1,2,3,4,5)), fixedpars=TRUE), "Analytic derivatives not available") expect_warning(tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmCat(c(0.8,0.1,0.05,0.05)),hmmCat(c(0.05,0.9,0.02,0.03))), data=test.df, hcovariates=list(~x+y,~x+y), hconstraint=list(p=c(1,1,2,3,4,5),x=c(1,2,2,3,4,5),y=c(1,2,3,3,3,3)), fixedpars=TRUE), "Analytic derivatives not available") expect_warning(tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmCat(c(0.8,0.2)),hmmCat(c(0.9,0.1))), hcovariates=list(~x,~x), hconstraint=list(x=c(1,1)), data=test.df, fixedpars=TRUE), "Analytic derivatives not available") }) test_that("Derivatives with CAV misclassification model",{ misc.msm <- msm(state ~ years, subject = PTNUM, data = cav[1:200,], qmatrix = oneway4.q, ematrix=ematrix, misccovariates = ~dage + sex, covariates = ~ dage, covinits = list(dage=c(0.1,0.2,0.3,0.4,0.5)), misccovinits = list(dage=c(0.01,0.02,0.03,0.04), sex=c(-0.013,-0.014,-0.015,-0.016)), fixedpars=TRUE) expect_lt(deriv_error(misc.msm), err) misc.msm <- msm(state ~ years, subject = PTNUM, data = cav[1:2,], qmatrix = oneway4.q, ematrix=ematrix, fixedpars=TRUE) expect_lt(deriv_error(misc.msm), err) misc.msm <- msm(state ~ years, subject = PTNUM, data = cav[1:2,], qmatrix = rbind(c(0,0.5,0),c(0,0,0.5),c(0,0,0)), hmodel=list(hmmCat(c(0.9,0.1,0)), hmmCat(c(0.1,0.8,0.1)), hmmCat(c(0,0.1,0.9))), fixedpars=TRUE) expect_lt(deriv_error(misc.msm), err) }) ## others in slow/test_fits_hmm.r test_that("simple exponential",{ nobs <- 3 test.df <- data.frame(time=1:nobs, obs=c(rexp(nobs,c(sample(c(1,2),size=nobs,replace=TRUE))))) tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmExp(1.5),hmmExp(2)), data=test.df, fixedpars=TRUE) expect_lt(deriv_error(tm), err) }) test_that("Information matrix",{ nobs <- 1000 set.seed(1) test.df <- data.frame(time=1:nobs, obs=sample(c(1,2),size=nobs,replace=TRUE)) p1 <- 0.2; p2 <- 0.2; pr1 <- c(1-p1, p1) # P obs(1,2) | true 1 pr2 <- c(p2, 1-p2) # P obs(1,2) | true 2 (tm <- msm(obs ~ time, qmatrix=rbind(c(0,1),c(0,0)), hmodel=list(hmmCat(pr1),hmmCat(pr2)), data=test.df, fixedpars=TRUE, hessian=TRUE)) expect_equal(c(0.88475550512612, 0.202501688704573, -0.474183198550202), tm$paramdata$info[1:3], tol=1e-05) tm$paramdata$opt$hessian }) set.seed(22061976) nsubj <- 100; nobspt <- 6 sim.df <- data.frame(subject = rep(1:nsubj, each=nobspt), time = seq(0, 20, length=nobspt), x = rnorm(nsubj*nobspt), y = rnorm(nsubj*nobspt)* 5 + 20) three.q <- rbind(c(0, exp(-6), exp(-9)), c(0, 0, exp(-6)), c(0, 0, 0)) set.seed(22061976) nsubj <- 100; nobspt <- 6 sim.df <- data.frame(subject = rep(1:nsubj, each=nobspt), time = seq(0, 20, length=nobspt), x = rnorm(nsubj*nobspt), y = rnorm(nsubj*nobspt)* 5 + 20) test_that("poisson",{ hmodel3 <- list(hmmPois(6), hmmPois(12), hmmIdent(999)) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, hmodel = hmodel3) sim.hid <- msm(obs ~ time, subject=subject, data=sim2.df, qmatrix=three.q, hmodel=hmodel3, fixedpars=TRUE) expect_lt(deriv_error(sim.hid), err) }) test_that("binomial",{ hmodel3 <- list(hmmBinom(10, 0.1), hmmBinom(20, 0.3), hmmIdent(999)) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, hmodel = hmodel3) sim.hid <- msm(obs ~ time, subject=subject, data=sim2.df, qmatrix=three.q, hmodel=hmodel3, fixedpars=TRUE) expect_lt(deriv_error(sim.hid), err) }) test_that("negative binomial",{ hmodel3 <- list(hmmNBinom(10, 0.1), hmmNBinom(20, 0.3), hmmIdent(999)) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, hmodel = hmodel3) sim.hid <- msm(obs ~ time, subject=subject, data=sim2.df, qmatrix=three.q, hmodel=hmodel3, fixedpars=TRUE) expect_lt(deriv_error(sim.hid), err) }) test_that("beta",{ ### some kind of underflow with about 200 obs or more. big derivs, prob poorly identified model hmodel3 <- list(hmmBeta(0.5,0.5), hmmBeta(2, 2), hmmIdent(999)) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, hmodel = hmodel3) sim.hid <- msm(obs ~ time, subject=subject, data=sim2.df[1:100,], qmatrix=three.q, hmodel=hmodel3, fixedpars=TRUE) expect_lt(deriv_error(sim.hid), err) }) test_that("t",{ hmodel3 <- list(hmmT(1, 2, 2), hmmT(4, 2, 3), hmmIdent(999)) sim2.df <- simmulti.msm(sim.df[,1:2], qmatrix=three.q, hmodel = hmodel3) sim.hid <- msm(obs ~ time, subject=subject, data=sim2.df[1:100,], qmatrix=three.q, hmodel=hmodel3, fixedpars=TRUE) expect_lt(deriv_error(sim.hid), err) }) options(msm.test.analytic.derivatives=NULL) msm/src/0000755000176200001440000000000012774212430011637 5ustar liggesusersmsm/src/hmm.c0000755000176200001440000000734112774212430012574 0ustar liggesusers#include "hmm.h" #include #include "msm.h" /* Response (emission) functions for hidden Markov models (probability of outcome conditionally on the hidden state). All of the form double f(double x, double *pars) */ /* Categorical distribution on the set (1, 2, 3, ..., pars[0]), Baseline category is given by pars[1] (not used any more, to delete?) Probabilities are defined by pars[2], ... pars[ncats+1] NEW IMPLEMENTATION in v1.3 pars[2],pars[3]... are absolute probs. covariates applied in R. used to be relative with covariates applied in C. */ double hmmCat(double x, double *pars) { int cat = fprec(x, 0); int ncats = fprec(pars[0], 0); if ((cat > ncats) || (cat < 1)) return 0; return pars[1 + cat]; } double hmmIdent(double x, double *pars) { return all_equal(x, pars[0]); } double hmmUnif(double x, double *pars) { double lower = pars[0], upper = pars[1]; return dunif(x, lower, upper, 0); } double hmmNorm(double x, double *pars) { double mean = pars[0], sd = pars[1]; return dnorm(x, mean, sd, 0); } double hmmLNorm(double x, double *pars) { double meanlog = pars[0], sdlog = pars[1]; return dlnorm(x, meanlog, sdlog, 0); } double hmmExp(double x, double *pars) { double mean = 1 / pars[0]; return dexp(x, mean, 0); } double hmmGamma(double x, double *pars) { double shape = pars[0], scale = 1 / pars[1]; return dgamma(x, shape, scale, 0); } double hmmWeibull(double x, double *pars) { double shape = pars[0], scale = pars[1]; return dweibull(x, shape, scale, 0); } double hmmPois(double x, double *pars) { double lambda = pars[0]; return dpois(x, lambda, 0); } double hmmBinom(double x, double *pars) { double size = pars[0], prob = pars[1]; return dbinom(x, size, prob, 0); } /* Truncated normal distribution. Infinite bounds are allowed through a parameter with a value of "Inf" or "-Inf" passed from R */ double hmmTNorm(double x, double *pars) { double mean = pars[0], sd = pars[1], lower = pars[2], upper = pars[3]; double denom = pnorm(upper, mean, sd, 1, 0) - pnorm(lower, mean, sd, 1, 0); if (x < lower) return 0; if (x > upper) return 0; return dnorm(x, mean, sd, 0) / denom; } /* Satten and Longini's truncated normal distribution with normal measurement error */ /* To parameterise so covariates go on observation: Put in a dummy parameter meanerr = 0 for the measurement error model xobs ~ N(xhid + meanerr, sderr), then covs go on meanerr. */ double hmmMETNorm(double x, double *pars) { double mean = pars[0], sd = pars[1], lower = pars[2], upper = pars[3], sderr = pars[4], meanerr = pars[5]; double sumsq = sd*sd + sderr*sderr; double sigtmp = sd*sderr / sqrt(sumsq); double mutmp = ((x - meanerr)*sd*sd + mean*sderr*sderr) / sumsq; double nc = 1/(pnorm(upper, mean, sd, 1, 0) - pnorm(lower, mean, sd, 1, 0)); double nctmp = pnorm(upper, mutmp, sigtmp, 1, 0) - pnorm(lower, mutmp, sigtmp, 1, 0); return nc * nctmp * dnorm(x, meanerr + mean, sqrt(sumsq), 0); } /* Satten and Longini's uniform distribution with normal measurement error */ double hmmMEUnif(double x, double *pars) { double lower = pars[0], upper = pars[1], sderr = pars[2], meanerr = pars[3]; return ( pnorm(x, meanerr + lower, sderr, 1, 0) - pnorm(x, meanerr + upper, sderr, 1, 0) ) / (upper - lower) ; } double hmmNBinom(double x, double *pars) { double size = pars[0], prob = pars[1]; return dnbinom(x, size, prob, 0); } double hmmBeta(double x, double *pars) { double shape1 = pars[0], shape2 = pars[1]; return dbeta(x, shape1, shape2, 0); } double hmmT(double x, double *pars) { double tmean = pars[0], tscale = pars[1], tdf=pars[2]; return (1/tscale)*dt((x-tmean)/tscale, tdf, 0); } msm/src/Makevars0000755000176200001440000000006112774212430013333 0ustar liggesusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) msm/src/lik.c0000755000176200001440000015366712774212430012607 0ustar liggesusers/* ***************************************************************** PROGRAM: lik.c AUTHOR: Chris Jackson DATE: July 2004 Routines for calculating likelihoods for multi-state Markov and hidden Markov models. ****************************************************************** */ #include "msm.h" #include "hmm.h" #include #include #define NODEBUG #define NOVITDEBUG0 #define NOVITDEBUG #define NODERIVDEBUG /* MUST KEEP THIS IN SAME ORDER AS .msm.HMODELPARS IN R/constants.R */ hmmfn HMODELS[] = { hmmCat, hmmIdent, hmmUnif, hmmNorm, hmmLNorm, hmmExp, hmmGamma, hmmWeibull, hmmPois, hmmBinom, hmmTNorm, hmmMETNorm, hmmMEUnif, hmmNBinom, hmmBeta, hmmT }; /* MUST KEEP THIS IN SAME ORDER AS .msm.HMODELPARS IN R/constants.R */ dhmmfn DHMODELS[] = { DhmmCat, DhmmIdent, DhmmUnif, DhmmNorm, DhmmLNorm, DhmmExp, DhmmGamma, DhmmWeibull, DhmmPois, DhmmBinom, DhmmTNorm, DhmmMETNorm, DhmmMEUnif, DhmmNBinom, DhmmBeta, DhmmT }; /* MUST MATCH order of .msm.CTASKS in R/constants.R */ #define DO_LIK 0 #define DO_DERIV 1 #define DO_INFO 2 #define DO_VITERBI 3 #define DO_LIK_SUBJ 4 #define DO_DERIV_SUBJ 5 #define DO_DPMAT 6 #define OBS_SNAPSHOT 1 #define OBS_PANEL 1 /* preferred term now */ #define OBS_EXACT 2 #define OBS_DEATH 3 double logit(double x) { return log(x / (1 - x)); } double expit(double x) { return exp(x) / ( 1 + exp(x) ); } double identity(double x) { return x; } /* Good-enough floating point equality comparison */ int all_equal(double x, double y) { return fabs (x - y) <= DBL_EPSILON * fabs(x); } /* For models with censoring: */ /* Return a vector of the nc possible true states that a censored state could represent */ /* These will be summed over when calculating the likelihood */ /* Compare one-indexed obs against one-indexed cm->censor. Return one-indexed current (*states) */ void GetCensored (double obs, cmodel *cm, int *nc, double **states) { int j, k=0, n, cens=0; if (cm->ncens == 0) n = 1; else { while ((k < cm->ncens) && !all_equal(obs, cm->censor[k])){ ++k; } if (k < cm->ncens) { cens = 1; n = cm->index[k+1] - cm->index[k]; } else n = 1; } if (cm->ncens == 0 || !cens) (*states)[0] = obs; else { for (j = cm->index[k]; j < cm->index[k+1]; ++j) (*states)[j - cm->index[k]] = cm->states[j]; } *nc = n; } /* Calculate p (obs curr | true i) for hidden Markov or censoring models If observation is not necessarily of the true state (!obstrue), then this is just the HMM outcome probability (summed over censor set if necessary) If obstrue (observation not misclassified) or censored state. e.g. censor set 1,2,3, state set 1,2,3,4, pout = if i in curr 1, else 0 */ /* TODO does find_exactdeath_hmm need updating for multivariate observations with different models ? */ /* New obstrue facility On entry, obstrue will contain 0 if state unknown, and state if state known But how do we know if there are any extra outcome data in the outcome variable? If this is NA, we can ignore it but still use obstrue (TODO put in na.find.msmdata) If this is a state (eg in misc models) prob of observing it cond on true state is 1. If this is a general outcome, get prob of observing it from HMODELS */ void GetOutcomeProb(double *pout, double *outcome, int nc, int nout, double *hpars, hmodel *hm, qmodel *qm, int obstrue) { int i, j, k, ind; for (i=0; inst; ++i) { if (hm->hidden && (obstrue==0)) { /* HMMs with true state not known */ if (nout > 1) { /* multivariate outcomes. Censored states not supported */ pout[i] = 1; for (k=0; kmv ? MI(k,i,nout) : /* different models for different variables */ i); /* same model for all */ if (!ISNA(outcome[k]) && !ISNA(hm->models[ind])){ pout[i] *= ((HMODELS[hm->models[ind]])(outcome[k], &(hpars[hm->firstpar[ind]]))); } } } else { /* Standard univariate HMM (with or without censored state) */ pout[i] = 0; for (j=0; jmodels[i]])(outcome[j], &(hpars[hm->firstpar[i]])); } } } else { /* True state is known at this time, and appears here as "obstrue" */ if (nout > 1){ pout[i] = 0; if (obstrue == i+1){ /* "state" data contain an actual observation. get its distribution here conditional on the supplied true state */ pout[i] = 1; for (k=0; kmv ? MI(k,i,nout) : i); if (!ISNA(outcome[k]) && !ISNA(hm->models[ind])){ pout[i] *= ((HMODELS[hm->models[ind]])(outcome[k], &(hpars[hm->firstpar[ind]]))); } } } } else { pout[i] = 0; if (hm->hidden && nc == 1 && !hm->ematrix){ /* "state" data contain an actual observation. get its distribution here conditional on the supplied true state */ if (obstrue == i+1){ pout[i] = (HMODELS[hm->models[i]])(outcome[0], &(hpars[hm->firstpar[i]])); } } else { /* "state" data contain the true state (for hm->ematrix with obstrue) or censor indicator */ for (j=0; jdpars, calculated in R msm.form.dh) We assume there's only one of these (true for standard dists with one location parameter, and for categorical outcome where f(x) depends on only one pr for a given x. */ void GetDOutcomeProb(double *dpout, /* qm->nst x hm->nopt */ double *outcome, int nc, int nout, double *hpars, hmodel *hm, qmodel *qm, int obsno, int obstrue) { int i, j, k, l, r, s, ind; int p=0; /* indexes parameters up to totpars */ double *pout, *dptmp = Calloc(hm->totpars, double); /* will only use hm->npars[i] slots for each i */ #ifdef DERIVDEBUG printf("GetDOutcomeProb:\n"); #endif for (i=0; inst; ++i) { for (l=0; lnopt; ++l) dpout[MI(i,l,qm->nst)] = 0; if (hm->hidden && (!obstrue || (obstrue==(i+1) && !hm->ematrix))) { if (nout > 1) { /* multivariate outcomes. Censored states not supported TODO. This is fiddlier than first thought. not considered what hm->dpars should be, particularly with constraints */ pout = Calloc(nout, double); for (r=0; rmv ? MI(r,i,nout) : i); if (!ISNA(outcome[r]) && !ISNA(hm->models[ind])){ pout[r] = ((HMODELS[hm->models[ind]])(outcome[r], &(hpars[hm->firstpar[ind]]))); } } for (r=0; rmv ? MI(r,i,nout) : i); if (!ISNA(outcome[r]) && !ISNA(hm->models[ind])){ (DHMODELS[hm->models[ind]])(outcome[r], &(hpars[hm->firstpar[ind]]), dptmp); for (k=0; knpars[ind]; ++k){ for (s=0; snopt; ++l){ dpout[MI(i,l,qm->nst)] += dptmp[k] * hm->dpars[MI3(p+k,l,obsno,hm->totpars,hm->nopt)]; #ifdef DERIVDEBUG printf("dpars[%d,%d]=%.2f,", p+k, l, hm->dpars[MI3(p+k,l,obsno,hm->totpars,hm->nopt)]); #endif } #ifdef DERIVDEBUG printf("\n"); #endif #ifdef DERIVDEBUG printf("MI=%d,hm=%d,fp=%d,hp=%f,outcome=%2.0f,dptmp=%f\n", ind,hm->models[ind], hm->firstpar[ind], hpars[hm->firstpar[ind]+1], outcome[r],dptmp[k]); #endif } #ifdef DERIVDEBUG for (l=0; lnopt; ++l) printf("dpout[%d,%d]=%f,",i,l,dpout[MI(i,l,qm->nst)]); printf("\n"); #endif } if (hm->mv) p += hm->npars[ind]; } if (!hm->mv) p += hm->npars[i]; Free(pout); } else { for (j=0; jmodels[i]])(outcome[j], &(hpars[hm->firstpar[i]]), dptmp); for (k=0; knpars[i]; ++k){ for (l=0; lnopt; ++l){ dpout[MI(i,l,qm->nst)] += dptmp[k] * hm->dpars[MI3(p+k,l,obsno,hm->totpars,hm->nopt)]; } } } p += hm->npars[i]; } } else { for (l=0; lnopt; ++l) dpout[MI(i,l,qm->nst)] = 0; if (nout > 1 && hm->mv) for (r=0; rnpars[MI(r,i,nout)]; else p += hm->npars[i]; } } Free(dptmp); } void normalize(double *in, double *out, int n, double *lweight) { int i; double ave; for (i=0, ave=0; inpcombs, int); for (i=0; inpcombs; ++i) comb_done[i] = 0; for (pt = 0; pt < d->npts; ++pt){ for (i = d->firstobs[pt]+1; i <= d->firstobs[pt+1] - 1; ++i) { c = d->pcomb[i]; if (!comb_done[c]) { qmat = &(qm->intens[MI3(0, 0, i-1, qm->nst, qm->nst)]); Pmat(&pmat[MI3(0, 0, c, qm->nst, qm->nst)], d->time[i] - d->time[i-1], qmat, qm->nst, (d->obstype[i] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); comb_done[c] = 1; } } } Free(comb_done); } void calc_dp(msmdata *d, qmodel *qm, double *dpmat) { double *qmat, *dqmat; int pt, i, c, np=qm->nopt; // int r,s,p; int *comb_done = Calloc(d->npcombs, int); for (i=0; inpcombs; ++i) comb_done[i] = 0; for (pt = 0; pt < d->npts; ++pt){ for (i = d->firstobs[pt]+1; i <= d->firstobs[pt+1] - 1; ++i) { c = d->pcomb[i]; if (!comb_done[c]) { qmat = &(qm->intens[MI3(0, 0, i-1, qm->nst, qm->nst)]); dqmat = &(qm->dintens[MI4(0, 0, 0, i-1, qm->nst, qm->nst, np)]); /* dpmat is nst*nst*np*npcombs, leftmost index varies fastest and DPmat returns nst*nst*np */ DPmat(&dpmat[MI4(0, 0, 0, c, qm->nst, qm->nst, np)], d->time[i] - d->time[i-1], dqmat, qmat, qm->nst, np, (d->obstype[i] == OBS_EXACT)); // printf("calc_dp: i=%d,c=%d,r=%d,s=%d,p=%d,dp=%f\n",i,1,0,1,0,dpmat[MI4(0, 1, 0, 1, qm->nst, qm->nst, np)]); comb_done[c] = 1; } } } Free(comb_done); } /* Find the true state that observation with an exact death time * represents in a HMM. This should be the state with outcome model * hmmIdent(obs). This function also works for non-HMM censoring * models, just returning the observed state. */ int find_exactdeath_hmm(double *outcome, int obsno, msmdata *d, qmodel *qm, hmodel *hm){ int ideath; double *hpars = &(hm->pars[MI(0, obsno, hm->totpars)]); if (!hm->hidden || d->obstrue[obsno]) ideath = outcome[0] - 1; else for (ideath=0; ideath < qm->nst; ++ideath) if (hm->models[ideath] == 1 && hmmIdent(outcome[0], &(hpars[hm->firstpar[ideath]]))) break; return ideath; } /* Post-multiply the row-vector cump by matrix T to accumulate the likelihood */ void update_likhidden(double *outcome, int nc, int obsno, msmdata *d, qmodel *qm, hmodel *hm, double *cump, double *newp, double *lweight, Array3 pmat) { int i, j, ideath=0; double T, *pout = Calloc(qm->nst, double); double *qmat = &(qm->intens[MI3(0, 0, obsno-1, qm->nst, qm->nst)]); double *hpars = &(hm->pars[MI(0, obsno, hm->totpars)]); GetOutcomeProb(pout, outcome, nc, d->nout, hpars, hm, qm, d->obstrue[obsno]); if (d->obstype[obsno] == OBS_DEATH) ideath = find_exactdeath_hmm(outcome, obsno, d, qm, hm); for(j = 0; j < qm->nst; ++j) { newp[j] = 0.0; for(i = 0; i < qm->nst; ++i) { if (d->obstype[obsno] == OBS_DEATH) T = pmat[MI(i,j,qm->nst)] * qmat[MI(j,ideath,qm->nst)]; else { T = pmat[MI(i, j, qm->nst)] * pout[j]; // printf("pmat[%d,%d]=%16.12lf,pout[%d]=%16.12lf\n,", i, j, pmat[MI(i, j, qm->nst)], j, pout[j]); } if (T < 0) T = 0; newp[j] = newp[j] + cump[i]*T; } } /* re-scale the likelihood at each step to prevent it getting too small and underflowing */ /* while cumulatively recording the log scale factor */ normalize (newp, cump, qm->nst, lweight); Free(pout); } /* Likelihood for the hidden Markov model for one individual */ double likhidden(int pt, /* ordinal subject ID */ msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, Array3 pmat) { double *curr = Calloc (qm->nst, double); double *cump = Calloc(qm->nst, double); double *newp = Calloc(qm->nst, double); double *pout = Calloc(qm->nst, double); double lweight, lik, *hpars, *outcome; int i, obsno, nc=1, allzero=1; if (d->firstobs[pt] + 1 == d->firstobs[pt+1]) return 0; /* individual has only one observation. Shouldn't happen since 1.3.2 */ /* Likelihood for individual's first observation */ hpars = &(hm->pars[MI(0, d->firstobs[pt], hm->totpars)]); if (d->nout > 1) outcome = &d->obs[MI(0, d->firstobs[pt], d->nout)]; else { /* TODO these four lines or similar are pasted a few times */ GetCensored((double)d->obs[d->firstobs[pt]], cm, &nc, &curr); outcome = curr; } GetOutcomeProb(pout, outcome, nc, d->nout, hpars, hm, qm, d->obstrue[d->firstobs[pt]]); /* Likelihood contribution for initial observation */ // printf("\nlikhidden:\n"); for (i = 0; i < qm->nst; ++i) { cump[i] = pout[i]; // printf("pout[%d]=%.4f\n",i,pout[i]); /* Ignore initprobs if observation is known to be the true state or TODO, can we set it in R to one for obs state, zero for others? */ if (!d->obstrue[d->firstobs[pt]]) cump[i] = cump[i]*hm->initp[MI(pt,i,d->npts)]; if (!all_equal(cump[i], 0)) allzero = 0; } if (allzero && (qm->nliks==1)) { warning("First observation of %f for subject number %d out of %d is impossible for given initial state probabilities and outcome model\n", curr[0], pt+1, d->npts); } lweight=0; /* Matrix product loop to accumulate the likelihood for subsequent observations */ for (obsno = d->firstobs[pt]+1; obsno <= d->firstobs[pt+1] - 1; ++obsno) { R_CheckUserInterrupt(); if (d->nout > 1) outcome = &d->obs[MI(0, obsno, d->nout)]; else { GetCensored((double)d->obs[obsno], cm, &nc, &curr); outcome = curr; } update_likhidden(outcome, nc, obsno, d, qm, hm, cump, newp, &lweight, &pmat[MI3(0,0,d->pcomb[obsno],qm->nst,qm->nst)]); } for (i = 0, lik = 0; i < qm->nst; ++i) { lik = lik + cump[i]; } Free(curr); Free(cump); Free(newp); Free(pout); /* Transform the likelihood back to the proper scale */ return -2*(log(lik) - lweight); } /* DERIVATIVES FOR HMM using notation from Titman (Lifetime Data Analysis 2009) */ /* Lik and deriv at first obs */ /* Don't support random initprobs for the moment */ void init_hmm_deriv(double *curr, int nc, int pt, int obsno, double *hpars, double *a, double *phi, double *xi, double *dxi, msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *pok, double *dpok) { int i, j, p, n=qm->nst, nqp=qm->nopt, nhp = hm->nopt, np = nqp + nhp; double suma, sumphi; double *pout = Calloc(n, double); double *dpout = Calloc(n * nhp, double); int cens_not_hmm = (cm->ncens > 0 && !hm->hidden); GetOutcomeProb(pout, curr, nc, d->nout, hpars, hm, qm, d->obstrue[obsno]); GetDOutcomeProb(dpout, curr, nc, d->nout, hpars, hm, qm, obsno, d->obstrue[obsno]); for (p=0; pinitp[MI(pt,i,d->npts)] * pout[i]); #ifdef DERIVDEBUG printf("i=%d,initp=%f,pout=%f,a=%f\n", i, hm->initp[MI(pt,i,d->npts)], pout[i], a[i]); #endif suma += a[i]; } /* printf("\n"); */ *pok = (cens_not_hmm ? 1 : suma); for (i = 0; i < n; ++i) xi[i] = a[i] / (*pok); for (p=0; pinitp[MI(pt,i,d->npts)] * dpout[MI(i,p,n)]); #ifdef DERIVDEBUG printf("p=%d,i=%d,initp=%f,dpout=%f,phi=%f\n", p, i, hm->initp[MI(pt,i,d->npts)], dpout[MI(i,p,n)], phi[MI(i,nqp+p,n)]); #endif dpok[nqp+p] += phi[MI(i,nqp+p,n)]; } } for (p=0; pnst, nqp=qm->nopt, nhp = hm->nopt, np = nqp + nhp, ideath=0; double qs=0, suma, sumphi, ptrans, dptrans, dqs, dhp; double *pout = Calloc(n, double); double *dpout = Calloc(n * nhp, double); GetOutcomeProb(pout, curr, nc, d->nout, hpars, hm, qm, d->obstrue[obsno]); GetDOutcomeProb(dpout, curr, nc, d->nout, hpars, hm, qm, obsno, d->obstrue[obsno]); if (d->obstype[obsno] == OBS_DEATH) ideath = find_exactdeath_hmm(curr, obsno, d, qm, hm); #ifdef DERIVDEBUG printf("update_hmm_deriv:\n"); #endif for (i=0; iobstype[obsno] == OBS_DEATH) qs = qmat[MI(i,ideath,n)]; for (p=0; ppcomb[obsno], n,n)]; if (d->obstype[obsno] == OBS_DEATH) anew[i] += aold[j] * ptrans * qs; else anew[i] += aold[j] * ptrans * pout[i]; /* typo here in Titman (2009) */ for (p=0; ppcomb[obsno], n, n, nqp)] : 0); dhp = (pobstype[obsno] == OBS_DEATH){ dqs = (pobstype[obsno] == OBS_DEATH){ qs = qmat[MI(s,ideath,n)]; #ifdef DERIVDEBUG printf("s=%d,ideath=%d,MI=%d,qs=%f\n",s,ideath,MI(s,ideath,n),qs); #endif } ptrans = pmat[MI3(j, s, d->pcomb[obsno], n,n)]; if (d->obstype[obsno] == OBS_DEATH) *pok += xiold[j] * ptrans * qs; else *pok += xiold[j] * ptrans * pout[s]; for (p=0; ppcomb[obsno], n, n, nqp)] : 0); dhp = (pobstype[obsno] == OBS_DEATH){ dqs = (pnst, nqp=qm->nopt, nhp = hm->nopt, np = nqp + nhp; double lp, pok; double *curr = Calloc (n, double); int nobspt = d->firstobs[pt+1] - d->firstobs[pt]; double *anew = Calloc(n, double); /* alpha_k(i) = P(X(t_k) = i, o_1, ..., o_k), X is true, O is obs */ double *aold = Calloc(n, double); double *phinew = Calloc(n * np, double); /* phi_k(theta_m, i) = deriv of alpha wrt theta_m. */ double *phiold = Calloc(n * np, double); double *xinew = Calloc(n, double); /* xi(k,i) = P(x(k-1) = i | o_1, ..., o_(k-1)) */ double *xiold = Calloc(n, double); double *dxinew = Calloc(n * np, double); double *dxiold = Calloc(n * np, double); double *dpok = Calloc(np, double); double *qmat, *dqmat, *hpars=NULL, *outcome=NULL; if (hm->hidden) hpars = &(hm->pars[MI(0, d->firstobs[pt], hm->totpars)]); if (d->nout > 1) outcome = &d->obs[MI(0, d->firstobs[pt], d->nout)]; else { GetCensored((double)d->obs[d->firstobs[pt]], cm, &nc, &curr); outcome = curr; } // Get lik and deriv at first obs init_hmm_deriv(outcome, nc, pt, d->firstobs[pt], hpars, aold, phiold, xiold, dxiold, d, qm, cm, hm, &pok, dpok); lp = log(pok); /* for (i=0;inout;++i) printf("outcome[%d]=%f,",i,outcome[i]); printf("\n"); */ #ifdef DERIVDEBUG printf("hmm_deriv:\n"); #endif for (p=0; pfirstobs[pt] + k; qmat = &(qm->intens[MI3(0, 0, obsno-1, n, n)]); dqmat = &(qm->dintens[MI4(0, 0, 0, obsno - 1, n, n, nqp)]); hpars = &(hm->pars[MI(0, obsno, hm->totpars)]); if (d->nout > 1) outcome = &d->obs[MI(0, obsno, d->nout)]; else { GetCensored((double)d->obs[obsno], cm, &nc, &curr); outcome = curr; } update_hmm_deriv(outcome, nc, obsno, pmat, dpmat, qmat, dqmat, hpars, aold, phiold, xiold, dxiold, anew, phinew, xinew, dxinew, d, qm, hm, &pok, dpok); for (i=0; inst, nqp=qm->nopt, nhp = hm->nopt, np = nqp + nhp; double pok; double *curr = Calloc (n, double); double *potential = Calloc (n, double); int nobspt = d->firstobs[pt+1] - d->firstobs[pt]; double *anew = Calloc(n, double); /* alpha_k(i) = P(X(t_k) = i, o_1, ..., o_k), X is true, O is obs */ double *aold = Calloc(n, double); double *phinew = Calloc(n * np, double); /* phi_k(theta_m, i) = deriv of alpha wrt theta_m. */ double *phiold = Calloc(n * np, double); double *xinew = Calloc(n, double); /* xi(k,i) = P(x(k-1) = i | o_1, ..., o_(k-1)) */ double *xiold = Calloc(n, double); double *dxinew = Calloc(n * np, double); double *dxiold = Calloc(n * np, double); double *dpok = Calloc(np, double); double *qmat, *dqmat, *hpars=NULL, *outcome; if (hm->hidden) hpars = &(hm->pars[MI(0, d->firstobs[pt], hm->totpars)]); for (p=0; pfirstobs[pt], hpars, anew, phinew, xinew, dxinew, // discard, not used for updating d, qm, cm, hm, &pok, dpok); for (p=0; p 0) info[MI(q,p,np)] += dpok[p]*dpok[q] / pok; // printf("k=0,j=%d,dpok[%d]=%f,dpok[%d]=%f,pok=%f,info=%f\n",j,p,dpok[p],q,dpok[q],pok,info[MI(q,p,np)]); } } if (d->nout > 1) outcome = &d->obs[MI(0, d->firstobs[pt], d->nout)]; else { GetCensored((double)d->obs[d->firstobs[pt]], cm, &nc, &curr); outcome = curr; } init_hmm_deriv(outcome, nc, pt, d->firstobs[pt], hpars, aold, phiold, xiold, dxiold, // use actual observation to update these d, qm, cm, hm, &pok, dpok); // Subsequent observations, using forward algorithm for (k=1; kfirstobs[pt] + k; if (d->obstype[obsno] != OBS_PANEL) error("Fisher information only available for panel data\n"); qmat = &(qm->intens[MI3(0, 0, obsno-1, n, n)]); dqmat = &(qm->dintens[MI4(0, 0, 0, obsno - 1, n, n, nqp)]); hpars = &(hm->pars[MI(0, obsno, hm->totpars)]); for (j=0; j 0) info[MI(q,p,np)] += dpok[p]*dpok[q] / pok; // printf("k=%d,j=%d,dpok[%d]=%f,dpok[%d]=%f,pok=%f,info=%f\n",k,j,p,dpok[p],q,dpok[q],pok,info[MI(q,p,np)]); } } if (d->nout > 1) outcome = &d->obs[MI(0, obsno, d->nout)]; else { GetCensored((double)d->obs[obsno], cm, &nc, &curr); // update using observed data outcome = curr; } update_hmm_deriv(outcome, nc, obsno, pmat, dpmat, qmat, dqmat, hpars, aold, phiold, xiold, dxiold, anew, phinew, xinew, dxinew, d, qm, hm, &pok, dpok); for (i=0; iintens[MI3(0, 0, obsno-1, qm->nst, qm->nst)]); double contrib; int i, j, k; for(i = 0; i < nc; ++i) { newp[i] = 0.0; for(j = 0; j < np; ++j) { if (d->obstype[obsno] == OBS_DEATH) { contrib = 0; for (k = 0; k < qm->nst; ++k) if (k != curr[i]-1) contrib += pmat[MI((int) prev[j]-1, k, qm->nst)] * qmat[MI(k, (int) curr[i]-1, qm->nst)]; newp[i] += cump[j] * contrib; } else { newp[i] += cump[j] * pmat[MI((int) prev[j]-1, (int) curr[i]-1, qm->nst)]; } } } normalize(newp, cump, nc, lweight); } double likcensor(int pt, /* ordinal subject ID */ msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, Array3 pmat ) { double *cump = Calloc(qm->nst, double); double *newp = Calloc(qm->nst, double); double *prev = Calloc(qm->nst, double); double *curr = Calloc(qm->nst, double); double lweight = 0, lik; int i, obs, np=0, nc=0; if (d->firstobs[pt] + 1 == d->firstobs[pt+1]) return 0; /* individual has only one observation */ for (i = 0; i < qm->nst; ++i) cump[i] = 1; GetCensored((double)d->obs[d->firstobs[pt]], cm, &np, &prev); for (obs = d->firstobs[pt]+1; obs <= d->firstobs[pt+1] - 1; ++obs) { /* post-multiply by sub-matrix of P at each obs */ GetCensored((double)d->obs[obs], cm, &nc, &curr); update_likcensor(obs, prev, curr, np, nc, d, qm, hm, cump, newp, &lweight, &pmat[MI3(0,0,d->pcomb[obs],qm->nst,qm->nst)]); np = nc; for (i=0; inst)*(qm->nst), double), *qmat; qmat = &(qm->intens[MI3(0, 0, 0, qm->nst, qm->nst)]); for (i=0; i < d->nagg; ++i) { R_CheckUserInterrupt(); if ((i==0) || (d->whicha[i] != d->whicha[i-1]) || (d->obstypea[i] != d->obstypea[i-1])) { /* we have a new timelag/covariates/obstype combination. Recalculate the P matrix for this */ /* pointer to Q matrix for ith datapoint */ qmat = &(qm->intens[MI3(0, 0, i, qm->nst, qm->nst)]); Pmat(pmat, d->timelag[i], qmat, qm->nst, (d->obstypea[i] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); } if (d->obstypea[i] == OBS_DEATH) { contrib = pijdeath(d->fromstate[i], d->tostate[i], pmat, qmat, qm->nst); } else contrib = pmat[MI(d->fromstate[i], d->tostate[i], qm->nst)]; lik += d->nocc[i] * log(contrib); #ifdef DEBUG /* printf("obs %d, from %d, to %d, time %lf, obstypea %d, ", i, d->fromstate[i], d->tostate[i], d->timelag[i], d->obstypea[i]); printf("nocc %d, con %lf, lik %lf\n", d->nocc[i], log(contrib), lik);*/ // printf("%d-%d in %lf, q=%lf,%lf, lik=%20.20lf, ll=%lf\n",d->fromstate[i], d->tostate[i], d->timelag[i],qmat[0],qmat[1], contrib, d->nocc[i] * log(contrib)); #endif } Free(pmat); return (-2*lik); } /* Likelihood for the non-hidden multi-state Markov model, by subject */ double liksimple_subj(int pt, /* ordinal subject ID */ msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm) { int i, from, to; double lik=0, pm=0, dt; double *pmat = Calloc((qm->nst)*(qm->nst), double), *qmat; for (i = d->firstobs[pt]+1; i < d->firstobs[pt+1]; ++i) { R_CheckUserInterrupt(); dt = d->time[i] - d->time[i-1]; from = fprec(d->obs[i-1] - 1, 0); /* convert state outcome to integer */ to = fprec(d->obs[i] - 1, 0); qmat = &(qm->intens[MI3(0, 0, i-1, qm->nst, qm->nst)]); /* use covariate at start of transition */ Pmat(pmat, dt, qmat, qm->nst, (d->obstype[i] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); if (d->obstype[i] == OBS_DEATH) pm = pijdeath(from, to, pmat, qmat, qm->nst); else pm = pmat[MI(from, to, qm->nst)]; #ifdef DEBUG printf("i=%d, %d-%d in %lf, q=%lf,%lf, ll=%lf\n",i,from,to,dt,qmat[0],qmat[1],log(pm)); #endif lik += log(pm); } Free(pmat); return (-2*lik); } void msmLikelihood (msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *returned) { int pt; double likone; double *pmat = Calloc((qm->nst)*(qm->nst)*(d->npcombs), double); *returned = 0; /* Likelihood for hidden Markov model */ if (hm->hidden) { calc_p(d, qm, pmat); for (pt = 0; pt < d->npts; ++pt){ likone = likhidden (pt, d, qm, cm, hm, pmat); #ifdef DEBUG printf("pt %d, lik %lf\n", pt, likone); #endif *returned += likone; } } /* Likelihood for Markov model with censored outcomes */ else if (cm->ncens > 0) { calc_p(d, qm, pmat); for (pt = 0; pt < d->npts; ++pt){ likone = likcensor (pt, d, qm, cm, hm, pmat); *returned += likone; } } /* Likelihood for simple non-hidden, non-censored Markov model */ else { *returned = liksimple (d, qm, cm, hm); } Free(pmat); } /* First derivatives of the log-likelihood for the non-hidden multi-state Markov model. */ void derivsimple(msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *deriv) { int i, p, np=qm->nopt; double *qmat, *dqmat; double *pmat = Calloc(qm->nst * qm->nst, double); double *dpmat = Calloc(qm->nst * qm->nst * np, double); double *dp = Calloc(np, double); double pm; qmat = &(qm->intens[MI3(0, 0, 0, qm->nst, qm->nst)]); dqmat = &(qm->dintens[MI4(0, 0, 0, 0, qm->nst, qm->nst, np)]); for (p = 0; p < np; ++p) deriv[p] = 0; for (i=0; i < d->nagg; ++i) { R_CheckUserInterrupt(); if ((i==0) || (d->whicha[i] != d->whicha[i-1]) || (d->obstypea[i] != d->obstypea[i-1])) { /* we have a new timelag/covariates/obstype combination. Recalculate the P matrix and its derivatives for this */ qmat = &(qm->intens[MI3(0, 0, i, qm->nst, qm->nst)]); Pmat(pmat, d->timelag[i], qmat, qm->nst, (d->obstypea[i] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); dqmat = &(qm->dintens[MI4(0, 0, 0, i, qm->nst, qm->nst, np)]); DPmat(dpmat, d->timelag[i], dqmat, qmat, qm->nst, np, (d->obstypea[i] == OBS_EXACT)); } if (d->obstypea[i] == OBS_DEATH) { pm = pijdeath(d->fromstate[i], d->tostate[i], pmat, qmat, qm->nst); dpijdeath(d->fromstate[i], d->tostate[i], dpmat, pmat, dqmat, qmat, qm->nst, np, dp); } else { pm = pmat[MI(d->fromstate[i], d->tostate[i], qm->nst)]; for (p = 0; p < np; ++p) dp[p] = dpmat[MI3(d->fromstate[i], d->tostate[i], p, qm->nst, qm->nst)]; } for (p = 0; p < np; ++p) { if (pm > 0) deriv[p] += d->nocc[i] * dp[p] / pm; } } for (p = 0; p < np; ++p) { deriv[p] *= -2; /* above is dlogL/dtu as in Kalb+Law, we want deriv of -2 loglik */ } Free(pmat); Free(dpmat); Free(dp); } /* First derivatives of the likelihood for the non-hidden multi-state Markov model. Uses data of form "subject, time, state, covariates". Returns derivatives by individual and parameter for use in the score residual diagnostic. */ void derivsimple_subj(msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *deriv) { int pt, i, p, np=qm->nopt; double *qmat, *dqmat; double *pmat = Calloc(qm->nst * qm->nst, double); double *dpmat = Calloc(qm->nst * qm->nst * np, double); double *dp = Calloc(np, double); double pm=0, dt; int from, to; for (pt = 0; pt < d->npts; ++pt){ { R_CheckUserInterrupt(); if (d->firstobs[pt+1] > d->firstobs[pt] + 1) { /* individual has more than one observation? */ for (p = 0; p < np; ++p) { deriv[MI(pt,p,d->npts)] = 0; } for (i = d->firstobs[pt]+1; i < d->firstobs[pt+1]; ++i) { dt = d->time[i] - d->time[i-1]; from = fprec(d->obs[i-1] - 1, 0); /* convert state outcome to integer */ to = fprec(d->obs[i] - 1, 0); qmat = &(qm->intens[MI3(0, 0, i-1, qm->nst, qm->nst)]); /* use covariate at start of transition */ Pmat(pmat, dt, qmat, qm->nst, (d->obstype[i] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); dqmat = &(qm->dintens[MI4(0, 0, 0, i-1, qm->nst, qm->nst, np)]); DPmat(dpmat, dt, dqmat, qmat, qm->nst, np, (d->obstype[i] == OBS_EXACT)); if (d->obstype[i] == OBS_DEATH) { pm = pijdeath(from, to, pmat, qmat, qm->nst); dpijdeath(from, to, dpmat, pmat, dqmat, qmat, qm->nst, np, dp); } else { pm = pmat[MI(from, to, qm->nst)]; for (p = 0; p < np; ++p) dp[p] = dpmat[MI3(from, to, p, qm->nst, qm->nst)]; } for (p = 0; p < np; ++p) { deriv[MI(pt,p,d->npts)] += dp[p] / pm; /* on loglik scale not -2*loglik */ #ifdef DEBUG printf("i=%d, p=%d, pt=%d, from=%d, to=%d, dt=%6.4f, %f, %f, %lf, %lf\n", i, p, pt, from, to, dt, dp[p], pm, -2 * dp[p] / pm, -2*deriv[MI(pt,p,d->npts)]); #endif } } for (p = 0; p < np; ++p) deriv[MI(pt,p,d->npts)] *= -2; } else for (p = 0; p < np; ++p) deriv[MI(pt,p,d->npts)] = 0; } } Free(pmat); Free(dpmat); Free(dp); } void infosimple(msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *info) { int i, j, p, q, np=qm->nopt; double *qmat, *dqmat; double *pmat = Calloc(qm->nst * qm->nst, double); double *dpmat = Calloc(qm->nst * qm->nst * np, double); double *dpm = Calloc(qm->nst* np, double); double *pm = Calloc(qm->nst, double); for (p = 0; p < np; ++p) for (q = 0; q < np; ++q) info[MI(p,q,np)] = 0; for (i=0; i < d->nagg; ++i) { R_CheckUserInterrupt(); if ((i==0) || (d->whicha[i] != d->whicha[i-1]) || (d->obstypea[i] != d->obstypea[i-1])) { /* we have a new timelag/covariates/obstype combination. Recalculate the P matrix and its derivatives for this */ qmat = &(qm->intens[MI3(0, 0, i, qm->nst, qm->nst)]); Pmat(pmat, d->timelag[i], qmat, qm->nst, (d->obstypea[i] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); dqmat = &(qm->dintens[MI4(0, 0, 0, i, qm->nst, qm->nst, np)]); DPmat(dpmat, d->timelag[i], dqmat, qmat, qm->nst, np, (d->obstypea[i] == OBS_EXACT)); } if (d->obstypea[i] != OBS_PANEL) error("Fisher information only available for panel data\n"); for (j=0; j < qm->nst; ++j) { pm[j] = pmat[MI(d->fromstate[i], j, qm->nst)]; for (p = 0; p < np; ++p){ dpm[MI(j,p,qm->nst)] = dpmat[MI3(d->fromstate[i], j, p, qm->nst, qm->nst)]; } } if ((i==0) || (d->whicha[i] != d->whicha[i-1]) || (d->obstypea[i] != d->obstypea[i-1]) || (d->fromstate[i] != d->fromstate[i-1])) { for (p = 0; p < np; ++p) { for (q = 0; q < np; ++q) { /* for expected information, sum over all possible destination states for this fromstate/time/cov combination */ for(j = 0; jnst; ++j) { if (pm[j] > 0) info[MI(p,q,np)] += d->noccsum[i] * dpm[MI(j,p,qm->nst)] * dpm[MI(j,q,qm->nst)] / pm[j]; } } } } } for (p = 0; p < np; ++p) { for (q = 0; q < np; ++q) { info[MI(p,q,np)] *= 2; /* above is E(-d2logL/dtudtv) as in Kalb+Law. we want second deriv of of -2 loglik */ } } Free(pm); Free(dpm); Free(dpmat); Free(pmat); } /* Derivatives of the P matrix, used for the Pearson test p-value */ /* Returns a ntrans * ntostates * npars matrix */ /* Panel data only (obstype 1) */ void dpmat_obs(msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *deriv) { int pt, i, j, k, p, from, np = qm->nopt; double *dpmat = Calloc(qm->nst * qm->nst * np, double), *qmat, *dqmat; double dt; j=0; for (pt = 0; pt < d->npts; ++pt) { R_CheckUserInterrupt(); if (d->firstobs[pt+1] > d->firstobs[pt] + 1) { /* individual has more than one observation? */ for (i = d->firstobs[pt]+1; i < d->firstobs[pt+1]; ++i) { ++j; qmat = &(qm->intens[MI3(0, 0, i, qm->nst, qm->nst)]); dqmat = &(qm->dintens[MI4(0, 0, 0, i, qm->nst, qm->nst, np)]); dt = d->time[i] - d->time[i-1]; from = fprec(d->obs[i-1] - 1, 0); /* convert state outcome to integer */ DPmat(dpmat, dt, dqmat, qmat, qm->nst, np, (d->obstype[i] == OBS_EXACT)); for (p = 0; p < np; ++p) { for (k=0; k < qm->nst; ++k) { deriv[MI3(j-1,k,p,d->ntrans,qm->nst)] = dpmat[MI3(from, k, p, qm->nst, qm->nst)]; } } } } } Free(dpmat); } void derivhidden(msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *deriv, int by_subject){ int pt, p, np = qm->nopt + hm->nopt; double *pmat = Calloc((qm->nst)*(qm->nst)*(d->npcombs), double); double *dpmat = Calloc((qm->nst)*(qm->nst)*qm->nopt*(d->npcombs), double); double *dlp = Calloc(np, double); calc_p(d, qm, pmat); calc_dp(d, qm, dpmat); if (!by_subject) for (p=0; pnpts; ++pt){ hmm_deriv(pt, d, qm, cm, hm, pmat, dpmat, dlp); for (p=0; pnpts)] = -2*dlp[p]; else deriv[p] += -2*dlp[p]; } } Free(pmat); Free(dpmat); Free(dlp); } void msmDeriv_subj (msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *returned) { if (hm->hidden || (cm->ncens > 0)) derivhidden(d, qm, cm, hm, returned, 1); else derivsimple_subj(d, qm, cm, hm, returned); } // Information matrix for HMMs. Only support panel data and misclassification models void infohidden(msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *info){ int pt, p, q, np = qm->nopt + hm->nopt; double *pmat = Calloc((qm->nst)*(qm->nst)*(d->npcombs), double); double *dpmat = Calloc((qm->nst)*(qm->nst)*qm->nopt*(d->npcombs), double); double *itmp = Calloc(np*np, double); calc_p(d, qm, pmat); calc_dp(d, qm, dpmat); for (p=0; pnpts; ++pt){ hmm_info(pt, d, qm, cm, hm, pmat, dpmat, itmp); for (p=0; phidden || cm->ncens > 0) derivhidden(d, qm, cm, hm, returned, 0); else derivsimple(d, qm, cm, hm, returned); } void msmInfo (msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *returned) { if (hm->hidden || (cm->ncens > 0)) infohidden(d, qm, cm, hm, returned); else infosimple(d, qm, cm, hm, returned); } /* Return vector of subject-specific log likelihoods */ void msmLikelihood_subj (msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *returned) { int pt; double *pmat = Calloc((d->npcombs)*(qm->nst)*(qm->nst), double); if (hm->hidden || (cm->ncens > 0)) calc_p(d, qm, pmat); for (pt = 0; pt < d->npts; ++pt){ if (hm->hidden) returned[pt] = likhidden (pt, d, qm, cm, hm, pmat); else if (cm->ncens > 0) returned[pt] = likcensor (pt, d, qm, cm, hm, pmat); else returned[pt] = liksimple_subj (pt, d, qm, cm, hm); } Free(pmat); } /* Find zero-based index of maximum element of a vector x */ void pmax(double *x, int n, int *maxi) { int i=0; *maxi = i; for (i=1; i x[*maxi]) { *maxi = i; } } } /* Calculates the most likely path through underlying states and "posterior" probabilities of underlying states */ void Viterbi(msmdata *d, qmodel *qm, cmodel *cm, hmodel *hm, double *fitted, double *pstate) { int i, j, tru, k, kmax, obs, nc = 1; double *pmat = Calloc((qm->nst)*(qm->nst), double); int *ptr = Calloc((d->n)*(qm->nst), int); double *lvold = Calloc(qm->nst, double); double *lvnew = Calloc(qm->nst, double); double *lvp = Calloc(qm->nst, double); double *curr = Calloc (qm->nst, double), *outcome; double *pout = Calloc(qm->nst, double); double *pfwd = Calloc((d->n)*(qm->nst), double); double *pbwd = Calloc((d->n)*(qm->nst), double); double dt, logpall, psum; double *qmat, *hpars; double *ucfwd = Calloc(d->n, double); double *ucbwd = Calloc(d->n, double); i = 0; if (d->obstrue[i]) { for (k = 0; k < qm->nst; ++k) lvold[k] = (k+1 == d->obstrue[i] ? 0 : R_NegInf); } else { if (d->nout > 1) outcome = &d->obs[MI(0, i, d->nout)]; else { GetCensored(d->obs[i], cm, &nc, &curr); outcome = curr; } /* initial observation is a censored state. No HMM here, so initprobs not needed */ if (nc > 1) { for (k = 0, j = 0; k < qm->nst; ++k) { if (k+1 == outcome[j]) { lvold[k] = 0; ++j; } else lvold[k] = R_NegInf; } } else { /* use initprobs */ for (k = 0; k < qm->nst; ++k) lvold[k] = log(hm->initp[MI(0, k, d->npts)]); } } for (k = 0; k < qm->nst; ++k) pfwd[MI(i,k,d->n)] = exp(lvold[k]); ucfwd[0] = 0; for (i = 1; i <= d->n; ++i) { R_CheckUserInterrupt(); #ifdef VITDEBUG0 printf("obs %d\n", i); #endif if ((i < d->n) && (d->subject[i] == d->subject[i-1])) { #ifdef VITDEBUG0 printf("subject %d\n", d->subject[i]); #endif dt = d->time[i] - d->time[i-1]; qmat = &(qm->intens[MI3(0, 0, i-1, qm->nst, qm->nst)]); hpars = &(hm->pars[MI(0, i, hm->totpars)]); /* not i-1 as pre 1.2.3 */ if (d->nout > 1) outcome = &d->obs[MI(0, i, d->nout)]; else { GetCensored(d->obs[i], cm, &nc, &curr); outcome = curr; } GetOutcomeProb(pout, outcome, nc, d->nout, hpars, hm, qm, d->obstrue[i]); #ifdef VITDEBUG0 for (tru=0;trunst, (d->obstype[i] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); psum = 0; for (tru = 0; tru < qm->nst; ++tru) { /* lvnew = log prob of most likely path ending in tru at current obs. kmax = most likely state at the previous obs pfwd = p(data up to and including current obs, and hidden state at current obs), then scaled at each step to sum to 1 to avoid underflow. */ pfwd[MI(i,tru,d->n)] = 0; for (k = 0; k < qm->nst; ++k) { lvp[k] = lvold[k] + log(pmat[MI(k, tru, qm->nst)]); pfwd[MI(i,tru,d->n)] += pfwd[MI(i-1,k,d->n)] * pmat[MI(k,tru,qm->nst)]; } if (d->obstrue[i-1]) // kmax = d->obs[MI(0, i-1, d->nout)] - 1; kmax = d->obstrue[i-1] - 1; else pmax(lvp, qm->nst, &kmax); lvnew[tru] = log ( pout[tru] ) + lvp[kmax]; ptr[MI(i, tru, d->n)] = kmax; pfwd[MI(i,tru,d->n)] *= pout[tru]; psum += pfwd[MI(i,tru,d->n)]; #ifdef VITDEBUG0 printf("true %d, pout[%d] = %lf, lvold = %lf, pmat = %lf, lvnew = %lf, ptr[%d,%d]=%d\n", tru, tru, pout[tru], lvold[tru], pmat[MI(kmax, tru, qm->nst)], lvnew[tru], i, tru, ptr[MI(i, tru, d->n)]); #endif } ucfwd[i] = ucfwd[i-1] + log(psum); for (k = 0; k < qm->nst; ++k){ pfwd[MI(i,k,d->n)] /= psum; lvold[k] = lvnew[k]; } } else { /* Traceback and backward algorithm for current individual pall = p(data at all times) pbwd = p(data at future times | hidden state at current obs) so that p(hidden state at current obs) = pfwd * pbwd / pall */ pmax(lvold, qm->nst, &kmax); obs = i-1; // fitted[obs] = (d->obstrue[obs] ? d->obs[MI(0,obs,d->nout)]-1 : kmax); fitted[obs] = (d->obstrue[obs] ? d->obstrue[obs]-1 : kmax); logpall = 0; // compute full likelihood. ucbwd[obs] = 0; for (k = 0; k < qm->nst; ++k){ pbwd[MI(obs,k,d->n)] = 1; logpall += pfwd[MI(obs,k,d->n)]; } logpall = log(logpall) + ucfwd[obs]; for (k = 0; k < qm->nst; ++k){ pstate[MI(obs,k,d->n)] = exp(log(pfwd[MI(obs,k,d->n)]) + log(pbwd[MI(obs,k,d->n)]) - logpall + ucfwd[obs]); } #ifdef VITDEBUG printf("traceback for subject %d\n", d->subject[i-1]); printf("obs=%d,fitted[%d]=%1.0lf\n",obs,obs,fitted[obs]); for (tru = 0; tru < qm->nst; ++tru){ printf("pfwd[%d,%d]=%f, ", obs, tru, pfwd[MI(obs,tru,d->n)]); printf("pbwd[%d,%d]=%f, ", obs, tru, pbwd[MI(obs,tru,d->n)]); printf("ucfwd[%d]=%f, ", obs, ucfwd[obs]); printf("ucbwd[%d]=%f, ", obs, ucfwd[obs]); printf("logpall=%f,",logpall); printf("pstate[%d,%d]=%f, ", obs, tru, pstate[MI(obs,tru,d->n)]); printf("\n"); } #endif while ( (obs > 0) && (d->subject[obs] == d->subject[obs-1]) ) { fitted[obs-1] = ptr[MI(obs, fitted[obs], d->n)]; #ifdef VITDEBUG printf("fitted[%d] = ptr[%d,%1.0lf] = %1.0lf\n", obs-1, obs, fitted[obs], fitted[obs-1]); #endif dt = d->time[obs] - d->time[obs-1]; qmat = &(qm->intens[MI3(0, 0, obs-1, qm->nst, qm->nst)]); hpars = &(hm->pars[MI(0, obs, hm->totpars)]); if (d->nout > 1) outcome = &d->obs[MI(0, obs, d->nout)]; else { GetCensored(d->obs[obs], cm, &nc, &curr); outcome = curr; } GetOutcomeProb(pout, outcome, nc, d->nout, hpars, hm, qm, d->obstrue[obs]); Pmat(pmat, dt, qmat, qm->nst, (d->obstype[obs] == OBS_EXACT), qm->iso, qm->perm, qm->qperm, qm->expm); psum=0; for (tru = 0; tru < qm->nst; ++tru){ pbwd[MI(obs-1,tru,d->n)] = 0; for (k = 0; k < qm->nst; ++k) pbwd[MI(obs-1,tru,d->n)] += pmat[MI(tru,k,qm->nst)] * pout[k] * pbwd[MI(obs,k,d->n)]; psum += pbwd[MI(obs-1,tru,d->n)]; } ucbwd[obs-1] = ucbwd[obs] + log(psum); for (tru = 0; tru < qm->nst; ++tru){ pbwd[MI(obs-1,tru,d->n)] /= psum; pstate[MI(obs-1,tru,d->n)] = exp(log(pfwd[MI(obs-1,tru,d->n)]) + log(pbwd[MI(obs-1,tru,d->n)]) - logpall + ucfwd[obs-1] + ucbwd[obs-1]); #ifdef VITDEBUG printf("pfwd[%d,%d]=%f, ", obs-1, tru, pfwd[MI(obs-1,tru,d->n)]); printf("pbwd[%d,%d]=%f, ", obs-1, tru, pbwd[MI(obs-1,tru,d->n)]); printf("ucfwd[%d]=%f, ", obs, ucfwd[obs]); printf("ucbwd[%d]=%f, ", obs, ucfwd[obs]); printf("logpall=%f,",logpall); printf("pstate[%d,%d]=%f, ", obs-1, tru, pstate[MI(obs-1,tru,d->n)]); printf("\n"); #endif } #ifdef VITDEBUG printf("logpall=%f\n",logpall); #endif --obs; } #ifdef VITDEBUG printf("\n"); #endif if (i < d->n) { if (d->obstrue[i]) { for (k = 0; k < qm->nst; ++k) // lvold[k] = (k+1 == d->obs[MI(0,i,d->nout)] ? 0 : R_NegInf); lvold[k] = (k+1 == d->obstrue[i] ? 0 : R_NegInf); } else { if (d->nout > 1) outcome = &d->obs[MI(0, i, d->nout)]; else { GetCensored(d->obs[i], cm, &nc, &curr); outcome = curr; } /* initial observation is a censored state. No HMM here, so initprobs not needed */ if (nc > 1) { for (k = 0, j = 0; k < qm->nst; ++k) { if (k+1 == outcome[j]) { lvold[k] = 0; ++j; } else lvold[k] = R_NegInf; } } else { /* use initprobs */ for (k = 0; k < qm->nst; ++k) lvold[k] = log(hm->initp[MI(d->subject[i]-1, k, d->npts)]); } } for (k = 0; k < qm->nst; ++k) pfwd[MI(i,k,d->n)] = exp(lvold[k]); ucfwd[i] = 0; } } } Free(pmat); Free(ptr); Free(lvold); Free(lvnew); Free(lvp); Free(curr); Free(pout); Free(pfwd); Free(pbwd); Free(ucfwd); Free(ucbwd); } /* get the list element named str, or return NULL */ SEXP getListElement(SEXP list, const char *str) { SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol); for (int i = 0; i < length(list); i++) if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) { elmt = VECTOR_ELT(list, i); break; } return elmt; } double *list_double_vec(SEXP list, const char *str) { SEXP elt = getListElement(list, str); return REAL(elt); } int *list_int_vec(SEXP list, const char *str) { SEXP elt = getListElement(list, str); return INTEGER(elt); } double list_double(SEXP list, const char *str) { SEXP elt = getListElement(list, str); return REAL(elt)[0]; } int list_int(SEXP list, const char *str) { SEXP elt = getListElement(list, str); return INTEGER(elt)[0]; } SEXP msmCEntry(SEXP do_what_s, SEXP mf_agg_s, SEXP mf_s, SEXP auxdata_s, SEXP qmodel_s, SEXP cmodel_s, SEXP hmodel_s, SEXP pars_s) { msmdata d; qmodel qm; cmodel cm; hmodel hm; int do_what = INTEGER(do_what_s)[0], nopt; double lik, *ret, *fitted, *pfwd; SEXP ret_s; /* type coercion for all these is done in R */ d.fromstate = list_int_vec(mf_agg_s, "(fromstate)"); d.tostate = list_int_vec(mf_agg_s, "(tostate)"); d.timelag = list_double_vec(mf_agg_s, "(timelag)"); d.nocc = list_int_vec(mf_agg_s, "(nocc)"); d.noccsum = list_int_vec(mf_agg_s, "(noccsum)"); d.whicha = list_int_vec(mf_agg_s, "(whicha)"); d.obstypea = list_int_vec(mf_agg_s, "(obstype)"); d.subject = list_int_vec(mf_s, "(subject)"); d.time = list_double_vec(mf_s, "(time)"); d.obs = list_double_vec(mf_s, "(state)"); d.obstype = list_int_vec(mf_s, "(obstype)"); d.obstrue = list_int_vec(mf_s, "(obstrue)"); d.pcomb = list_int_vec(mf_s, "(pcomb)"); d.nagg = list_int(auxdata_s, "nagg"); d.n = list_int(auxdata_s, "n"); d.npts = list_int(auxdata_s, "npts"); d.ntrans = list_int(auxdata_s, "ntrans"); d.npcombs = list_int(auxdata_s, "npcombs"); d.firstobs = list_int_vec(auxdata_s, "firstobs"); d.nout = list_int(auxdata_s, "nout"); qm.nst = list_int(qmodel_s,"nstates"); qm.npars = list_int(qmodel_s,"npars"); qm.nopt = list_int(qmodel_s,"nopt"); qm.iso = list_int(qmodel_s,"iso"); qm.perm = list_int_vec(qmodel_s,"perm"); qm.qperm = list_int_vec(qmodel_s,"qperm"); qm.expm = list_int(qmodel_s,"expm"); qm.nliks = list_int(auxdata_s,"nliks"); qm.intens = list_double_vec(pars_s,"Q"); // TODO name qm.dintens = list_double_vec(pars_s,"DQ"); // TODO name cm.ncens = list_int(cmodel_s,"ncens"); cm.censor = list_int_vec(cmodel_s,"censor"); cm.states = list_int_vec(cmodel_s,"states"); cm.index = list_int_vec(cmodel_s,"index"); hm.hidden = list_int(hmodel_s,"hidden"); hm.mv = list_int(hmodel_s,"mv"); hm.ematrix = list_int(hmodel_s,"ematrix"); hm.models = list_int_vec(hmodel_s,"models"); hm.totpars = list_int(hmodel_s,"totpars"); hm.npars = list_int_vec(hmodel_s,"npars"); hm.firstpar = list_int_vec(hmodel_s,"firstpar"); hm.pars = list_double_vec(pars_s,"H"); hm.dpars = list_double_vec(pars_s,"DH"); hm.nopt = list_int(hmodel_s,"nopt"); hm.initp = list_double_vec(pars_s,"initprobs"); nopt = list_int(pars_s, "nopt"); if (do_what == DO_LIK) { msmLikelihood(&d, &qm, &cm, &hm, &lik); ret_s = ScalarReal(lik); } else if (do_what == DO_DERIV) { ret_s = PROTECT(NEW_NUMERIC(nopt)); ret = REAL(ret_s); msmDeriv(&d, &qm, &cm, &hm, ret); UNPROTECT(1); } else if (do_what == DO_INFO) { ret_s = PROTECT(allocMatrix(REALSXP, nopt, nopt)); ret = REAL(ret_s); msmInfo(&d, &qm, &cm, &hm, ret); UNPROTECT(1); } else if (do_what == DO_LIK_SUBJ) { ret_s = PROTECT(NEW_NUMERIC(d.npts)); ret = REAL(ret_s); msmLikelihood_subj(&d, &qm, &cm, &hm, ret); UNPROTECT(1); } else if (do_what == DO_DERIV_SUBJ) { ret_s = PROTECT(allocMatrix(REALSXP, d.npts, nopt)); ret = REAL(ret_s); msmDeriv_subj(&d, &qm, &cm, &hm, ret); UNPROTECT(1); } else if (do_what == DO_VITERBI) { /* Return a list of a vector (fitted states) and a matrix (hidden state probabilities) */ /* see https://stat.ethz.ch/pipermail/r-devel/2013-April/066246.html */ ret_s = PROTECT(allocVector(VECSXP, 2)); SEXP fitted_s = SET_VECTOR_ELT(ret_s, 0, NEW_NUMERIC(d.n)); SEXP pfwd_s = SET_VECTOR_ELT(ret_s, 1, allocMatrix(REALSXP, d.n, qm.nst)); fitted = REAL(fitted_s); pfwd = REAL(pfwd_s); Viterbi(&d, &qm, &cm, &hm, fitted, pfwd); UNPROTECT(1); } else if (do_what == DO_DPMAT) { ret_s = PROTECT(alloc3DArray(REALSXP, d.ntrans, qm.nst, nopt)); ret = REAL(ret_s); dpmat_obs(&d, &qm, &cm, &hm, ret); UNPROTECT(1); } else error("Unknown C task.\n"); return ret_s; } msm/src/hmmderiv.c0000755000176200001440000000647312774212430013633 0ustar liggesusers#include "hmm.h" #include /* Derivatives of PDF w.r.t parameters, for each HMM outcome * distribution */ void DhmmCat(double x, double *pars, double *d) { /* f(x) = p_y if x=y, and 0 otherwise df / dp_y |x = 1 if x=y, and 0 otherwise */ int i; int cat = fprec(x, 0); int ncats = fprec(pars[0], 0); for (i=0; i ncats) || (cat < 1)) return; d[1+cat] = 1; } void DhmmIdent(double x, double *pars, double *d){ d[0] = 0; } void DhmmUnif(double x, double *pars, double *d) { d[0]=0; d[1]=0; /* uniform parameters are not estimated */ } void DhmmNorm(double x, double *pars, double *d) { double mean = pars[0], sd = pars[1], f; f = dnorm(x, mean, sd, 0); d[0] = f*(x - mean)/R_pow_di(sd,2); d[1] = f*(R_pow_di((x-mean)/sd, 2) - 1)/sd; } void DhmmLNorm(double x, double *pars, double *d) { double meanlog = pars[0], sdlog = pars[1], f; f = dlnorm(x, meanlog, sdlog, 0); d[0] = f*(log(x) - meanlog)/R_pow_di(sdlog,2); d[1] = f*(R_pow_di((log(x)-meanlog)/sdlog, 2) - 1)/sdlog; } void DhmmExp(double x, double *pars, double *d) { double rate = pars[0]; d[0] = (1 - rate*x)*exp(-rate*x); } void DhmmGamma(double x, double *pars, double *d) { double shape = pars[0], rate=pars[1], scale = 1 / rate, f; f = dgamma(x, shape, scale, 0); d[0] = f*(log(rate) + log(x) - digamma(shape)); d[1] = f*(shape/rate - x); } void DhmmWeibull(double x, double *pars, double *d) { double shape = pars[0], scale = pars[1], f, rp; f = dweibull(x, shape, scale, 0); rp = R_pow(x/scale, shape); d[0] = f*(1/shape + log(x/scale)*(1 - rp)); d[1] = f*(shape/scale*(rp - 1)); } void DhmmPois(double x, double *pars, double *d) { double lambda = pars[0], f; f = dpois(x, lambda, 0); d[0] = (x/lambda - 1)*f; } void DhmmBinom(double x, double *pars, double *d) { double size = pars[0], prob = pars[1], f; f = dbinom(x, size, prob, 0); d[0] = 0; // fixed d[1] = f*(x/prob - (size-x)/(1-prob)); // printf("f=%.3f, dlf=%.3f, d[1]=%.5f\n", f, (x/prob - (size-x)/(1-prob)), d[1]); } /* not sure these three are tractable. don't support */ void DhmmTNorm(double x, double *pars, double *d){} void DhmmMETNorm(double x, double *pars, double *d){} void DhmmMEUnif(double x, double *pars, double *d){} void DhmmNBinom(double x, double *pars, double *d) { double size = pars[0], prob = pars[1], f; f = dnbinom(x, size, prob, 0); d[0] = f*(digamma(x+size) - digamma(size) + log(prob)); d[1] = f*(size/prob - x/(1-prob)); } void DhmmBeta(double x, double *pars, double *d) { double shape1 = pars[0], shape2 = pars[1], f; f = dbeta(x, shape1, shape2, 0); d[0] = f*(digamma(shape1+shape2) - digamma(shape1) + log(x)); d[1] = f*(digamma(shape1+shape2) - digamma(shape2) + log(1-x)); } void DhmmT(double x, double *pars, double *d) { double tmean = pars[0], tscale = pars[1], tdf=pars[2], f, xmsq; f = (1/tscale)*dt((x-tmean)/tscale, tdf, 0); xmsq = (x - tmean)*(x-tmean); d[0] = f * (x - tmean)*(tdf + 1) / (tdf*tscale*tscale + xmsq); d[1] = f * (-1/tscale + (tdf+1)*xmsq / (tdf*R_pow(tscale,3) + tscale*xmsq)); d[2] = 0.5 * f * (digamma((tdf + 1)/2) - digamma(tdf/2) - 1/tdf - log(1 + xmsq / (tdf*tscale*tscale)) + (tdf+1)*xmsq / (R_pow(tdf*tscale,2) + tdf*xmsq)); } msm/src/analyticp.c0000755000176200001440000015710112774212430013777 0ustar liggesusers/* Analytic formulae for P(t) in terms of transition intensities, for selected 2, 3, 4 and 5-state models. These were derived using symbolic algebra software (Mathematica). Increases speed and stability by avoiding the numeric calculation of the matrix exponential. ### The numbered label gives the indices into the matrix of rates (vectorised by reading across rows) ### e.g. the 3-state model with qmatrix of the form ### well-disease, well-death, disease-death transitions allowed. ### *,1,1 ### 0,*,1 ### 0,0,* uses the function p3q124() ### Some models are isomorphic and use the same p?q? function. ### See .msm.graphs in R/constants.R for permutations. */ #include "msm.h" #include void p2q1(Matrix pmat, double t, Matrix qmat, int *degen); void p2q12(Matrix pmat, double t, Matrix qmat, int *degen); void p3q12(Matrix pmat, double t, Matrix qmat, int *degen); void p3q14(Matrix pmat, double t, Matrix qmat, int *degen); void p3q16(Matrix pmat, double t, Matrix qmat, int *degen); void p3q124(Matrix pmat, double t, Matrix qmat, int *degen); void p3q135(Matrix pmat, double t, Matrix qmat, int *degen); void p3q1246(Matrix pmat, double t, Matrix qmat, int *degen); void p4q159(Matrix pmat, double t, Matrix qmat, int *degen); void p4q13569(Matrix pmat, double t, Matrix qmat, int *degen); void p5q1_6_11_16(Matrix pmat, double t, Matrix qmat, int *degen); void p5q1_4_6_8_11_12_16(Matrix pmat, double t, Matrix qmat, int *degen); void p5q1_6_7_11_12(Matrix pmat, double t, Matrix qmat, int *degen); typedef void (*pfn)(Matrix pmat, double t, Matrix qmat, int *degen); pfn P2FNS[] = { p2q1, p2q12 }; pfn P3FNS[] = { p3q12,p3q14,p3q16,p3q124,p3q135,p3q1246 }; pfn P4FNS[] = { p4q159,p4q13569 }; pfn P5FNS[] = { p5q1_6_11_16,p5q1_4_6_8_11_12_16,p5q1_6_7_11_12 }; void AnalyticP(Matrix pmat, double t, int nstates, int iso, int *perm, int *qperm, Matrix qmat, int *degen) { int i, j; Matrix qmat_base = (Matrix) Calloc( (nstates)*(nstates), double); Matrix pmat_base = (Matrix) Calloc( (nstates)*(nstates), double); for (i=0; i 0) REprintf("Lapack routine dgesv: system is exactly singular\n"); Free(Acopy); Free(ipiv); Free(work); } static void padeseries (double *Sum, double *A, int m, int order, double scale, double *Temp) { int i, j, r; int N = m*m; FormIdentity(Sum, m); for (j = order; j >= 1; --j) { double s = (order-j+1) / (j*(2*order-j+1) * scale); MultMat(Sum, A, m, m, m, Temp); for (i = 0; i < N; ++i) { Sum[i] = Temp[i] * s; } for (r = 0; r < m; ++r) { Sum[r*m+r] += 1; } } } void MatrixExpPade(double *ExpAt, double *A, int n, double t) { /* Calculate exp(A*t) by diagonal Pade approximation with scaling and squaring */ int i, j; int order = 8; int N = n*n; double *workspace = Calloc( 4*N, double); double * Temp = workspace; double * At = workspace + N; double * Num = workspace + 2*N; double * Denom = workspace + 3*N; double l1 = F77_CALL(dlange)("1", &n, &n, At, &n, 0); /* L-1 norm */ double linf = F77_CALL(dlange)("i", &n, &n, At, &n, Temp); /* L-Infinity norm */ double K = (log(l1) + log(linf))/log(4); int npower = (R_FINITE(K) ? (int)(K)+4 : NA_INTEGER); double scale = 1; /* Multiply by t */ for (i = 0; i < N; ++i) { At[i] = A[i] * t; } /* Scale the matrix by a power of 2 */ /* The expression below is not clear because it is optimized. The idea is that sqrt(l1 * linf) is an upper bound on the L2 norm of the matrix At (i.e the largest eigenvalue). We want to take the log, to base 2 of this to get the smallest K, st ||At/2^K|| <= 1. */ if (npower < 0) { npower = 0; } for (i = 0; i < npower; ++i) { scale *= 2; } /* Calculate exp(A/scale) by Pade series */ padeseries (Num, At, n, order, scale, Temp); for (i = 0; i < N; ++i) { At[i] = -At[i]; } padeseries (Denom, At, n, order, scale, Temp); solve(ExpAt, Denom, Num, n); /* Now repeatedly square the result */ for (i = 0; i < npower; ++i) { for (j = 0; j < N; ++j) { Temp[j] = ExpAt[j]; } MultMat(Temp, Temp, n, n, n, ExpAt); } Free(workspace); } /* Tests if a vector has any non-unique entries */ int repeated_entries(vector vec, int n) { int i, j; for (i=1; i 0) AnalyticP(expmat, *t, *n, *iso, perm, qperm, mat, degen); else MatrixExpMSM(mat, *n, expmat, *t, *degen, *method); } void MatrixExpEXPM(double *mat, int *n, double *expmat, double *t, int *method, int *iso, int *perm, int *qperm, int *degen, int *err){ int i; int nsq = (*n)*(*n); double *matt = Calloc(nsq, double); if (*iso > 0) AnalyticP(expmat, *t, *n, *iso, perm, qperm, mat, degen); else { for (i=0; i<((*n)*(*n)); ++i) { matt[i] = (*t) * mat[i]; /* Check whether any of the elements of Q have overflowed. If so, Fortran eigen function will hang in a infinite loop, so bail out before this happens. */ /* Could we return loglik = -Inf instead of halting by setting error code? return all zeros for pmat in that case? Doesn't help convergence with test case in test/rory.r: lik stays at zero. */ if (!R_FINITE(matt[i])){ // *err = -1; return; error("numerical overflow in calculating likelihood\n"); } } expm(matt, *n, expmat, Ward_2); } Free(matt); } /* Returns i-j transition intensity time t given vectors of intensities and transition indicators */ /* Calculates the whole transition matrix in time t given an intensity matrix */ void Pmat(Matrix pmat, double t, Matrix qmat, int nstates, int exacttimes, int iso, ivector perm, ivector qperm, int use_expm) { int i,j,method=MEXP_PADE,degen=0,err=0; double pii; if (exacttimes) { for (i=0; i 1 - DBL_EPSILON) pmat[MI(i, j, nstates)] = 1; } } } double pijdeath(int r, int s, Matrix pmat, Matrix qmat, int n) { int j; double contrib; if (r == s) return 1; /* absorbing-same absorbing transition has probability 1 */ else { /* sum over unobserved state at the previous instant */ contrib = 0; for (j = 0; j < n; ++j) if (j != s) { contrib += pmat[MI(r, j, n)] * qmat[MI(j,s,n)]; } } return contrib; } /*************************************************** CODE FOR DERIVATIVES OF P MATRIX. ***************************************************/ /* qij exp (qii t) dqij exp(qii t) + dqii qij t exp(qii t) exp(qii t) ( dqij + dqii qij t ) or exp(qii t) if diag */ void DPmatEXACT(Array3 dqmat, Matrix qmat, int n, int npars, Array3 dpmat, double t) { int i,j,p; for (i=0; i 0) REprintf("error code %d from EISPACK eigensystem routine rg\n", err); if (repeated_entries (revals, n)) { DMatrixExpSeries(dqmat, qmat, n, npars, dpmat, t); } else { MatInv(evecs, evecsinv, n); for (p=0; p #include #include #include /* index to treat a vector as a matrix. ith row, jth column. Fills columns first, as in R */ #define MI(i, j, nrows) ( (int) ((j)*(nrows) + (i)) ) /* index to treat a vector as a 3-dimensional array. Left-most index varies fastest, as in R */ #define MI3(i, j, k, n1, n2) ( (int) ((k)*((n1)*(n2)) + (j)*(n1) + (i)) ) #define MI4(i, j, k, m, n1, n2, n3) ( (int) ((m)*((n1)*(n2)*(n3)) + (k)*((n1)*(n2)) + (j)*(n1) + (i)) ) /* Macros to switch quickly between C and S memory handling. Currently not used */ #define USE_CALLOC /* #define USE_SALLOC */ #ifdef USE_CALLOC #define MSM_ALLOC(length, type) Calloc((length), type) #define MSM_FREE(var) Free((var)) #else #define MSM_ALLOC(length, type) (type *) S_alloc((length), sizeof(type)) #define MSM_FREE(var) #endif typedef double * Array3; typedef double * Array4; typedef double * Matrix; typedef int * iMatrix; typedef double * vector; typedef int * ivector; struct msmdata { /* for non-hidden model */ int *fromstate; int *tostate; double *timelag; int *nocc; int *noccsum; int *whicha; int *obstypea; /* for hidden model */ int *subject; double *time; double *obs; /* observed state or any other HMM observation */ int *obstype; int *obstrue; int *pcomb; int *firstobs; int nagg; int n; int npts; int ntrans; int npcombs; int nout; }; struct qmodel { int nst; int npars; int nopt; double *intens; double *dintens; int iso; int *perm; int *qperm; int expm; int nliks; }; struct cmodel { int ncens; int *censor; int *states; int *index; }; struct hmodel { int hidden; int mv; int ematrix; int *models; int totpars; int *npars; int *firstpar; double *pars; double *dpars; int nopt; double *initp; }; typedef struct msmdata msmdata; typedef struct qmodel qmodel; typedef struct cmodel cmodel; typedef struct hmodel hmodel; int repeated_entries(vector vec, int n); double logit(double x); double expit(double x); double identity(double x); int all_equal(double x, double y); void MatrixExpPadeR(double *ExpAt, double *A, int *n, double *t); void AnalyticP(Matrix pmat, double t, int nstates, int iso, int *perm, int *qperm, Matrix qmat, int *degen); double pijdeath(int r, int s, Matrix pmat, Matrix qmat, int n); void Pmat(Matrix pmat, double t, Matrix qmat, int nstates, int exacttimes, int iso, int *perm, int *qperm, int expm); void DPmat(Array3 dpmat, double t, Array3 dqmat, Matrix qmat, int n, int np, int exacttimes); void dpijdeath(int r, int s, Array3 dpmat, Matrix pmat, Array4 dqmat, Matrix qmat, int n, int npars, Matrix dcontrib); msm/src/hmm.h0000755000176200001440000000304312774212430012574 0ustar liggesusers typedef double (*hmmfn)(double x, double *pars); typedef void (*dhmmfn)(double x, double *pars, double *d); double hmmCat(double x, double *pars); double hmmIdent(double x, double *pars); double hmmUnif(double x, double *pars); double hmmNorm(double x, double *pars); double hmmLNorm(double x, double *pars); double hmmExp(double x, double *pars); double hmmGamma(double x, double *pars); double hmmWeibull(double x, double *pars); double hmmPois(double x, double *pars); double hmmBinom(double x, double *pars); double hmmTNorm(double x, double *pars); double hmmMETNorm(double x, double *pars); double hmmMEUnif(double x, double *pars); double hmmNBinom(double x, double *pars); double hmmBeta(double x, double *pars); double hmmT(double x, double *pars); void DhmmCat(double x, double *pars, double *d); void DhmmIdent(double x, double *pars, double *d); void DhmmUnif(double x, double *pars, double *d); void DhmmNorm(double x, double *pars, double *d); void DhmmLNorm(double x, double *pars, double *d); void DhmmExp(double x, double *pars, double *d); void DhmmGamma(double x, double *pars, double *d); void DhmmWeibull(double x, double *pars, double *d); void DhmmPois(double x, double *pars, double *d); void DhmmBinom(double x, double *pars, double *d); void DhmmTNorm(double x, double *pars, double *d); void DhmmMETNorm(double x, double *pars, double *d); void DhmmMEUnif(double x, double *pars, double *d); void DhmmNBinom(double x, double *pars, double *d); void DhmmBeta(double x, double *pars, double *d); void DhmmT(double x, double *pars, double *d); msm/NAMESPACE0000755000176200001440000000441012622613433012271 0ustar liggesusersuseDynLib(msm) export( absorbing.msm, boot.msm, coef.msm, contour.msm, crudeinits.msm, deltamethod, draic.msm, drlcv.msm, efpt.msm, ematrix.msm, envisits.msm, hazard.msm, image.msm, MatrixExp, msm, msm2Surv, msm.form.qoutput, msm.form.eoutput, logLik.msm, lrtest.msm, odds.msm, pearson.msm, persp.msm, phasemeans.msm, plot.msm, plotprog.msm, pmatrix.msm, pmatrix.piecewise.msm, pnext.msm, ppass.msm, plot.prevalence.msm, plot.survfit.msm, prevalence.msm, printold.msm, printnew.msm, qmatrix.msm, qratio.msm, recreate.olddata, scoreresid.msm, sim.msm, simmulti.msm, simfitted.msm, sojourn.msm, statetable.msm, summary.msm, surface.msm, totlos.msm, transient.msm, viterbi.msm, hmmCat, hmmIdent, hmmUnif, hmmNorm, hmmLNorm, hmmExp, hmmGamma, hmmWeibull, hmmPois, hmmBinom, hmmTNorm, hmmMETNorm, hmmMEUnif, hmmNBinom, hmmBeta, hmmT, hmmMV, dtnorm, ptnorm, qtnorm, rtnorm, dmenorm, pmenorm, qmenorm, rmenorm, dmeunif, pmeunif, qmeunif, rmeunif, dpexp, ppexp, qpexp, rpexp, qgeneric, d2phase, p2phase, q2phase, r2phase, h2phase ) importFrom(graphics, plot) importFrom(graphics, persp) importFrom(graphics, contour) importFrom(graphics, image) importFrom(stats, coef) importFrom(mvtnorm, rmvnorm) importFrom(survival, Surv) importFrom(survival, survfit) importFrom(expm, expm) S3method(print, msm) S3method(summary, msm) S3method(plot, msm) S3method(contour, msm) S3method(persp, msm) S3method(image, msm) S3method(coef, msm) S3method(logLik, msm) S3method(model.frame, msm) S3method(model.matrix, msm) S3method(print, hmodel) S3method(print, hmmdist) S3method(print, msm.est) S3method("[", msm.est) S3method(print, pearson.msm) S3method(plot, prevalence.msm) S3method(plot, survfit.msm) importFrom("grDevices", "rainbow") importFrom("graphics", "filled.contour", "legend", "lines", "par", "text") importFrom("stats", "as.formula", "deriv", "dexp", "dnorm", "integrate", "logLik", "model.extract", "model.frame", "model.matrix", "na.fail", "na.omit", "na.pass", "numericDeriv", "optimHess", "pchisq", "pexp", "plogis", "pnorm", "qlogis", "qnorm", "quantile", "rbeta", "rbinom", "reformulate", "rexp", "rgamma", "rlnorm", "rnbinom", "rnorm", "rpois", "rt", "runif", "rweibull", "sd", "setNames", "terms", "uniroot") msm/data/0000755000176200001440000000000012774212430011761 5ustar liggesusersmsm/data/bos4.rda0000755000176200001440000000675412371154243013337 0ustar liggesusers͜_eƏ6;)IMI'4Cπ 0 F`fdRefeFfeE\tх\xEλ5 3<{a9} 3iƤ\.7.7?0_'&N9Zr8>R*S g()YO ή|FgU`S|/*\ /+\(E _U_+4(XS5jW( (\po(\P7\0U W*\p; LSu'pF7)@a͂[jC5Mp&LY;f .)Hf|A```Up~%  +<(xHaA+mGjFV.X'X/PAg 6 5ؤУY } mGk0 ءSKPc5x\ 5WOXgkO~&x^s (W_ ^/58 *AᏂ? ^Y/7{;JwrJ]!~k'C;#MNO7o=֟&7$>odǗ$i!wP+i}U?S&r=[HR $.̥}ץy!i]:λ4~?S|kWOPYM!Ω8o(ۘ-i}!n)_1ͷ% J.iJV.yHKJC||Z_SIcߴľ4t9A$_Nwr7K\p 6.yz$NHUܣ:}?|H?3WWK7Hlɥ^UnL2ώSCܥϭ߮i5(͖zԷ(\wJUr6h}@}IjZKCP" دt.m1КΦoy̳]]v5_ӁgC\PNNNiNB{ZoJ*vuץaR I]!Y qĴ^Rqki}~׫t٫7y7yz[5OzZ|PrK]{!E7Ij>yb*<vy7zǔ4U"wՏJں4Tbz\ʏWJk^tr7z]_ktg)ŊoQ[P]3Tn{. qA=}Bze0č-!QJo>[Ҽ^bY}}/y5NދJ~OU^u5!*l:_nV~Yn9K)h:4_v轏ͪ\V,/BWIKl0čxk'k]m}s}Gzx1~>o?zn>'X(}i>8R50>1|s~ˍnzccqK9/_cF61_h۱9hsxqcza1 w1sG9>V?|1BzqhG9W߈<f#=~|`Ku^jaq9E \\C3nNj.Lua _]dE(b\C}\5ĕ+W>|DfMd6ٸ&2l"62l#6No#62"|..2"#>#|Y"_ȗIȜE,2g9A>ȜȜW|W|8s!2"_!⤅\\\8s1(أX1eKҲt,=ˌee%@Z4Т hE^UZx ^kZFZx-u:x;Z8x=-<^=Eoo-h7ot'D*}R<ѧW(]Y>'**+RETUXϋ ҥJҗD_]4G+J_U\ ה]%ZJ׈UjTh7E׉%w)]/A黢nݬ=QYi[E D t"(.C"Z,Z"j---ݥBRn*=JES_ԮhhC:zF&QfQQGWOihRҀhҠh!N!.ݢ=hhâJ=tP1JO)P#'RODO~*zFggE?BKs_)=koD/~+zQwJA菢E":]+lC_Y|ݓ/q4p>>uUrn/e4wGL|]vv+52C4XqpiܒB?xMO7uf]i\'xK4؈Mqё4pKߔdi~f}c|MWy9.َi[ƾ4poCi~NLrzMs~ϊGGxim7q䷥=y-Lz%YK:b_/b;f(#olE25uqias^4ߗԷQ8962>h^iOO]i=[d0[~i~y~sn73|i|y^W;9xǜ{qד$_ :kyf]wem6/9$?ԖL?W>>tjjw%oci$f4֐IMi={97ؐ+dXLs!Og^O4ɸ4SO9ݭiۼ޳|GMoٞ7cO#ކ4Ds:My4n7<mgĵ4^u86Ml,eM&nHslȜ̾=oJ\]V{&ͷ>e"aylҸ(c}Mh_K>6`?:jog8_7ϱlyn5&B_ϥo3פ: ׃}7~j8|lGH<智{41׶5ԵɜCh֘#xmefF;7uehkJ=i%C<+s﫥iYLvS#imQ?>y;Nwg}Oc?uc?zgs;uLy>`vYTs;a~c}o{Su^:o}c~ux({;LxMNT)Z?} O)sҞw3YbzYDx'-nnYp? 5?I-',m8eْ)iJO> IY&K8+ř3gX[\tqE,*.>⣋8..*k)b-](p Gk96ĵ! qmxwCt pQѥ]ʱr\[k+qm%VUUUJkDjFjFj=qjܣZcFXa1%L2L[Y f%`NQGey8x\ǵBeH92Fe Ápp,k 2p(ár0+ìPdEVE[T[o8TPCEVq· _{W,bZa1%LӀiSlQ%l.pW/p `Dq@9Ǝ0:@ Dq"88# pq _0C 90 ppC3䀓C 90C 90*} \f'prpp<ŃZч`>`>z tH tH t@G;(_rG 'g|e-ņw>msm/data/msmdata.rda0000755000176200001440000025443112442030660014106 0ustar liggesusers]\E~)@ )$@zݲ%ulytQ:E@ADQޑ MMw朝w{/~_6{v;e[tVrMC j<ߡ jڴru}*}SMM#.` CB0X!+VJU0,+ RVjUz U!Uc`vS`z#0 & L ̨X 6YUBqlR`*p,UYXUA s`^X,T,X%hhڀvC 4tYz,d#7DBppsn#p"p;"p];X7E<#P#xLq OTU*T<] s!xx!xIx Ufu77-CNލ{#Q>>"i>  P +a!X9 na 5#0R`0:c`*qXX'& L`*0-f`flldac`lh '[Y $"XTYXlaIZBG#) d"i+@ȅ /P@o66 m| fa;v Y`*5_nQ{Tث &880E*-À#pD#-#p pl "*8pRN)Fi#C33##?~j, 'p~\PVEUpq\/..py\+"\]u >7XG M7[ŸCp+p[n+wG"pF!a<ǀ#d S3x /ExW^j^zxx+o"o}  |#IO"9cp0(!VJ-"zG`DFFG`"0¸u"0^`B֍zI LL t 3,̌ Ba6 D`S`6'n<@,$"#07,D`H`qD%" #@t'(D, l-#U6W"mjk!;F` `n3{`|3ka?` Dߊa8<G|;GF(c#p\c ߍI89D|?EgG8+?!I~  k<| Bpa. !C\,\+ ~~k7~[k#p] #:ip-[mnpG3w:qO/uPbHx4Yx<OD5SUgk*x`x ^ ?#5 77!xx xx; |k|\,cHST'`Hja*XJE`RZXX 0B`:1R`TF*XqXS'Ƈ`uCD u`J L0NL*Y'U0+VF!x)`i ̮5W'*Y[HTA ̋, -( [XGԁD[mΤn TGWT%*wmC_~hxJ?;͝0xÏ*wYO-~7v:Θpn&ݱ/qtzo|x\+7gt9 ntv{ι[p}[?^>{v{\}I_1x_˨ڷ.7r+FǯOm۱7-[z񾱛˂}b_x;]e_mQ{7ܷ{Xm~Bv}Uw>|^^;ti߇_?B?kϟm1}sO\y rvx{ ^0z>pw].~G]ѯ1h39)w樇DZҗ޸V0.' ]|t{?T׍r>wћ]rуU7'>=f]kytk{Rw*`Ey3{G_GuK|_?:TR_,9ݮ\\?|oCU=vϿ;>}6ˋ۲s*svl*yj9_Uٻ+R>_s`oz=%?.UkW~~RWmr* c/bknO}_U_<Ͽu&"<<(kb9}[o/].73߻eWE?\wi!ޒz38x^7+|[>|ˬSTn׶\yrDTwt6xʡyw96;%Ϛosܴg_s]v?+ۣ3_t1%D-|]OR}d?2՜1*?}T&Mxco+N_轭F+RG߫ x*WW^)KG=;)/}-ڿN7 {.)x+u߾(ϚOr;{۫*~Hs~oMrT=寫zO۫Z"$ÿ*n-{Osrk|JѠs wx}~uG]:KEF1^gył-ݧ],oܓsoǩbl;~NRV;ջ;prÕ7'ye//SV;o+ /_W77>Ǐsr[z6Xiy*(ESomev|:\i W !~?<<=iB^'Ub~y}ཿ=sjAƿVy\?0LW9HzOrX!o %aA=]n$rgK1h=Z廵^?.qےo|_賃Pe,~%<^挢h^b>}T7 ǧ^K{~ofV8䓢iyoܲvA.S?Ts~tr3sU$=~h]#;kW{4-#Uz'Ck;/A}!OG}jbg|Wcg`+SE*yN)2s>L!z[˯s6W/O_Ƴ#r9o4?~f~eW~]y =ێ|e,A>cFMnga*Tc[oQwя,wb]ߧd([; |2z۠O\??b֏!K>&c|h5A~?>_gUnS+ڿ*K2ׯ=5l&Ki\Xa=UƯL*{!ϻ[~ga7YJy[YS kN\藎^Py4ė/':F[e7Z+9`y聊+ͷsYsϜZ @yG4ywi;ע;tT/tpF<ۋі;~Fk~W}wv{m!<`xKvD)+޸_ r>0m;3ޫr/qq{"C8j\n볏LM:nm"_ βwŸGG?<,V3T~w=ϲW 0ڿ΁'߸gs=Ӹ{Wwˌ>s\v?.G|ן3e_KAmr wY~)~Br;u~[^X]=/CEsxwqSo4E<;wʏ1`$8㑗?Q^rqԊӞϾ?|L11?Ûާ,CЮ6_2Ëѯ_)*?un_nQQ8COVE_{^)9t*oan:{(m;/*98lyZUNϳ,ng?g{lmm~{G|=/x5=^'}(~7SsFiq _y>!Y_Aix\t<xs:^IחQ/f;Y;YGN~zhksOXq'>7ޓXO)_'$h?xG:j9~+_!Goxj_k#f?|;tsN܇X{T7Uԟq z. zqM;BIXk=^2yq'r֊C8ߦǃT!Vк֐3ȯ3a7myZ>b~g]?Wޖ[WQOF;юoC\[Pqosݒ/ɵe]Rwn7swwرܙy 1& 3۷u }G {\Z/buؕ&u/J@/į9R*kGiP]Gc^1qqȧWSW9-><lu<ɕt wYNCWK?¶^X@W=/#G_Yا=tߴg!޹6ٶ~~1kO4zsZ|{3c1w*,e//>TBg ߛʟ~a!/Ao^"?a]%+e:k Zuڤo^_O;|d_ןuW1(#bh{ c;"ԎckYįs8wUKsXIqGfswG\<,x"CW:*Doqo^ۓ<ֽ?/a!`iI7E^B?Ί OO=Ry:^źK[zf=q3u~CmZq9xOO03#޵GP~l'L^6̺ g;JGoEBim'gn_u?~OmG_m;hWbω)1Q!r_?wkОg#ÃO̯:Q>!'򻽎f¬'a=M{-hr7_&_yBqS#Da}ooE{V%xcw󩢟((z*BhΒo2z%rg o~ߛ|B+um׳#oCL\ޒGߠz#Bq OWV<19_|R>:允oy|d8PNORr iH/R<z0o{0U7#y+L\TlOG FgE#@~$?#y{wx !Vn55<ʟj_h''CvMr*_v>"cCg<~6y (E!&e3-w/ŗ<<o-WCd_vo:BP^6ͣyۮy{iS3vO֭C< ZG%oP?x,۔nY(?Ο8@otm/փ+(>G^(^Nb}OOw~t>L^x/)bO=C;>L7,֎CSct S}/a+@jvtWwY[Y m3~^AЯ\wF}``U۟G̓}Aܔe񨈫žݦN~/3EA<<3 Ю N짦*j'|=ޥ센5qX;>.+i;@a]v9xdޞov=G}hը~ߦx2joCުE+V%<'z87v>֡xWyjO@Q3ϱ.gc:O RORY]HiH>`Be0c'c܀slu14~FN!/eaf4Wb3 zpmOa]'? { O4v7R~7@A7Ay$הIt~M|AEBK$&ʲ':G#ާu6뺊8R~G^[q"@܁⓶8{hXW<_;>u^9/a?.$~s. ;>g'3G)_·5ͺ3P|?[?v?SP97*f ?؜SW_v7[m8ar{7_LO1I?fi?-2ss~)#Oc˒B͠׏_C= wc5zَ~-F:?9w99z9)//3moj `?g^b9U4oM>,;b+[oa+k3:/YTsL^Ry^HE<ǜqBE^OyzC6iжOM~u)9vȯ<:?k/&됹'Wg3þB{ɬyGys7(j#!mǥ7z)_/aF|?!ߚ<-*/j4m_3g~-v9liS%; v]}M|5ecԯzqxP ~(?0~ ۤqb\OgsQ@^?SM5/V{;eOZJqsΨ_Pҟֹ8,W{||ҟy= #p>4FE3?X;/k8z>_<&g3ֹ &\MI)YC~퓀_n֡zù 9z?[U9*W}Kp=}^N[E.^nWG;? z@q }fx䭸}"WG|xX'~D%hOp˳8w=}.y.}h?p/Y@} m$?g~!/ͯ~?_q*D}vF,<^WwM9/ ؏X?jsG}^6rIwL9i_rpNdNΡ*|gQ1Ish_zn s s\'6WS8ܣ=fstN#q^J:UX[{6$ X)+ nQƂO6k,Ż\s:~<ܢ/[!z6"{RhiOos 86S7V@|w-Ͻ8ދz/܋yloй-k32u)~H.υ3݈߁1~t\:fK8~?7p<|^g.>OwWMmrJQ=r7|}#u6ŴN?'2ֱaGw  X-w@ |}߫&ݦzWw-_|ߋ~= 뽸\'-w C1/T~baUmw`ON.~kS{XyE߄߻ByiRrt^h z7~_zi(\'~71y?m^-?C+㜋y51n֏&>b͗/dŋOz~&7 7.ǾrYM;=G@_nߊ[=snbgo c=~b# xHWyi"qN)/+?}t} -s} _q^~Mur(o6s/6i4l,?+`o!fw80zvFs:D k=Nw?9^ط~3_|BGȏsi>rOw <^!{no/v{GUagiXs;\U;υ>b{-98 ~RzuEgTX_P+?.X]=ߚø=>ErX67ѹjݮE0f.|#=5: >1}E~u2v^ R4}>fWhi?8ha;mW-G j*_ݠ\RXKC ™yGkͽo/&y4!ο%rI({wM6i};Bzz{q~t/!Eߐgo_W@|@/5=<cK/_uٚ߈OM})81W>~~;U/ցzbFܶ5bW~KKފCּG<<;^* HCt%s u^ݽV9WxޗG?籾VXv6λ-mXp*?vqQO|^ q«O~1Mm{9WDu<kYqYCsCI?:i:ߟ?S*ކZH­Q#S_vބgz;s>*֏8~`>ԜsG~̟sMŸk2|MyS {x<y{]Α*| IDzyGRxIarܛosyx"&q3!|=X:vo~ M<&'so w68ހq]yȟɟ|)[XWW~g>, =? [ 8g;,#';JCG.- ~T8U? ϕp^b? "k؏km?r6t [yyȻwM\x4eCRѹt}.Co~ ۝v~7oYVY?Ѻ;ltPZ/(`=`t 0Ϣ8 YIIx1~7w/{]酿k?Νn֛7+W.̄ ֵ+_^@ܬ͋ 'ay$u7M_F,?\VC:ЋwߋxQ/Z$Ccݼߵ(@?Ά݁-?rhm\L2Wϣ^O/;콨Vs^jLj'濋<{1y@n^K/O? 7qE~C;Dہ#kiOXr8ħOj#ӳiQ߬`G;'9si&{) ?V@^d_7_~*vv(}]44_PnKn ~Oywbytۯsf#ޘP~{Ӝg~:LZ_FP9Åx[zmƽ{븰_\C^Oz ?C~Y_iZW7Tئ h}W )Lvؕ/ ֹaf} /t?WkǹsWi#EyO?~arַF^qΒɷ^~ nSxRwcR>d/ρrܯq.wU=E^]ͺ/{aDy^UneGs}z7zaz_J/o/[Lz.OA3`ѿ-. ~S]k*.)S ͸,8WiߙzOF.78"sNvS]g---=Q8<g\&xɳ9?XiuKW嚉@=UL^ɗTj}ZuM@]&?EpDo r .k!\PMU@ݿH4ށ7_=%/IxRMi/ a2 6X[/@Ѵ@|2P(/ZԫA2P&-u__`Y !7XepOOjeWr4β/[/G4Ȇ ehr/:"Ek(ش괬pu\_TYE(b ^KME/b-7 %^l]Sz&>[EM(:~-3\<9]e9V|NߕESiƨlϺhTl$Q ,uij m+"cV E}JϚfz?u'6h*K7#Cf&y3'77%K)baŢߨIiLun}1~cx~ODʱy>K<C<º)p|QiYTGcxn\-(b J?͗szJIJDK\MsƛD}x4`k9W)41GPR[*RDig+9g&ω_7lbr*T%M,3Ơ*xVցis$2Kה7'Ohy;6F+ŧ'5yÛHݺ.>:~AuK\KHsxIJ5T8x&T3ۛ4mb"H2hmmb#P%18Av۳1~GD9k7%yGIʗ9HK"M,G$[ڑA5&E5UꐍEJ>&Grm~SحgOGNM>svS<}Njԅ>RVwxRȆqn&dDsC/W:7i?|t뤦rcC.Gds|BSKI,eJaoX%-DžL2A|Mߍs7n*Vz&tpg%I.c܈#_bLJs7&㶝H6 KߓJ(l7m!|W$[Ə8b!?AOMrKm&n⹿brin}O21k5!9$ޤjbl"Y7y:Wj&qd&{@mzUi7\" AϕfCzOIwq8˪́z8P~V\Q-WYa}W(2G\T#GV1mQL]]zx$Lպ'JvL_ZlZZM>kqDs峢l0 {?(yQ|(Tk˰{rt1%&jqI֖v֒Pg}Hʾglg=27g{mkq__O?WCE5.f5> ~kƲوNwtbCϫճlU1 գOUЈ;v[}V6mZ^~M ס7=fiwGOWid}YmBXT#|Ë/YaeCF4dE!X%!ht m!t+=!ȅ ́-BU Wm | N.v ׁB{=BO!88 a!8· !8FX ]-|8)Nt!83?1p69!Yεpp~...pI~"r W~:W7~ \#;ZCBppsnnn=wN wn>~Aa IS!;Xx xx% xHc?g5ACK^/5Cfx‡G'>>gp!PVV,*5B0R`kcq`u !88.p"=dMMk?5)S]S,1pgmmypԥNwnC#]WLNfskN\ͻE-n5לU?PN݇X;ޛ⧏V .%4-%S[љ9|K>i,y3nR 7F'\tmgn4eƹ}^PS~6m}jz=yؖZevǔjJ6gD7fd~zlE~KÔ--6 2\sVx{ -oFxMc]-u|ooq6V-]?o, .lC'PLr' nf;h9 횥V՚Z>Էnx!*uſ|scYs=ɃN+QFkan^o8ĕy _H>ەo5Cgp‡_m~].SxJM;蠕~ջ*~ ٟ|tn9jZ*gkٯp;=rO?꓃NQk9u~yMMxvoRKN<@_뭺^mOÅqLBustS&⟾Z0CoiZwr麭.6S~hy7+o:kUtܾ?Y_oxC.Om1ϧs6JgggCͻ|d^%~߻֏t] ſ)M!# yqm8vIgC^&<ɬ]<鿏{T)oz--[_mj2k8?I6?-9 C^Q?yծBgUO|OG}O{>JAҰ,/}Ѷݧ^3|pדrh9_vT~_eA?BW4('-yPoһcw1 oz.+ [Ԭf(U[oMYƱzY6rn=;n-+Կj]k\Xo^Vދ-V-DY?)>dw|U|/q9ώy}6GRduϪg;Ϻ޵@yv+\f[̀?۲6cS\gf_+:S79-6^nW-`%s hcy0g%ZW.כYzo[>ݮ.U.?]lf͗d}nǶ㗲[+跎uCz{gԊ}Rmr=fՒ8e?a_^R+]8HQŲ۬nSSʟ ¾c7_²lSV}};~I⍵7l<67 񗹖Y8j=/5[zZWe-5l/ݖY~b+HjʊYϛǭ}K +3zo/WekdZ /u]Dd=)g2}F_:/А{k%2YZKe/[u3YK?rZuWV=յZ6ڟ}3 Zu=uo_FmT&¾ju#rW3jͣzen_<4(ō;J뽮~!U>-Ig Wn{R¢LRBwE%ER_1\G?1O$ͳ?3bq)1e8 ǔ2ScpL)1e8 ה2\SkpM)5e ה2s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1R_;n`>|c kA\h:qI5pe?pUN\p,NNG- #}ux8c5xUx*ԉgs y //Ygx U'^5[uS'ޭՉu|(𑅏'u? p| Z+TJ5rX%։u`Uf:0:cX#0>,[&W:1̬ BqhxUG D $k`N̯E5ց訁@d@gtׁ*VA !(D65eت D+u`[kU5S \_-|=k`*ػ }k`*8 "pH:px]G m*8  uu^SBpj|iUpz0gT~G BpnW \P%UE\ZE\QWFU:* ~ µ?5pCpGBp=Up/p"q>8aP !XI` C50¸U0A`gaR&WL  !¬lCMCX" f!)0G`n`, E`IZ,Zh2!\ !L`laaK [E` _1;[E`Wv { },klCÀ-!pp1 #p |N} 8Kg[ #pnZX~aR \nJWWYC[k,\+pQnpn C.p/px#xBI M) O <#/x'*oo k | 𡅏>D? |A!P ++ $0 XY``U`5`u k F F X[`u$``tL Yl p<B%hR@, @/VWN.n7o #/?ppÁ#cc'N~ 8 8 SgyE%/Kˀˁ++_W~#'f6v.n{< <<<<<xxxQU-}c?'&?z*[n@OTe~rkT'Sxmյ |M~3Zpgn|Zx߾mbpwAoR[;f=ՒOq<ղϹAS->_֪I?xj-޴ݪm)۩x鲵?V Ę35GLl{5?vWfe5Em5t+zժT}Xn*fU"(S%Fj-OrWU{F<ڬڟ?כ:_3\z`R{@e6#%cf?*5J楛6zaJk*] U^wZ~j}/T[{v*jϢ9߫wVRۗ ^M?.> ۳^/GGkxy|K-F{Ow̿'UN_ҵktӞ?IkUo tU9%xJuMӅ~.û;AՃ{Џ=9bSoUsujް[}5']ΙV j S.5(/Zo+:eg-zO-sdϫ%ז -?;z=w{C&=GW~xUۺo~I@VTmË&ն(~}^0cՎ~hGTg-WUjr(E;飢d?#fTfmM9m'ܪ27ײrQ~ǝԶ/]y**MgE1k }*MqZϿAub^vge~CTmR@@S?,(. _Feo=-b,պwnlwg?Um9Rv랪1*ݾIJod*Ւb~dzWfvT-~o]?omKJ<_9Au~[dU|fJ?V'xKmQlֺ#%b][GyR:_?\~}"k8HxG^ꊗ~0[z-+ռs_be6).cJZEť{{HՆ{i߶?%A?د?-vi{bEW:>*MST$gުRf}JJE}Nqڏ23:/MYKL>P-P`%,9cUힶҴ{mV(xK }̗WUˋoKji*S-IJj- sEy,kQmJNQr~{~X`S%j17}%R|YzjIEƻPUo(xׇ>W4ݧ:;j)umk 5W)".MŰEw[~^zN}7w}ƯD:Bu|R|^KܘJOC2~.JSs_=a거VJ4ZM->Rⷵz>r#ү͑2>I}y;vtmW-X?LQ`>h)jny/VJ惟@T&vZ!9L>~:fNd@mRnǯKU6*;P%RE 4X. 3%U췶KE-_v!Ë=y=؂y {m;Ǵ=P4[lZnQ4VVj%}isIq^7Vm7 "z~HІ흎"m5Xt;RN`8OI{NO{n]Z5Wj!П.&\r[e0nh]9;m%m\-U2~G%G0vޢM-[|GK. jzDBɜOtd==[+S_R0+fMJfK٥羫br:Ts5RmRT];kקH^z*)Ǎ۪Hqit=yBGJ<_wT& A-ֿj{ v`u~aTj~MCOe3rhmt^ ru{Fh1va˿Ԋ~3 r׆8F; S򷜒;Qy߷}"u[񜖒~[RCW֘(Rr83 vg0g}?u~G0~>Rc~<[T/~a+mmwj98@(>y+:Q.-]`~?Z|ke|vJi9L\2hNq-zح7uzl+Ռe;)/뾩|s%u}#*dwLG̔S2_)JxZ\ÊJ㗹D.t0RAOc%^-ŕEtZU tb~nm]\ W)=wH_#nЁ8[:ΖX f})\wT?Rg]2/TiCҷ_`u'W+6mwǕGn-'j;~ݤP ~98VOwG;{+v"sȟB\xAPnZXQEY]`ivz>Y'̩v&oGz3R);8jOˠh[`em״U;₭୶aunN})ďm[rJᘇvxп ] I4lOkc՞:zpqi:?rR(ux\`5B~F- niYA'-hu[Kݾ8/b^r vD%lkk -j?秠xL;KM͸ h↩'j` ٲ⥈綾8>x)ڵ}ZjY߀<]NOaJv&t͚_Ku*;6E9ռ@O"ײ]mЎH;ہq#ߦ`aצK:tBt~0Bg`u'7NBO,S'*Oa~,FduO^QO2/?7;vC{ x.N)u~FWW2,WVmX?l]q6j6igTSl؝3Ts>gb{W?֑2Xڵ讽qzS!t`;>JNy7}l(5D۽пɒX(5 OwXׅ䔢^ )pzwL_dwD|e:B;;HU2T|/2R{?-^B9Џ}㣝>8}.Im).U)#QjE{ N=i\G։8k'.nҍo.NƘ%;)fq̓~_R ^7݈c`}_o[T.ݰ{=h0 /z#EY?;`?P9}`iViP)BN#*`#AZqi/^tf/Wt/zXu_ΥUim2e/z6, Uoߺ;i3?14!/_:wօvwqU7=Ȗ?H@[go|b= qv8p;||&N]wc&=X'ɂ?;D.)?2WGzŵ]v΋iwa7c{툇v.ML/OJ#:񋱎؆|%u@h$C=_zZPś8b_tn]XOW77=73;?]x>A>Dvx]𷻰؎xY_C|" M2'{u^L^t`:ƺ a 9V2G[%j^ZGZwFm`w7/\O{́>{892v =; APCWt#܍~"Ozio'P#Cd+Ik,#]jz]73CXRS٠=kn{ZdgkʂXJA/{_ĺcq.nȁs23O3_'.ᮿi} ;V7H`]y]XBi7=5x/BBaq6s;OmwP"RXgLwЍy>KLJ;W">$56s;vtJRXu.;Ž>Jn {a}42^3q=ӍȃX}@X"{$ݐn[]݁|4i;k,42w". v[7>]l@Ńq*uй=~:܎ QAZUCܩvBߴKyA܏ elA<y-n?mz|;gG#G=);F?7w"4q5zw7ś ]~zKY1 |6 ;zA뚝.sI_ݧ׳2ב;ءw!? z_X?B?=ډ.g|v_+z>܃ q4r<Ї]31qh[m,֯xNKa_[z4%<4|dl'r;!7v֙vD]B.}u.uC`}3VWĹ:auR3Yi:|ˢٓt ]n؏ż^WOr%tjQ?ky@ l?ߤMc?E9X:l7' qg|-_v]h75@NH>:H!#? 8y;AZh_K6mC߶BڰцvS o3}V۝n_yU7| A-Xj=Ԇ>.k~|`='nQS+h^5Znl߁<9BƼyu~_Ku}W_ {!}X.@;Ѕ򛖠Ÿo o#oa Q[?JQx_"EqnF _!NPېw?WBv1A?uvB 6 [ x:XI!:s]PܽmG7f -:ikzu+5m[M;F+忥GHc}P$ƾ$=8e.oN_]/&{~V r|3'o_~"=3X_c+~@=?븫lGlr ^؏r7M)J5NrKE;JwҾ_ȞVuT2?D j>xXA,O;C;H`^ch췆_;]JŶu+lmہ+)'Riv/@wauAKS}3(Ing`wb*}1/}cAl'6]O~9߉>F>z!M{/0ۻSe_- Uj. QqŨG2E~?A:B|7*0;n :JcG4)o q:|~QRidMg;)3HmZvjjkP{//:}iC1Oy%s7 1WQ Hqx9~Oc3ؿzC'L]}'X8t6E=2ȻHR'z yh;hW wB x2N{]vft2sudfXeGȷ|y<ցxa 3}ey)I QCS~O v7m;~J4Hv#^5n)nՂh+]M.~ h:Džu$G'.tß5;O2/ȧ[ua ^Eȇh<3-;`?v9)k{ҴgWtb>1Q =ٍ<f.gډW:G!s9Q/iPK7{ WY׈뒾@u!цuvC'.׃}/2dO ylφ:`/_ƾE7cmA]!wt"n3}G'֟`?t#q.Ѻ57!. ׍%'[>S$؅{S^٣݈vC_iE;W v Ԭϣ='kK9AB5 #^7@.Iy,ߧ`7/ۅ}dR=) .sV:/${yJH~:_AQ:Fh_؃l`gyӥ<'/KX^Iidځ)ivwh_ljuCOP^q>º}\ʋDt/zx< |<>4 m/(_:#s5hU|5y>󱿰@͐; yXdG~S;؉|.̿n)#8Pk o[q_vf[z}2|(Ay]9[h(zf#Qfv+EF7"ƬW/L4I xe.։/,búR'}'Ӯu^_':΍is yA֍unĭրT'o]װO݈CQ ~D{S7/>y|}iFF|-[tn ՜0T|]ȫF|=;DTe 3#Bz9]n m9<ǓƺS'Ι}ºa8] ŷ# (O4(r5/D^1;?1=>G K7}@-_NGojn1ns(q4s۵:߃s`ށ|#/iNV z EJ/|: K)t42XNoс4]a_jyCz q6&J7q E`3 ?mhI$u"ԅs!Ӹ.MrF%W4x!C|/B牚<DZz 뺱)Ľh@efa_&~R ;0ݸO!c^|nAMn'H4 tKC>GB/^I/\;C\ƾ /7*:'!BovD'sIP؛&@,{ \'藺^ІxA;g/7a>.sH^QNҾAsnRjDHa^~)6s/a7ͦ.w9$;9Ts=Wӈfͺ9fؗy&_| "OY D;! ]/QW9Qg{ cC{ g=N$yBng^FtqCܤ^5,/U#0OGaX1US>Z)*0Ԩ`_з8|>!7I5 O`TqԈS_i$I۸4yza?5,jD۩&3| O~uaAjDpfj47LB^vTS5㾀HWr QMA{Gqut0\5&`{-K}+Sjt ?V!aN A|p󼷃[TWR`>m ޙq"'^oݣOK9!kԤx4 \>gNJk}~x·KҸC Ѽ9&~ɫj O ٿ5-|+8a3jXjtiRjJ )GKT9?A|~xUMrfyZoWi.0U5{MCh8NLiA<,52݂̈́y6E_Ai\a;xo~{<4!j|0Nϫ~?j*tg*応h|N0C09 y<=(H5=ZR<BFF {狕9)A[sρ\}Gy&o`x5)594,-rv ΁Fo~%j :T~^\ZC<05,8Q#gF^$4+YuVkG P =˳֋ J\ܯuA|.'#0}'~rS!Sr8`.aoox-nRca\@Tcx$Clx3|sՄ +Aa*x <*|]`=BO쟷y0b;r4 <2r}1o[o^Ã|i\ OMzm,x`e55=cGA7|4rA1BrϨxJ7o; LATs{鹆ziu5Er? c>yvG;> ξjZ Ì8[]y5sy>sO]LM jy$1>mXh훙<<۴{ n8?ߏ ڱM]9;o?ȳ`\,όxRPrzwQq &3v.]!_~_O| c̼OBǤ`{|?J:j?!uiz}>Opͺ^>VBIN@~Dd`\'A}i3I5zT_/4փ hDS7MP\fIx^s أ&{j,3&~\\Y?P\q2vRpd5Ka'`w>F}I~+?t~@AL1OQSm3$]avN{9űHP=tFsL7*|͊oq3>:Ad xS5k:pݨ#5(<m1AH5.؇ZGuTԇ(x\JٷG܍=zқ4ѿ%4>?Aч/FL{Z'?3SGkQdQ|7>^O3XW\&;J87ur_>KMfa`?_D;s|=x c%@+Ԧ+<>稧W&FuvѓaV ޛVn<>8ɬ v&BO`)u<#t+jhy709䷂7ҿka78?&ct5M.֛$+cfܯU: Aƾ'C=;` ?jH'<)NLv r#9x3 1]S\`ԏZ[_|?QۘoF.)c}n8+0X{׀uq%uxf} oPp.hZ0~Y_yA gr1vhXYGZ3oll:qSjķv Q'Vܖn}e qcox)*k4?~]J?u׉V!Ap.fO?wX߽FCN yÃ0ƟFbIkT/xYAP8^#GPǃ'wbLϡxKaYD ?R?q6-(oq(TѰhN'އ|֯|䷓FT?Qv֯\_x;sj#?xxm=;OV*ƙ%u0_l|>ς 50]'6_!?vy?/A dN '>uFd_hχ1cߜtVȡB\Wˮ7vG Fχz}̿1y'TƝTr9arZ7}Et/'gl+`[ <~.7yatӃ}O1O r~[k=܏gjKSo}&hvJ֙o7xN?@~R@,XRk>)_ l;N=),֛,{Kܕˁ47hy$lO&OzW1/ҌrihΟ"X>?M\w~I>OGG\ʓU'dXnp(+(.N]OqvŸ6xo# ?$x_at;~;5Rv2ɿ䟑3E͸)zK܏X1yAx^2ֲs 91qAX?ߴ_ D+vpNFS0!!}gA#(}?y_1!KjS)~@ Uro'S>fofW}=5+h_&k??Sޓ#rjմn4%O ? 8ghT}^ G4W)Ίxz8f*Ǜ=k̺Ta.ɖGcNަA:Ӕ`Wȅ5`]?mmy4N$d?n:?'bX"8K |FAY7~RNJX'n?'ޛ㰕rG ۬OQ}p ڇOz]#)~<kZ#8_A5 `j` ?A \̃Ki9?F}x'.~~ϥ8n?|2K׏95LrבS9#;?{VOp nCyU,1n=AOtZ;8׎eg?AwWsW&n[+y^-O&Ok̫՚bd`~Ҽ͓9g竼Qq=Ѓ~6s݈8ǩ1^W4 V?oǑhkM{]x|??OX[B>|}Ή/sn_ێh>S9+gۭ8H&덤=1Aʴﾢp/;IܱeGCG;3ksZ߯A ~R+|~q`uKklY+V<Qg?i2NO c7y /cs^ 䙌(ϟ0v;2.&m_!cun_~sΧP+!5L6?(AvR;q:Ȯ7'{|T q%5F_OD;򸈱}nch{}x\?xl0~Wp(~Mk?ǁ YOa<5ߪ 2׿,qyqA@A wZss o 5^7q"?P#|=%<^4-uv|YPϜC?_Ucz*_OrNOz̧;_zh|>Fc~F41zry<Y5>X;$\Vye<{3}:Ś 7> ~x6?Gg +'c"uIOrpoqPk1 @A` 9o3W]=7?G[ng^\xS{=켑I+F[^Wǹ_5V;Fn>ϡln?(?,f c9,'}GG~PY? oKz8=9RέR+59a>RnO9Ntp^+ܯO.稕,_|ER~.Z ?-qWe?_e޿*f~Y_i/3/:|?$y~dך_ c?zt@ Iay _lǬT _ș~ ~PScpp.{-iPyģ> 3os< mԠ`9ϦCeɊϊ7.+6~Hy<\A%n,)_ɲ+w@_L'~..~K+^ .yiosJw>9˼>XWbz7穞 Qeoyp38ļ35 fyo_DuS8xLiaDXQ@6C01V`a?R'&4K=rR7:6ցq5PHԚ3Fָ}_h}:Qo_LjXV'։U`(a:Q/W1xdx5ggYw6l#@cP3ա֘+?Q}QQ'b;Tjs?rꕡz z.JJw>S&@XZu3BPD J֪-Q+avDc Z6K-n(;z*g7o걹yVjף=Un|qΣjQB5՗Rƫ-QKjH-~WوC}ZcBum5άǮ :MT5٩V)a:PKרZ6S:dj\#"As-ϢFx @%}T6 ͪ;;?q5P6K~H"dxSո7$sָɱnv ԲU6Qvl52) TMո*QzBH 9|ZvQXny&SF1QzUHD=+Jkť]ȾǺZ<~6?6RWa2SM|qyahtnT& PE=H.Ya2<٧au js–kt Y.ӲacsV'lk˰([1 7j H~~\@l[v0#[|[J._0J),_ɱhdkɄ'^{>RJ֣Z (& 9ķ`˞g8;sk[{d T/ s H$ E{)4f-DɶVq !djWB@>vn7aY7_O*9J>Wʔl0!ʣeݩ\ish9v;$4wj%kujG_LC*Gc)GGGԇTGzƜGOe?5M!=)zѳi4Omt}o˝wR[T?XQwl;غm{2 P_Pv'qƎ>FLQy| so9=^>T0ۑh6@mYXA .v/kYco_}YoҞ3"_,[:mq}/64fKCޗ%]n[3@K s_ժ( ˚.u`}_K،BZe߿Fe/*s޷e3SN=oEGyFwiI#o"}lo[/._=C(xh4n_4] QxK#*{)ዔ㨱$ d9ܯ՟K_ \~9Eߥ/o>2ei:, t_|6_VcE___V7RN_4r~i{3P2slKeytiUF忞.Eɲ&R,2Vֳ^gL+ KS[UqtRHYk|\Zue>:ҐéDrn5!}YOoVFRjh/rz,Q#uyjw UjG#Q,Tfou^E]#Kԧϗ2UzG#sW[3]k_G_e\md#튊EVǑMU[oͧjTlQm_ԩ<\u_Ǧ66*-+WW u6\|]qy藍Cl _o/ I,1hKzd.fx)nwM5!:8(45UvJE hg9 auiMMAҟ!v'VW{]#}\3}d]z^mC~/RvggS]J}Um9V&!Mg˰zS8RaLZrAtKM3+5r@yPͥjz_Q='F/߰׆>u/Ո իޟTO[뵕hs_ٰg4:V)Eq~_8RԪK?{_=vy=ϫ{;Vyߗ9hj/,Pަ{g__dV0$ڰyhi~ח?]^[;jՖj_/՞.(7רhY}F6&l{l9ϫdST㉰()plC9%bF_=6otX_x0*U~#Ԩ.iǽSMM2W={& z1Q}T\%W/ש%t-MMe4Qeʲk}Q{Պ_T]Jj5#CaTkwtSseuFtOԺ!~}Q󲞾3G8RVfgWEqST9K6jUFZ#}Qh0۪޾oVeWe7W>.+ߩ?(٨'Vd?JUF%sKWKzF1y-]K0[ͦDyx_9f%&'Q0:ًQ:(. ƝIggQ)zI\a:r\8ʿ9%/O>V(5jȰcCv2?w$/Q(*396v=W=;l|٥( kswQY/jW-+?OC80TQyծoɮsXQ튺>lg/\{q>>ߨWɾv]Tx<ZSQG.ۦ*۠{j]z]aHD}_s'm =ϭqg|ƿVzV3j,S__ ^ e۲?϶Ǽ/F^CCjWy7gDS}r}_qr#ȸ MSZovG9j|j}ۈ\TʆG}igL/J@?L)չZ6)rҲl^fD9vM5ZPoZ}]l+^Q}??l~Ft-0;#̶o_P͆@-=SVOגQrc=3jS9mz&afkGo=cU_5#ּO՞KQ>g5^8аbG}[Zz0hOlD}qk{\PP__+Lk͠ʩ5lgغցQvB=חq&'5N:y.jPb]_KFbd[:l\(yb_W/wè֫kSs5~G ͥk~I#vje'o=eDg=QP6ƵvUZ2U]0ҊFe-l|z/3^M~Qu=}a[x۶z^-_ziŪjXFu#853]H9Q6|=m ?z7o>ߨ_+64XR}Zv^Wjs?񯇷8ګ?vm5zn/uF4ǧ?Toizײ:.6mP}j+~_uK%9?﫼 6/KFƭ/Gpw9-KC7\,-ȽKa|6Psaip#9v`#׺fisfzpY>gi/ˆ46fڎYvZ"ĨB6Wd4lץu@rͲf4_}k=[F탥=־^EضKno]3@|x6*WOhK\>e}iY5V==Y%g2۟jM} y]k{#e~}RFoݾz XYϺˉxmoϩZY>׷{ lGzF۵˩w<>5__yUMe^uϣeҒ@<5x_=eLϭ~֣v5g1~Q|Poy _zD_A5}kxk?vϳ_- y_>K9.o9_?:>֟o>ʮ_|Squ^_ i d.%}ZzwjOTץsk |A|}復׺y~o>}>Yw4羴8:[v|N_kI_k}Wn:`gv(Y夏~գ׆[?@09맾j@:yS}t;*ʏx{\YQ0{ ?z4 :`}K+/sxG+_h{/,< 75,_r]/S}{N-z^k `j~[eeUzFkҖ끒=qzҖ/{~ Q=kT%wM]E@~ZΗK{yz:K= ըg_]Z~==^i^o}^oZ_X_QݾF7]E祝_yQM ~߲3Sz4tpSϋ)}JЦ+d{7›!3}~ ݉5iwśw<`}wޝo[۾a{nPifCq?ǧ?qO76k6s\?7 ǔ2ScpL)1e8 ǔ2\SkpM)5e ה2\SkL)3ex ϔ2s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3%>s\3ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\c.1ĘKb%1sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3ęK%q8sI$\g.3$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\`.I0$K% sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I2$K%I$sI$\d.I.<ېI+1B_,m6rE͢fQn(Y,m:\GrQ#uD(:\Gr]Q+uE(庢\Wr]Q'D(z\Or=Q'D(\_r}Q/E(D1QnLD1QnLD1Qn\EqQn\EqQn\&D QnB&D QnB&D QnR&EIQnR&EIQnR+YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂_5 j|,YUfW͂W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#|r_9W+G#| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_\W+W+| r_e"HL"F0`C ' V߆B9dOK2P%.4GlI4ߒןnE.ҙ'9BD ,#ؕ`O@?FȆJ3REױ^4f TP{qZ'ڏ?K&'Y F %F"5Kи@Z Z1g>'h\ U4=AOF%L' ~=MЏ`mrK1Iڋ"rJSƓܙ'u $F0h,aGx?O4(BtGK8",xGh"'>zDQ(A)`;Z(ZG ;l+^x1Ft; U hqC1N~>^J@4 ZM$/8RRD))c4Et">MQY~Y4,j'&ݑ}&{.ۯfOIޅia0Yh#B{9փt\tG(z]+F(Fc} amH.NIiDq8e!A!Az-Ar!=" ,[C3)ɂT>KHM@딢ˢ΢" Ƙu_5=X,!=4ے~!7!'a8 4LvFh0L & =R5d¤gôaeaЋ000Kۋ|"$"4U3Qj#J%zj(m=uʾ8m`{$ HFM}HH"ݐMZ8[\lAcmgCwZğa;!#43B㌐=!9!!ڎ^GX>E޶r?C! dGQZh2]tsQ(3Jr7J\ށuxʙ_K ҳaC fIIDžI/Ii"7#BGTiZǬ~o=ZC@d?yt/qdIFI6EҺ[ߗ YvdyI;s%9KlAYKZV˭/ \&,L'k aH<v8Aacᷡ/oEY_H6H7иwƸ JdѸIWeW.\gO&Br&>V]ôa1>ogXlٜZ-l>Gi-D[.f9%ҘQ'kַ4K#Y###_nGňnw' X%1'AjI_ƚvMzB'|lfuы|v&J Q&?!/!@=eߕѧ Y΅r!r:;`5|hĄHV>mmejxحm~ 9,kB4۱ޱmJfͱEi_"$Lܗ0 тtĶQYŶ񇓬u 'ĬDo`;c24'E|#L؍!.Bb|EIIIilPc{!k'U k= k%CrĐI_EHh&& Kw_bN,+fT+7'<~/0:oa/b}vO9@!͜UZFIF ?x:JrĘ߇Db{t98]'7M_~԰UKas`ګq8Ɂ8m ZɊɲdWՑ]Mphc } td5B$dlN;_ φi";`K8%\E_vxblq\tUt|'aZX]pFF7g+̹h.1btnN0rb 4ѹolnc߂mqUXqliP^X?̃$?kqa19K_ {lb$M bh 0m{"# ys$WM5Xe*9']/4(bdn,gi<ѳ'0k sp.FF$4$y)ao@94lZϜ>sɱVc敁!{Mkkxdbd+$Bf /YO=!9yD 7g,ɷ3&^#+c'JY2JP 5868٤ $GEZG?K?w[$rYM]GϼVX=`g}<:l- 9Hݱ?|6d{(Ds bliy9}"d)/>WZeerm,LÏ z#@M|e>&j8SX^{s0s,mq'܉̃XK@s;@NAx,?ؾ`LK1 ˂181 /!J4uGɆ6qG88 N9N㋗:41[;'cO_1$7"A [okf31!yqyVúgyɈ8stK./I>&HE|Fpn*5ަhR㜐3/Yx?ٶ tC|آQ6sb_.OY}̋!b pXji&_m|3̊lic_βu7o`. MimGkj|o;=yO]ƟeHkodOl"~cDkhIƏY-+hm)Ik$*I#I4\em?agX̹%'@~8}#y8- K?oply zʷ|nG<^f!'a[o΃:nf(No]ĩ8um v1>9[;jd/$iOhRG$Y>dXl!us69 ۾u߁>dcymiόOihkw' ľdYtBr34HIolm 仉-~`Ygf21#LcCvvsaD=[2ʲ(z9.JdԖ1Y- HI/nӚĉ/)A ]!~b苐8.1cld9^*?s0yL+@gޏ3Op{oɭl>B3EtEmpqV {k|!m j;1,vǩH/9NIPwiN.=T)=e >.> ǵ cDK1Z7sE{grVXM"UXw@3xn4o:l,$ǝN*"!Üf&ϕ}'&Mw+rx8x{2TWVOC.ucLԆw $sߜ$Y$O=g\noӭ\mysE吇,ܘ_g㳷طyXR[&|[ط&7h{ob_AVl/Ǿrxo˺}adG>|JkoP4]h7N9rYx9Sh͓/۸YkM'D N2,JmFwWל=K|ECsV)I#xw9|<ҿ&FαLNrl)lH ?Ŝᐛ|11&(z=?D>6H>81]!Vf!)|( V>D9>qĩ6c⳴e>xۆt#M|MPp6dtt.$c+!ΰhK}+`y o{obl8͂>'N"'dj(dXvELċy^dzq0u<#> Jgr׍M tA?˱(3!W/`?,?BK&W >7'ˡxa mdb8ZYmb]sv|>Ky(j'1 ;"׉d~}ƚxg$fRh-E|E$`K5g6?qAd~'}w8nȴBs Ys>d6S6Ǎb8^2߲bcawqlA_V%Vdr+ج9ag3p|7}gsr _"ݗjك))Ro<㿳Lc3'{=>_ɰö̢=3VWc~~ +ZGC)d۳4NsƴkhM5ǧ.mr l,Sqπi;^>b_Ĭgy.P|sl_ء#KӼDez KN&[Ԍ]"S/lGlែ3ym-?63gZ>Xm'c2iqϓO=!e>^h\au`l2Ty/G<`\??DtlbE{ql̍i&C<ɼ8  ukiӛ0tIJc|gğ&},olAX[ğ|ƉISdצDs9¶ Hx`:O`y=zf_>:S]hMn18,cٲ&g/&d3$m}ңK;X¹f0&>ucht a86sVv}18H+9Ү'6Ý#W2\|F:43F]o37]3ysZusN6-;&t!KhM|Ĭ/ص؆31$;͹;yizLdG6v1 `C;B='9br #o@knL~ĩ~yS伎.x:cwY@;r4dnFG2-v{,来]B{)|bP6ziO_3Xk0d6ژwbqq_i`㓬HP;Iz6Iz6d/E| qK|iHV\w6jh;W^LͷucaN2R{/ ĸ}Jc@|6g+$sD;pL2ۅ 1ylgs,~|;t?I{c޽Ѩϰ ?D&e)d;]bmT;D  rV-r#J6ɷ{,=uKM8 a9q9`;XG`062tk7Y=a"]qm >h-h3'9Lzka9^ʱ c76/C.,6+Si,h&ߝ7u #+}dryo%ڋZيg,niυϗYԼq; bDm#`jIfHow]sAs˴C㌟Ew8=~g䜰O&K0&^>&ǂɾ4$S7~HWrȶ x iM܁D_&>{q&9 }sk>G4B d9ZwNv^Vǚ<0^ϐCvgM> >#Q>2kw%2`&gmPCuOv(DOa_rBĜcAlks|Zƶ&&z~}\},>}ۗ|^m|>-Bc5gLhX9 䗘wYLg|!g^SZimxccX&sd~-jSdÁX =sĶ"R3s/1>{67Olw>8Cs=h/|0cJԟ'{oGX2gLwdKs;2bI샱g,iOcg9IpX0=9#uaZ_CAhMК1c0_1?&mPm|vblI~ d E }7¹ Ԍ)k=1$>f_}O@60/~X=d#i^9xkКyOY9x,Gdeq%9'g@'>eY& ۡ/hc8]o>o2VY2?}n1yp,}HÜunzB׿`К_/ ;c&|"ӑM{bAs2Ht{?KbЬ8;ws6K4j|f>x66c5=ȉ&9nZcD&-'}1l&C)Eu9: )e8+N:bx߱N]0ٛ`m px|I:uL+M@'w uisN<v9fK$[|{c59_iu!si)^=H&ןϑn4|&~l('c#(9'.I#Β⼕cNxwj!+"I=La⎷YT#?ErÏ'+>Cݡ59wwH'ۍy6!8o!y=Z0qt,vY|78;ɦ$% Ӝa,΅Ly]d}pv:ڐ-,/ |=1lN1zׇdɫOڶcBk@u0.8J3 =B6z_/Hߙx? !uz!>Z 0|~ 3уQj?qs^g#w[ˬ+К|Ckr|}T41g?jμ<}YѧyaNzk[^`y;SΧqX窚/wE||o5IGgm%}]|7a_h|_p~ŴB:ebsG/rgc޿Zw|03óH{b"yxnFvsFr,Ars*M3}dD 9[50k}!.D]ދ59zPh*dћs> 3Ma{^e?mv& ͹ a_73\.ގB2z&lx76=;/o[007z|o#'Z4`ۅ!n2Ǒ4_sʱ"M̔#lq%00~5?sc;O7+:x|τ51ߣ 3 !O䛰#YG=<|h7kY/r cŜGj,,}}Zt&. {䅱ٯ!!sq>|q//J:ʜ9ͮY/C염Zc]pChͻς/Xr|gl1>~ض<{cP59{A"C;*7|S4';x%e9Nlou]D:/֜ Ot}rc|F+|fki9gOc1O̔xN[3n ץuVy|l+rd\dK2NEsqFPxiNV]ރ/Aϫ⇶ῠ)tQ,JߢqKz/oM(xKukՓO{ ~@ ,'rC<ˮ{P>vz6`@3ĺ 'SP{aK\N r+v?ܟ߮mε, eg}*6v l]t? k˂xCJ{\A#qH=gaO2iOjKz벞/]G0o~ar_`]ѿ{f#gqI{R}mAO>egk.`qIK/>>i[_ԋz 礸[&Џ? XKYƵ`7Öޱ|#ؿ^9<$oUv\r])@#ϗp >ߠv^^2`/Xv/닭<_{%o4] g,9K`_(ϼBԟ{'eiF'"ߥю\f'^ 䍷YSdn+kqL 奖Ogl-X/]aa y Wa\U/o?z ߃pv>)Z/S?pMsl?"*9ԓS~V%W~ʰO_orڱ鰛Q92N`s0?>ew3aOuyh~b^0_ Kr0/a7KyKX[ۂ˄'հ{ ߲rQ-,_ ~1`\}y'y r||>s]xߎK\syXo]3S&b~'ט~OҘCDӈLo)9 7A;N>t;n7OwYc3R<`\y_0v]kvk$.|숳A;^v=zPp!gR?? zO])ϩn+eROsjҞ+=.ŮyN~, ~"  #3و#j;3rADą=o5G_Ov (xR/gz^ol{r}kb2]x_ǣ@3˄De'v# }c-}ejo$mcǣ@үͱR },Dq/a/kbgE|4v43`M~Dmr u< rcK3J;~o_ׅ)\bfK;cvC(;x>'-KWsW|vh{`2xn 쮋a1J߳Xu*9/>)S>b qB7q-;zi|UX_`iF=/S"9B δT8˴_ \-Ȏ0 ? dd~0q_<Փ?.\yI{szzyuyNy??ʁ9r8gJ\v7.xQtCKy*π'c]DGʂ$ݿ/LhB:uyik/]~N_W|q|T .cz߃$v Ɓvj"׋v,rtOlp:t;-;W[3B8r. 1c9)9r\ <5rFrzA)I?Ҿ3w;[2#vyz܉!,2ۿ ?@m~Ĺ)# g(jgKןy9<7wD~H ?ićҮܗydzޯ/u<~Ϟ8=rU߄EY2<5{'\s"C E;s ՘+N,Ule\~}^qM\_|"JwByRƍr},K>@N}qVʆ?W1 땈WV=i\%8/cѾ˨/gN7 Xz`c|z!~POYz*}srHkG+J 鍷"dRK*zPp9~W e¥x^qqwRqpy).8_gz.(㹠=)`n<>exn9 x: <\9'97γKjлXΧwy~~O9?9,"rN!RF]X-r?QI'3՗vKa}#7ūϨ/2;r/ vE'XΑ~jv!oR>^9j;)/#츥$?ٶ/yX m_I^D9ֳ;+%BK&v!obg-}˰n!ǃ-2GY%yr$z[xz % ;Ѷ}r(W G _9UO}/xn1)[zsɠЇ'N>iء.e{!֡[vEV͂;dԟ3Nӭ<FZ,-v6` 侴ח2{Uǽ< qE7~yv֋Bnq Y)hKʕ7.XߗJ!_.rP/`eR?"r]/? OD;8rfzY\x8YvrhSџ<' `_yK>z };(K=_.嵅;qT^xTaωxjd>ydOAu>qIYѾ`_ 9+DN|ғ]%uy?ؿ'xBA/G\=~,9|Ey_6\}u\ ~3q+OAzd*.E<侬Cli< XO5΀Kq^s>Ћr.a9U r>[ۑ}#9,HٟWyg.sq #XK08]e~;ui_/)\:/sO>ʹXyND{Ҏ_Ww9'z\χe|_oVo/q_z>~#U))}eO^!aC]F`.eQ'p[w=h7 /口Js>8ד~|׹/[: cC.Dk~ԎgدsRQ`\SO`GIAho+#*%KRa" 1Ű o/q^rg,KXm?W\!x)K>Ωp/q\\I9ig:-  xG>l #Ю85q\=LЯS"<hNA+Zq)qռɐWGE2.־ەOە%~=_;s2Nmw.}z{A}߰g5b7T<; >B{~^1`id1h^0;OYv~wWGg9)K?Rܗ \# {l>䍌#ysq[F:7\,קa,f!)S|Ў؏R&3t8-JY[~A^?s~;ROMM R/ ?zqSo8LřãmA%_{oA/IK╥p~<zx>DΈ6|=MR;0swv~#3Or#u9?>s!`_12O]/uA(zx~؟ce侼DyOG#:9'{ulR2_'XoGHʁ}{4Q{(;3vn/TeXK}NȮZ~/-`z堾~qvؒ?_ X!|R$]\-Gǹ̛φ,I~czr_RO]>寧Vog`/7=R_ύ_q-}'!~82 ŮrF~?UC?4~_=؏ ފ2 <3r]\.ga3r_Y|`/ unޯ/o)8wSJ5=Kg|N~{Q)Kg@hWT DawŸ+W{xXU)/[5~y+r489,9b!ȏ8 AftLNSa,kGJ=iWl]W^ߢf!r,\3{[zXoIYƇqUmn-E .G^O̓(oסr?}\ y?!:<3'I̱wK\|tۯ`g*)yLJY/L?$~zA9.k,-XW),åK ·ssϬbgNx~V}ٓ` 8u\0Q=R]A)o/,~K o ?C}~>J }ʶ+t#y_Q|cLc /L8)BoȾ \̂\~,߃.se觸/#[%8P=(Xڑq9iԯ'CWe\DYzrʅ^Y|Kn3Ag_4qVOAqh_p`^-u) < jA{OW@.셂[ Ιs=)? CKBTߏJYz| JpJ?.Ӹzy|Np'~p_/}>,]K^W=8CS|F~WA{SXkg1.,<e|Dn!$q0)y޻U$}:7iq,w,'9S$΋č`\>ٶ/XJ`2<DžwT_{P< e$p)۞z'F~.{mIO R+Ss|ǹe`V _MrU?;r=(c<~9pWDy[o:;w;w0A ~o-mE#,>ʵwXſ=}B=~נ7gzD8]C`9~2㾜 ^^E{*9,+; g>rFۿ<_|q9-SB|kw~V(pe_Iyx~t;9ժl+W@(US^"/ED˭|?@ 79rN$~,[fIX|aעxnBIy%̒#Kre9?>]pCu*TU՗z5CM`=GX|}؏r?bWJ=\/+]' \ X `^!ܢ/m-+r_bĕzKG(fCOͅ~w_Ν{wAy+b\[Y-rNVq |2؟> ]@?j|\C`k3R yRŸw}\:s޴8c~ø> k{8@G[zXo ?O/r9R΅8Z8AA//~jyD7\2Wa^ _0_w(ǰGfNl3yUWA=٢ X'X>/]<r2KF |W:)7bNG;SFX:Ӈs zK}`5# { ^X?bR.z ys}=y"+KA9/{3ώ+~|AY*U%@W`>%[8_3aM¶?bp+ },BYs"%\sCr}>uFץv?Ar_\&,K}0L82ry u(@=7x,⒒,y~徴#g幹%U򧃼 皻! qk~шo\7KA;lQyoo_Ïw7/8y]2Vl~ݤz\ÿ܇]'8gO\R#K`߂r?s~?6ހ|7h{w JY30GҞ`A7gc\Arϯw}ig2`']Le/?wk/:}F\;V/wyJX9迒7pN2?y|Wg=ۜ~fbb=f_uO: ek;H\;a]uGsuGNKSI/gO{zR'+%twZ_ߥd;_{Ǚ~''}u9)qj?]Cylu)K|;ў}, KObg]&ebUAJ9p}r;4H=3|og2^8w.D=L2iO~Y~YJ ~;Rů`Ў\G["v}߄CnCg~O1y'_G92~Y9=|/߂^q1ňӖT@el 9·Bu} ޱ4 p},@}[^ eaoŸ  ʶ2o]9?;7A{o{sҎ]R=C/!X/YXOtW/EOw eT2LU`yz$*zG{~Yӗ~3sO)@^Γ3:Sޖ|o^ N NT/xȮg~ t ػԓ8r䙼o|# q~\"ȻU/_$?:k9@NٶK;"p_.XDsO^E\by<#NY{Eb_ }'eO+Vz;,9N/e9ϟzYp=1ܟu)O $|.Z{G^YEyLWms7%a/ .DZE\:}b5ȵ z{wg>woB~1濇%A~H"4hWP/w.\._jk吴v#* O%8-8(H|v}{3?.` Lse?3[<9Uoo&<'{qR+?X [΁|G΃H΃8A>ipw=&神Ҟ(׎K?s~~\'Y_W1%zP/],\-γT]_®+./=_R#_\ ? ``;~ᰇafacW!m{yϔyOo: +T@IXUƍ`9G9'8+_5W(y/\}`K= 8W#i?=vvk=$N"eW6cڕL9r}>#X!88gOwF}KbN~˕}^*; E)/βZ!?B5qYkw;!]#{GAq@Nj z"g|,_ qγ7,>Se%;^wl)yX`|_h[^7;r-ZPc*/@m{u5~CjWcٔz ߯S[9~Ck2XX[ߍm#Ә3͡5ԿIݦܯNSx^}xk]˕>ոַChהm*dzX^,Gs5e gCƶ{ͥZ}5ƦosFs캐o}x1lci  E 鿮g|:ns))ꪓi\MP-W~cۨVv2ko]ijk_k,!%;YG{5>^Sllz]t![_Ceck lC^So1m4'M7NC\ZgNCemKCuo5e}jgꧾ ]LoگvGCױ!lH;i{uU[L}d곾< {k_c1U!tqfjg:ڮI}k|y1A# i7v]mU!Xj( G5ߦI]kS<# k.:L}֗^6m}ؘ» i'ӵPkXI7FF6f\ZlLZP:h:5L6dnA;J7O]kߺku齺l.9V߿gsSZPkޔȒLϬ14u~m(u.t=|O軩A][u););uW-7ͺ[J7GRW7?~;گ?_&ZsY|gИ_.[k]\[>LC|Yל>F}1m]\>7?_>Os9<޺[۸3W~Vw}im6&S=Xcck,=&S{Z/Vn4Cs[ ^߶[sWcx43#Ss>F]~Gci7q67BM纈4jscF% "?Zs"uϝ %GYYl=W@7/sd'ԈqB{S]ewj7oG֐Bā@ ˁ\ZZ9ցvttt] 0A q`;#[F;0&l ځ hZ` ```&``6`N-00߃Z P(ŀJer* KK8-`;v `wt`/ ? p;҃C=8 pG8ځc8ptc'O>|ҁoyG~ z X-$H<--jր6v&N.M=}`6 lr``[F`` $&800,l;:P(P (sJ@ KX6l =`;{ `W={`?8ЁV8܃#8ph1c8p'N3g9p6.AGP=OzlAg6=N?ן9I=cV雧`1A^7G?׃ޫCnv-.xs~;{K]0X-9POk n-'O;![UwTW9W/MY^w:?g_tA^VuOtSMG웳pIuV<޼#n7||ocGћ}9oɡm7qpǺooo^})J3^Gϩ+t =7={#8s뭯w}s=hAqwe;JzT;{'vyFzJ=?A3tUY$7ft|onvT6~WRݮM ]#>Gw6#coįK/缿v<~?mEjswؤ.K[ux]f_2w= OzE:)/y36"~Ct/hypf ŧO,_@=ٿp{9}D=uVV3zڶ?fj3pоAf7[zC}Xo^ٓVG~{~=jߪN}z̗4ӝ/oAǾuñЩtѭJi[CJ;POnkelQm/inӃ/lv8Gާ//H:/W?=|Ywo$bzDƟ='|xToYhǖ:l=yw_B=גw_nH=u'yh}]_Gn]w>==pj]BkfqSCxaTζ2jgڵz{t-Y ~zx~[=5;tGop'N>=ɳO8=˘t/ )уN?n_tnt{U9x>6y89Cw~ɴBՃ>lqau:v qgO?ڒgBZ\h&mmovzeWgm :q?zO ||#?:Q:}WzXiox-uWL2,"<9Gu$n'- *5lt3H}h#tiԝz)wcң?GXF|C{˦?x1=¨zǙM+0;"or{VGL%״Θa2pNmyA%;~{CtzgS8JVYVv>G|0LpZ}z:Mn"CW,N„t9/zD7dZ91ϱ'am7mwyfӯ=Y[_{(\n_NYKWڥ;!miY|<s]<|7}ב;I,VagGz|5'}.Yu +zz?aUDm$2R˷[M1|Zf{=+~zJK/]E{ W?z Q<;,6zfxȬz]Q[hKmbTEQt.i_;x:KmB {0ʡavsLwgɻuoӟ6?|g d},A?n5$֗s+e뾇Wn,"ݟxv6wxI/?=,^._213#wzHG {-L= \EDV?]`঳ԪG㧜gˆȅ41m~,ktN#/AO=˝vBϷП4[o ]˶?o{dׯv}m)qk]X;_70zॖ>kgk_|(v؃:'Xv}Q=s3a֣4?a~>c3C<ݞ<=t?XͯvX難w+BSA]0d[cokƑΆ<: uwk߈~:2޺Wl2Oֽj>/ڴ[>[ӟt?`V9||gmj ^f͖o /mR]|9gzK$3Oloۍ5.l)6)[m>r֞YF>֝wo"yXǦV^X.֟cX Wћdmݹb?9R Nʇj^_aeQ+݁f~^ۋ# ط?kko -ڸ&+mnO&Ց)fuߘ]YSw wrxg3N/zj럍]'|[dA~R'f=>ѽoIX!{Ȃ['5MHg1m~dǗΐ;![;Dݰ .}Ozl 651B!W?}`/-ѡ>? WY})k$).[N#jzO6mlHR,v'fh=hSKCYݺ&oߪ~-/3qW :"QOظI~{(k75Iɿ֓l#tVh1K'[bZ/q(m> ֟Oؠ?nJht(V~]{[ӟ#~i1sε[^nvx_ϸy.?3=뽹_kNz<{|q'Gﯺ[֮:h zdܭ4[[~5ڹ0FvYrßj O977H¸shm]y"e]2#Or>{=m:[} ڿs׳pOz=^#%Fl;3yW[#}!eC`-wѭz߹wޢ, uGz0vc=_6}No.0I滲áx\KA-7|>a76}#C_MiPJ΂*V(3r/0wCȌ=ctoHy;o23N֊rDg8vGX;^+&ޛ,RmY9;M[tȶ[}kOnK+#ڱ:cva$eI"顷|yqt/ğ|c=mPRW+,tߌ}WGe;;[ѱ|koG~DҘtZgq~E?go b8,T#/Gף^{~9SaM~,T=qcvOƗOmcskikwg}}Lkk1F?^mVE>d_82qm请[[_ִ~k[N׶V}צ;fj?eG&^חڣy]c2:GgM2[ֵ jAR]t6}PP]P6^ !~Km6A&]P[_6g+Sc}o۵ٛ4t [m4X]OhocۘƲ15zԗ'6ĺ:oc˦7w]i_2uCְ9e`sېcCtc\uA鿩<k^/zXsMW/Wsk[!sֱ eܟzb$k2*3YG յ@}PT3>)bvyb=\ Rmbmcg)|=_^ /~*umsm/R/0000755000176200001440000000000012774212430011251 5ustar liggesusersmsm/R/utils.R0000755000176200001440000004326512724253737012563 0ustar liggesusers### msm PACKAGE ### USEFUL FUNCTIONS NOT SPECIFIC TO MULTI-STATE MODELS ### Delta method for approximating the covariance matrix of f(X) given cov(X) deltamethod <- function(g, # a formula or list of formulae (functions) giving the transformation g(x) in terms of x1, x2, etc mean, # mean, or maximum likelihood estimate, of x cov, # covariance matrix of x ses=TRUE # return standard errors, else return covariance matrix ) { ## Var (G(x)) = G'(mu) Var(X) G'(mu)^T cov <- as.matrix(cov) n <- length(mean) if (!is.list(g)) g <- list(g) if ( (dim(cov)[1] != n) || (dim(cov)[2] != n) ) stop(paste("Covariances should be a ", n, " by ", n, " matrix")) syms <- paste("x",1:n,sep="") for (i in 1:n) assign(syms[i], mean[i]) gdashmu <- t(sapply(g, function( form ) { as.numeric(attr(eval( ## Differentiate each formula in the list deriv(form, syms) ## evaluate the results at the mean ), "gradient")) ## and build the results row by row into a Jacobian matrix })) new.covar <- gdashmu %*% cov %*% t(gdashmu) if (ses){ new.se <- sqrt(diag(new.covar)) new.se } else new.covar } ### Matrix exponential ### If a vector of multipliers t is supplied then a list of matrices is returned. MatrixExp <- function(mat, t = 1, method=NULL,...){ if (!is.matrix(mat) || (nrow(mat)!= ncol(mat))) stop("\"mat\" must be a square matrix") qmodel <- if (is.qmatrix(mat) && !is.null(method) && method=="analytic") msm.form.qmodel(mat) else list(iso=0, perm=0, qperm=0) if (!is.null(method) && method=="analytic") { if (!is.qmatrix(mat)) warning("Analytic method not available since matrix is not a Markov model intensity matrix. Using \"pade\".") else if (qmodel$iso==0) warning("Analytic method not available for this Markov model structure. Using \"pade\".") } if (length(t) > 1) res <- array(dim=c(dim(mat), length(t))) for (i in seq(along=t)) { if (is.null(method) || !(method %in% c("pade","series","analytic"))) { if (is.null(method)) method <- eval(formals(expm::expm)$method) resi <- expm::expm(t[i]*mat, method=method, ...) } else { ccall <- .C("MatrixExpR", as.double(mat), as.integer(nrow(mat)), res=double(length(mat)), as.double(t[i]), as.integer(match(method, c("pade","series"))), # must match macro constants in pijt.c as.integer(qmodel$iso), as.integer(qmodel$perm), as.integer(qmodel$qperm), as.integer(0), NAOK=TRUE) resi <- matrix(ccall$res, nrow=nrow(mat)) } if (length(t)==1) res <- resi else res[,,i] <- resi } res } ## Tests for a valid continuous-time Markov model transition intensity matrix is.qmatrix <- function(Q) { Q2 <- Q; diag(Q2) <- 0 isTRUE(all.equal(-diag(Q), rowSums(Q2))) && isTRUE(all(diag(Q)<=0)) && isTRUE(all(Q2>=0)) } ### Truncated normal distribution dtnorm <- function(x, mean=0, sd=1, lower=-Inf, upper=Inf, log=FALSE) { ret <- numeric(length(x)) ret[x < lower | x > upper] <- if (log) -Inf else 0 ret[upper < lower] <- NaN ind <- x >=lower & x <=upper if (any(ind)) { denom <- pnorm(upper, mean, sd) - pnorm(lower, mean, sd) xtmp <- dnorm(x, mean, sd, log) if (log) xtmp <- xtmp - log(denom) else xtmp <- xtmp/denom ret[x >=lower & x <=upper] <- xtmp[ind] } ret } ptnorm <- function(q, mean=0, sd=1, lower=-Inf, upper=Inf, lower.tail=TRUE, log.p=FALSE) { ret <- numeric(length(q)) if (lower.tail) { ret[q < lower] <- 0 ret[q > upper] <- 1 } else { ret[q < lower] <- 1 ret[q > upper] <- 0 } ret[upper < lower] <- NaN ind <- q >=lower & q <=upper if (any(ind)) { denom <- pnorm(upper, mean, sd) - pnorm(lower, mean, sd) if (lower.tail) qtmp <- pnorm(q, mean, sd) - pnorm(lower, mean, sd) else qtmp <- pnorm(upper, mean, sd) - pnorm(q, mean, sd) if (log.p) qtmp <- log(qtmp) - log(denom) else qtmp <- qtmp/denom ret[q >=lower & q <=upper] <- qtmp[ind] } ret } qtnorm <- function(p, mean=0, sd=1, lower=-Inf, upper=Inf, lower.tail=TRUE, log.p=FALSE) { qgeneric(ptnorm, p=p, mean=mean, sd=sd, lower=lower, upper=upper, lbound=lower, ubound=upper, lower.tail=lower.tail, log.p=log.p) } ## Rejection sampling algorithm by Robert (Stat. Comp (1995), 5, 121-5) ## for simulating from the truncated normal distribution. rtnorm <- function (n, mean = 0, sd = 1, lower = -Inf, upper = Inf) { if (length(n) > 1) n <- length(n) mean <- rep(mean, length=n) sd <- rep(sd, length=n) lower <- rep(lower, length=n) upper <- rep(upper, length=n) lower <- (lower - mean) / sd ## Algorithm works on mean 0, sd 1 scale upper <- (upper - mean) / sd ind <- seq(length=n) ret <- numeric(n) ## Different algorithms depending on where upper/lower limits lie. alg <- ifelse( lower > upper, -1,# return NaN if lower > upper ifelse( ((lower < 0 & upper == Inf) | (lower == -Inf & upper > 0) | (is.finite(lower) & is.finite(upper) & (lower < 0) & (upper > 0) & (upper-lower > sqrt(2*pi))) ), 0, # standard "simulate from normal and reject if outside limits" method. Use if bounds are wide. ifelse( (lower >= 0 & (upper > lower + 2*sqrt(exp(1)) / (lower + sqrt(lower^2 + 4)) * exp((lower*2 - lower*sqrt(lower^2 + 4)) / 4))), 1, # rejection sampling with exponential proposal. Use if lower >> mean ifelse(upper <= 0 & (-lower > -upper + 2*sqrt(exp(1)) / (-upper + sqrt(upper^2 + 4)) * exp((upper*2 - -upper*sqrt(upper^2 + 4)) / 4)), 2, # rejection sampling with exponential proposal. Use if upper << mean. 3)))) # rejection sampling with uniform proposal. Use if bounds are narrow and central. ind.nan <- ind[alg==-1]; ind.no <- ind[alg==0]; ind.expl <- ind[alg==1]; ind.expu <- ind[alg==2]; ind.u <- ind[alg==3] ret[ind.nan] <- NaN while (length(ind.no) > 0) { y <- rnorm(length(ind.no)) done <- which(y >= lower[ind.no] & y <= upper[ind.no]) ret[ind.no[done]] <- y[done] ind.no <- setdiff(ind.no, ind.no[done]) } stopifnot(length(ind.no) == 0) while (length(ind.expl) > 0) { a <- (lower[ind.expl] + sqrt(lower[ind.expl]^2 + 4)) / 2 z <- rexp(length(ind.expl), a) + lower[ind.expl] u <- runif(length(ind.expl)) done <- which((u <= exp(-(z - a)^2 / 2)) & (z <= upper[ind.expl])) ret[ind.expl[done]] <- z[done] ind.expl <- setdiff(ind.expl, ind.expl[done]) } stopifnot(length(ind.expl) == 0) while (length(ind.expu) > 0) { a <- (-upper[ind.expu] + sqrt(upper[ind.expu]^2 +4)) / 2 z <- rexp(length(ind.expu), a) - upper[ind.expu] u <- runif(length(ind.expu)) done <- which((u <= exp(-(z - a)^2 / 2)) & (z <= -lower[ind.expu])) ret[ind.expu[done]] <- -z[done] ind.expu <- setdiff(ind.expu, ind.expu[done]) } stopifnot(length(ind.expu) == 0) while (length(ind.u) > 0) { z <- runif(length(ind.u), lower[ind.u], upper[ind.u]) rho <- ifelse(lower[ind.u] > 0, exp((lower[ind.u]^2 - z^2) / 2), ifelse(upper[ind.u] < 0, exp((upper[ind.u]^2 - z^2) / 2), exp(-z^2/2))) u <- runif(length(ind.u)) done <- which(u <= rho) ret[ind.u[done]] <- z[done] ind.u <- setdiff(ind.u, ind.u[done]) } stopifnot(length(ind.u) == 0) ret*sd + mean } ### Normal distribution with measurement error and optional truncation dmenorm <- function(x, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0, log = FALSE) { sumsq <- sd*sd + sderr*sderr sigtmp <- sd*sderr / sqrt(sumsq) mutmp <- ((x - meanerr)*sd*sd + mean*sderr*sderr) / sumsq nc <- 1/(pnorm(upper, mean, sd) - pnorm(lower, mean, sd)) nctmp <- pnorm(upper, mutmp, sigtmp) - pnorm(lower, mutmp, sigtmp) if (log) log(nc) + log(nctmp) + log(dnorm(x, meanerr + mean, sqrt(sumsq), 0)) else nc * nctmp * dnorm(x, meanerr + mean, sqrt(sumsq), 0) } pmenorm <- function(q, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0, lower.tail = TRUE, log.p = FALSE) { ret <- numeric(length(q)) dmenorm2 <- function(x)dmenorm(x, mean=mean, sd=sd, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr) for (i in 1:length(q)) { ret[i] <- integrate(dmenorm2, -Inf, q[i])$value } if (!lower.tail) ret <- 1 - ret if (log.p) ret <- log(ret) ret[upper < lower] <- NaN ret } qmenorm <- function(p, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0, lower.tail=TRUE, log.p=FALSE) { qgeneric(pmenorm, p=p, mean=mean, sd=sd, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr, lbound=lower, ubound=upper, lower.tail=lower.tail, log.p=log.p) } rmenorm <- function(n, mean=0, sd=1, lower=-Inf, upper=Inf, sderr=0, meanerr=0) { rnorm(n, meanerr + rtnorm(n, mean, sd, lower, upper), sderr) } ### Uniform distribution with measurement error dmeunif <- function(x, lower=0, upper=1, sderr=0, meanerr=0, log = FALSE) { if (log) log( pnorm(x, meanerr + lower, sderr) - pnorm(x, meanerr + upper, sderr) ) - log(upper - lower) else ( pnorm(x, meanerr + lower, sderr) - pnorm(x, meanerr + upper, sderr) ) / (upper - lower) } pmeunif <- function(q, lower=0, upper=1, sderr=0, meanerr=0, lower.tail = TRUE, log.p = FALSE) { ret <- numeric(length(q)) dmeunif2 <- function(x)dmeunif(x, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr) for (i in 1:length(q)) { ret[i] <- integrate(dmeunif2, -Inf, q[i])$value } if (!lower.tail) ret <- 1 - ret if (log.p) ret <- log(ret) ret } qmeunif <- function(p, lower=0, upper=1, sderr=0, meanerr=0, lower.tail=TRUE, log.p=FALSE) { qgeneric(pmeunif, p=p, lower=lower, upper=upper, sderr=sderr, meanerr=meanerr, lbound=lower, ubound=upper, lower.tail=lower.tail, log.p=log.p) } rmeunif <- function(n, lower=0, upper=1, sderr=0, meanerr=0) { rnorm(n, meanerr + runif(n, lower, upper), sderr) } ## The exponential distribution with piecewise-constant rate. Vector ## of parameters given by rate, change times given by t (first should ## be 0) dpexp <- function (x, rate = 1, t = 0, log = FALSE) { if (length(t) != length(rate)) stop("length of t must be equal to length of rate") if (!isTRUE(all.equal(0, t[1]))) stop("first element of t should be 0") if (is.unsorted(t)) stop("t should be in increasing order") ind <- rowSums(outer(x, t, ">=")) ret <- dexp(x - t[ind], rate[ind], log) if (length(t) > 1) { dt <- t[-1] - t[-length(t)] if (log) { cs <- c(0, cumsum(pexp(dt, rate[-length(rate)], log.p=TRUE, lower.tail=FALSE))) ret <- cs[ind] + ret } else { cp <- c(1, cumprod(pexp(dt, rate[-length(rate)], lower.tail=FALSE))) ret <- cp[ind] * ret } } ret } ppexp <- function(q, rate = 1, t = 0, lower.tail = TRUE, log.p = FALSE) { if (length(t) != length(rate)) stop("length of t must be equal to length of rate") if (!isTRUE(all.equal(0, t[1]))) stop("first element of t should be 0") if (is.unsorted(t)) stop("t should be in increasing order") q[q<0] <- 0 ind <- rowSums(outer(q, t, ">=")) ret <- pexp(q - t[ind], rate[ind]) mi <- min(length(t), max(ind)) if (length(t) > 1) { dt <- t[-1] - t[-mi] pe <- pexp(dt, rate[-mi]) cp <- c(1, cumprod(1 - pe)) ret <- c(0, cumsum(cp[-length(cp)]*pe))[ind] + ret*cp[ind] } if (!lower.tail) ret <- 1 - ret if (log.p) ret <- log(ret) ret } qpexp <- function (p, rate = 1, t = 0, lower.tail = TRUE, log.p = FALSE) { qgeneric(ppexp, p=p, rate=rate, t=t, lower.tail=lower.tail, log.p=log.p) } ## Simulate n values from exponential distribution with parameters ## rate changing at t. Simulate from exponentials in turn, simulated ## value is retained if it is less than the next change time. rpexp <- function(n=1, rate=1, t=0) { if (length(t) != length(rate)) stop("length of t must be equal to length of rate") if (!isTRUE(all.equal(0, t[1]))) stop("first element of t should be 0") if (is.unsorted(t)) stop("t should be in increasing order") if (length(rate) == 1) return(rexp(n, rate)) if (n == 0) return(numeric(0)) if (length(n) > 1) n <- length(n) ret <- numeric(n) # outcome is a vector length n left <- 1:n for (i in seq(along=rate)){ re <- rexp(length(left), rate[i]) # simulate as many exponentials as there are values remaining r <- t[i] + re success <- if (i == length(rate)) seq(along=left) else which(r < t[i+1]) ret[left[success]] <- r[success] left <- setdiff(left, left[success]) # indices of values in outcome remaining to simulate. if (length(left)==0) break; } ret } qgeneric <- function(pdist, p, ...) { args <- list(...) if (is.null(args$log.p)) args$log.p <- FALSE if (is.null(args$lower.tail)) args$lower.tail <- TRUE if (is.null(args$lbound)) args$lbound <- -Inf if (is.null(args$ubound)) args$ubound <- Inf if (args$log.p) p <- exp(p) if (!args$lower.tail) p <- 1 - p ret <- numeric(length(p)) ret[p == 0] <- args$lbound ret[p == 1] <- args$ubound args[c("lower.tail","log.p","lbound","ubound")] <- NULL ## Other args assumed to contain params of the distribution. ## Replicate all to their maximum length, along with p maxlen <- max(sapply(c(args, p=list(p)), length)) for (i in seq(along=args)) args[[i]] <- rep(args[[i]], length.out=maxlen) p <- rep(p, length.out=maxlen) ret[p < 0 | p > 1] <- NaN ind <- (p > 0 & p < 1) if (any(ind)) { hind <- seq(along=p)[ind] h <- function(y) { args <- lapply(args, function(x)x[hind[i]]) p <- p[hind[i]] args$q <- y (do.call(pdist, args) - p) } ptmp <- numeric(length(p[ind])) for (i in 1:length(p[ind])) { interval <- c(-1, 1) while (h(interval[1])*h(interval[2]) >= 0) { interval <- interval + c(-1,1)*0.5*(interval[2]-interval[1]) } ptmp[i] <- uniroot(h, interval, tol=.Machine$double.eps)$root } ret[ind] <- ptmp } if (any(is.nan(ret))) warning("NaNs produced") ret } ## Transform vector of parameters constrained on [a, b] to real line. ## Vectorised. a=-Inf or b=Inf represent unbounded below or above. glogit <- function(x, a, b) { if (is.null(a)) a <- -Inf if (is.null(b)) b <- Inf ret <- numeric(length(x)) attributes(ret) <- attributes(x) nn <- is.infinite(a) & is.infinite(b) nb <- is.infinite(a) & is.finite(b) an <- is.finite(a) & is.infinite(b) ab <- is.finite(a) & is.finite(b) ret[nn] <- x[nn] ret[nb] <- log(b[nb] - x[nb]) ret[an] <- log(x[an] - a[an]) ret[ab] <- log((x[ab] - a[ab]) / (b[ab] - x[ab])) ret } dglogit <- function(x, a, b) { if (is.null(a)) a <- -Inf if (is.null(b)) b <- Inf ret <- numeric(length(x)) attributes(ret) <- attributes(x) nn <- is.infinite(a) & is.infinite(b) nb <- is.infinite(a) & is.finite(b) an <- is.finite(a) & is.infinite(b) ab <- is.finite(a) & is.finite(b) ret[nn] <- 1 ret[nb] <- -1 / (b[nb] - x[nb]) ret[an] <- 1 / (x[an] - a[an]) ret[ab] <- 1/(x[ab] - a[ab]) + 1/(b[ab] - x[ab]) ret } # d/dx log( (x-a)/(b-x) ) = (b-x)/(x-a) * (1/(b-x) + (x-a)/(b-x)^2) # = 1/(x-a) + 1/(b-x) # = d/dx log(x-a) - log(b-x) ## Inverse transform vector of parameters constrained on [a, b]: back ## from real line to constrained scale. Vectorised. a=-Inf or b=Inf ## represent unbounded below or above. gexpit <- function(x, a, b) { if (is.null(a)) a <- -Inf if (is.null(b)) b <- Inf ret <- numeric(length(x)) attributes(ret) <- attributes(x) nn <- is.infinite(a) & is.infinite(b) nb <- is.infinite(a) & is.finite(b) an <- is.finite(a) & is.infinite(b) ab <- is.finite(a) & is.finite(b) ret[nn] <- x[nn] ret[nb] <- b[nb] - exp(x[nb]) ret[an] <- exp(x[an]) + a[an] ret[ab] <- (b[ab]*exp(x[ab]) + a[ab]) / (1 + exp(x[ab])) ret } ## Derivative of gexpit w.r.t. x dgexpit <- function(x, a, b) { if (is.null(a)) a <- -Inf if (is.null(b)) b <- Inf ret <- numeric(length(x)) attributes(ret) <- attributes(x) nn <- is.infinite(a) & is.infinite(b) nb <- is.infinite(a) & is.finite(b) an <- is.finite(a) & is.infinite(b) ab <- is.finite(a) & is.finite(b) ret[nn] <- 1 ret[nb] <- - exp(x[nb]) ret[an] <- exp(x[an]) ret[ab] <- (b[ab] - a[ab])*exp(x[ab]) / (1 + exp(x[ab]))^2 ret } msm/R/hmm.R0000755000176200001440000004641612661576467012215 0ustar liggesusers### FUNCTIONS FOR HIDDEN MARKOV MODELS IN CONTINUOUS TIME ### WITH ARBITRARY RESPONSE DISTRIBUTION print.hmmMVdist <- function(x, ...) { cat(sprintf("Multivariate hidden Markov model with %d outcomes:\n", length(x))) for (i in x) print(i) } print.hmmdist <- function(x, ...) { cat("Hidden Markov model", x$label, "distribution\n\n") pnames <- if(x$label=="categorical") paste("P(",seq(x$pars[1]),")",sep="") else names(x$pars) pars <- if(x$label=="categorical") x$pars[3:(2+x$pars[1])] else x$pars cat("Parameters: ", paste(paste(pnames, pars, sep=" = "), collapse=", ")) cat("\n") } msm.check.hmodel <- function(hmodel, nstates) { if (is.null(hmodel)) stop("Hidden model not specified") if (!is.list(hmodel)) stop("Hidden model should be a list") if (length(hmodel) != nstates) stop("hmodel of length ", length(hmodel), ", expected ", nstates) for (i in hmodel) { if (!inherits(i, "hmmdist")) stop("hmodel should be a list of HMM distribution objects") } } msm.check.hcovariates <- function(hcovariates, qmodel) { if (!is.list(hcovariates)) stop("hcovariates should be a list") if (length(hcovariates) != qmodel$nstates) stop("hcovariates of length ", length(hcovariates), ", expected ", qmodel$nstates) for (i in hcovariates) { if (!is.null(i) ) if ( class(i) != "formula") stop("hcovariates should be a list of formulae or NULLs") } } msm.form.hmodel <- function(hmodel, hconstraint=NULL, initprobs=NULL, est.initprobs) { nst <- length(hmodel) if (is.null(initprobs)) initprobs <- if (est.initprobs) rep(1/nst, nst) else c(1, rep(0, nst-1)) else { if (!is.numeric(initprobs)) stop("initprobs should be numeric") if (is.matrix(initprobs)) { if (ncol(initprobs) != nst) stop("initprobs matrix has ", ncol(initprobs), " columns, should be number of states = ", nst) if (est.initprobs) { warning("Not estimating initial state occupancy probabilities since supplied as a matrix") } initprobs <- initprobs / rowSums(initprobs) est.initprobs <- FALSE } else { if (length(initprobs) != nst) stop("initprobs of length ", length(initprobs), ", should be ", nst) initprobs <- initprobs / sum(initprobs) if (est.initprobs && any(initprobs==1)) { est.initprobs <- FALSE warning("Not estimating initial state occupancy probabilities, since some are fixed to 1") } } } nipars <- if (est.initprobs) nst else 0 if (any(sapply(hmodel, inherits, "hmmMVdist"))){ hmod <- msm.form.mvhmodel(hmodel) } else hmod <- msm.form.univhmodel(hmodel) hmod <- c(list(hidden=TRUE, nstates=nst, fitted=FALSE, nipars=nipars, initprobs=initprobs, est.initprobs=est.initprobs, ematrix=FALSE), hmod) class(hmod) <- "hmodel" hmod } msm.form.univhmodel <- function(hmodel){ nst <- length(hmodel) labels <- sapply(hmodel, function(x) x$label) models <- match(labels, .msm.HMODELS) pars <- lapply(hmodel, function(x) x$pars) plabs <- lapply(hmodel, function(x) names(x$pars)) ## where non-misclassified outcome for hmmIdent distribution is not specified, this is ## just the state pars[labels=="identity"][sapply(pars[labels=="identity"], length) == 0] <- which(labels=="identity") plabs[labels=="identity"] <- "which" names(plabs) <- paste("state", 1:nst, sep=".") npars <- sapply(pars, length) parstate <- rep(1:nst, npars) firstpar <- c(0, cumsum(npars)[-nst]) pars <- as.numeric(unlist(pars)) plabs <- unlist(plabs) locpars <- which(plabs == rep(.msm.LOCPARS[labels], npars)) names(pars) <- plabs list(models=models, labels=labels, npars=npars, nout=rep(1, nst), mv=FALSE, totpars=sum(npars), pars=pars, plabs=plabs, parstate=parstate, firstpar=firstpar, locpars=locpars) } ### CHANGES FROM UNIVARIATE TO MULTIVARIATE OUTCOME HMMS ### models should be matrix instead of vector, new dim given by nout (same for labels) ### npars was vector with one for each state. now matrix ### pars was ragged array, mapped to states with parstate. should still be. (same for plabs) ### need new vector parout to map pars to outcomes. ### firstpar, used in C to point to first parameters for a univariate model. was one for each state. now needs to be a matrix msm.form.mvhmodel <- function(hmodel){ nst <- length(hmodel) for (i in seq_along(hmodel)) if (!inherits(hmodel[[i]], "hmmMVdist")) hmodel[[i]] <- list(hmodel[[i]]) nout <- sapply(hmodel, length) models <- labels <- firstpar <- matrix(nrow=max(nout), ncol=nst) npars <- matrix(0, nrow=max(nout), ncol=nst) pars <- plabs <- parstate <- parout <- vector(nst, mode="list") for (i in 1:nst){ labels[1:nout[i],i] <- sapply(hmodel[[i]], function(x) x$label) models[1:nout[i],i] <- match(labels[1:nout[i],i], .msm.HMODELS) pars[[i]] <- lapply(hmodel[[i]], function(x)x$pars) npars[1:nout[i],i] <- sapply(pars[[i]], length) pars[[i]][labels[,i]=="identity" & npars[,i]==0] <- i # TESTME - hmmIdent with no arg: par is the state plabs[[i]][labels[,i]=="identity" & npars[,i]==0] <- "which" plabs[[i]] <- lapply(hmodel[[i]], function(x)names(x$pars)) parstate[[i]] <- rep(i, sum(npars[,i])) parout[[i]] <- rep(1:nout[i], npars[1:nout[i],i]) } firstpar <- matrix(c(0, cumsum(npars)[-length(npars)]), nrow=max(nout), ncol=nst) firstpar[npars==0] <- NA pars <- unlist(pars); plabs <- unlist(plabs); parout <- unlist(parout); parstate <- unlist(parstate) locpars <- which(plabs == rep(.msm.LOCPARS[labels], npars)) names(pars) <- plabs list(models=models, labels=labels, npars=npars, nout=nout, mv=TRUE, totpars=sum(npars), pars=pars, plabs=plabs, parstate=parstate, parout=parout, firstpar=firstpar, locpars=locpars) } ## NOTE removed whichcovh, whichcovh.orig msm.form.hcmodel <- function(hmodel, mm, hcovinits, hconstraint) { nst <- hmodel$nstates ncovs <- if (is.null(mm)) rep(0, nst) else sapply(mm, function(x) {ncol(x)-1}) ncovs2 <- rep(rep(0, nst), hmodel$npars) ncovs2[hmodel$locpars] <- ncovs[hmodel$parstate[hmodel$locpars]] coveffstate <- rep(1:nst, tapply(ncovs2, hmodel$parstate, sum)) if (is.null(hcovinits)){ coveffect <- rep(0, sum(ncovs2)) } else { if (!(sum(ncovs2) == length(unlist(hcovinits)))) { warning("Initial values for hidden covariate effects do not match numbers of covariates, ignoring") coveffect <- rep(0, sum(ncovs2)) } else coveffect <- unlist(hcovinits) if (!is.numeric(coveffect)) { warning("hcovinits should be numeric") coveffect <- rep(0, sum(ncovs2)) } } covlabels <- lapply(mm, function(x) colnames(x)[-1]) covlabels <- unlist(covlabels[hmodel$parstate[hmodel$locpars]]) names(coveffect) <- covlabels hcmod <- list(ncovs=ncovs2, coveffect=coveffect, covlabels=covlabels, coveffstate=coveffstate, ncoveffs=length(coveffect)) hmodel <- c(hmodel, hcmod) hmodel$plabs[hmodel$plabs=="hcov"] <- paste("hcov.",covlabels,sep="") class(hmodel) <- "hmodel" hmodel } ### NOTE whichcovi removed msm.form.icmodel <- function(hmodel, mm, icovinits) { nst <- hmodel$nstates nicovs <- ncol(mm) - 1 nicovs <- rep(nicovs, nst-1) if (!is.matrix(hmodel$initprobs)) nicovs[hmodel$initprobs[-1] == 0] <- 0 # don't estimate cov effects on probs which are fixed to zero if (is.null(icovinits)) icoveffect <- rep(0, sum(nicovs)) else { icoveffect <- unlist(icovinits) if (!(length(icoveffect) == sum(nicovs))) { warning("Initial values for initial state covariate effects do not match numbers of covariates, ignoring") icoveffect <- rep(0, sum(nicovs)) } else if (!is.numeric(icoveffect)) { warning("icovinits should be numeric") icoveffect <- rep(0, sum(nicovs)) } } names(icoveffect) <- rep(colnames(mm)[-1], each=sum(nicovs>0)) icmod <- list(nicovs=nicovs, icoveffect=icoveffect, nicoveffs=length(icoveffect)) hmodel <- c(hmodel, icmod) class(hmodel) <- "hmodel" hmodel } ## Convert old-style misclassification model specification to a new-style HMM with categorical response msm.emodel2hmodel <- function(emodel, qmodel) { nst <- qmodel$nstates if (emodel$misc) { hidden <- TRUE nepars <- rowSums(emodel$imatrix) models <- ifelse(apply(emodel$ematrix,1,function(x)any(x==1)), 2, 1) npars <- ifelse(models==1, 2 + nst, 1) pars <- plabs <- vector(nst, mode="list") parstate <- rep(1:nst, npars) names(pars) <- names(plabs) <- paste("state", 1:nst, sep=".") for (i in seq(nst)) { if (models[i]==1) { ppars <- emodel$ematrix[i,] plab <- rep("p", nst) plab[ppars==0] <- "p0" plab[i] <- "pbase" plabs[[i]] <- c("ncats", "basecat", plab) ## Baseline category is the probability of no misclassification (diagonal of ematrix) pars[[i]] <- c(nst, i, ppars) } else { plabs[[i]] <- "which" pars[[i]] <- which(emodel$ematrix[i,]==1) } } firstpar <- c(0, cumsum(npars)[-qmodel$nstates]) pars <- unlist(pars) plabs <- unlist(plabs) names(pars) <- plabs labels <- .msm.HMODELS[models] locpars <- which(plabs == rep(.msm.LOCPARS[labels], npars)) hmod <- list(hidden=TRUE, fitted=FALSE, nstates=nst, models=models, labels=labels, ematrix=TRUE, ## remember if obtained from ematrix, since could change meaning of obstrue nout=rep(1, nst), mv=FALSE, npars=npars, totpars=sum(npars), locpars=locpars, pars=pars, plabs=plabs, parstate=parstate, firstpar=firstpar, nipars=emodel$nipars, initprobs=emodel$initprobs, est.initprobs=emodel$est.initprobs) hmod$constr <- msm.econstr2hconstr(emodel$constr, hmod) } else { hmod <- list(hidden=FALSE, fitted=FALSE, ematrix=FALSE, models=rep(0, qmodel$nstates), npars=0, ndpars=0) } class(hmod) <- "hmodel" hmod } msm.misccov2hcov <- function(misccovariates, emodel) { nst <- nrow(emodel$imatrix) whichst <- rep(1:nst, rowSums(emodel$imatrix)) hcov <- vector(nst, mode="list") for (i in 1:nst) { if (!any(whichst==i)) hcov[[i]] <- ~ 1 else hcov[[i]] <- misccovariates } hcov } msm.misccovinits2hcovinits <- function(misccovinits, hcovariates, emodel, ecmodel) { nst <- nrow(emodel$imatrix) whichst <- rep(1:nst, rowSums(emodel$imatrix)) hcovinits <- vector(nst, mode="list") for (i in 1:nst) { if (is.null(misccovinits)) hcovinits[[i]] <- rep(0, ecmodel$ncovs * rowSums(emodel$imatrix)[i]) else if (!any(whichst==i)) hcovinits[[i]] <- numeric(0) else hcovinits[[i]] <- as.vector(t(sapply(misccovinits, function(x)x[whichst==i]))) } hcovinits } msm.econstr2hconstr <- function(econstr, hmodel) { constr <- seq(length=hmodel$totpars) for (i in unique(econstr)) { constr[hmodel$plabs == "p"][econstr == i] <- min(constr[hmodel$plabs == "p"][econstr == i]) } match(constr, unique(constr)) } print.hmodel <- function(x, ...) { ci <- (x$fitted && x$foundse) cols <- if (ci) c("Estimate","LCL","UCL") else ("") if (!x$hidden) cat("Non-hidden Markov model\n") else { cat("Hidden Markov model, ") nst <- x$nstates cat(nst, "states\n") if (x$est.initprobs){ cat("Initial state occupancy probabilities: ") if (x$nipars > 0) { cat("\n") print(x$initprobs) cat("\n") if (any(x$nicovs > 0)) { cat("Covariates on log odds of initial states relative to state 1\n") print(x$icoveffect) } cat("\n") } else cat(paste(x$initprobs, collapse=","), "\n\n") } for (i in 1:nst) { if (x$mv){ cat("State", i, "\n") for (j in 1:x$nout[i]){ cat("Outcome", j, "-", x$labels[j,i], "distribution\n") if (x$labels[j,i]=="categorical") pars <- print.hmmcat(x, i, j, mv=TRUE) ## TESTME else { inds <- x$parstate==i & x$parout==j pars <- as.matrix(x$pars[inds]) if (ci) pars <- cbind(pars, matrix(x$ci[inds,], ncol=2)) dimnames(pars) <- list(x$plabs[inds], cols) } ## covs not supported for the moment print(pars) cat("\n") } } else { cat("State", i, "-", x$labels[i], "distribution\n") cat("Parameters: \n") if (x$label[i]=="categorical") pars <- print.hmmcat(x, i) else { pars <- as.matrix(x$pars[x$parstate==i]) if (ci) pars <- cbind(pars, matrix(x$ci[x$parstate==i ,], ncol=2)) dimnames(pars) <- list(x$plabs[x$parstate==i], cols) } if (any(x$ncovs[x$parstate==i] > 0)){ coveffs <- as.matrix(x$coveffect[x$coveffstate==i]) if (ci) coveffs <- cbind(coveffs, matrix(x$covci[x$coveffstate==i,], ncol=2)) rownames(coveffs) <- x$covlabels[x$coveffstate==i] pars <- rbind(pars, coveffs) } print(pars) cat("\n") } } } } print.hmmcat <- function(x, i, j=NULL, mv=FALSE) { inds <- if (mv) x$parstate==i & x$parout==j else x$parstate==i pars <- x$pars[inds] res <- matrix(pars[3:(2+pars[1])], ncol=1) rownames(res) <- paste("P(",seq(length=pars[1]),")",sep="") if (x$fitted && x$foundse) { ci <- matrix(x$ci[inds,], ncol=2) res <- cbind(res, ci[3:(2+pars[1]),]) colnames(res) <- c("Estimate","LCL","UCL") } else colnames(res) <- "prob" res } msm.form.hconstraint <- function(constraint, hmodel) { constr <- seq(length=hmodel$totpars) for (con in names(constraint)) { if ( ! (con %in% c(hmodel$plabs, hmodel$covlabels))) stop("parameter \"", con, "\" in hconstraint unknown") if (con %in% hmodel$plabs) { tc <- constraint[[con]] np <- length(tc) if (np != sum(hmodel$plabs==con)) stop("constraint for \"", con, "\" of length ", np, ", should be ", sum(hmodel$plabs==con)) for (i in unique(tc)) constr[hmodel$plabs == con][tc == i] <- min(constr[hmodel$plabs == con][tc == i]) } } match(constr, unique(constr)) } msm.form.hcovconstraint <- function(constraint, hmodel) { constr <- seq(length=hmodel$ncoveffs) for (con in names(constraint)) { if ( ! (con %in% c(hmodel$plabs, hmodel$covlabels))) stop("parameter \"", con, "\" in hconstraint unknown") if (con %in% hmodel$covlabels) { tc <- constraint[[con]] np <- length(tc) if (np != sum(hmodel$covlabels==con)) stop("constraint for \"", con, "\" of length ", np, ", should be ", sum(hmodel$covlabels==con)) for (i in unique(tc)) constr[hmodel$covlabels == con][tc == i] <- min(constr[hmodel$covlabels == con][tc == i]) } } match(constr, unique(constr)) } ## User-supplied range constraints on HMM parameters. msm.form.hranges <- function(ranges, hmodel) { hranges <- .msm.PARRANGES[hmodel$plabs,] if (hmodel$ncoveffs>0) { hcovranges <- matrix(rep(c(-Inf, Inf), hmodel$ncoveffs), nrow=hmodel$ncoveffs, byrow=TRUE) rownames(hcovranges) <- hmodel$covlabels hranges <- rbind(hranges, hcovranges) } if (!is.null(ranges)) { if (!is.list(ranges)) stop("expected \"hranges\" to be a list") for (i in names(ranges)) { if ( ! (i %in% c(hmodel$plabs, hmodel$covlabels))) stop("parameter \"", i, "\" in \"hranges\" unknown") ran.default <- hranges[rownames(hranges)==i,,drop=FALSE] ran.user <- do.call("cbind", ranges[[i]]) for (j in seq_len(nrow(ran.user))) { if (ran.user[j,1] < ran.default[j,1]) { warning("User-supplied lower bound of ",ran.user[j,1]," for ", i, " less than theoretical minimum of ", ran.default[j,1], ", ignoring") ran.user[j,1] <- ran.default[j,1] } if (ran.user[j,2] > ran.default[j,2]) { warning("User-supplied upper bound of ",ran.user[j,2]," for ", i, " less than theoretical maximum of ", ran.default[j,2], ", ignoring") ran.user[j,2] <- ran.default[j,2] } hranges[rownames(hranges)==i,][j,] <- ran.user[j,] } } } ## ideally should be strict here if estimated, but allow inits on Inf boundary if not estimated. for (i in seq(along=hmodel$pars)){ if (!in.range(hmodel$pars[i], hranges[i,], strict=FALSE)) stop("Initial value ", hmodel$pars[i], " of parameter \"", hmodel$plabs[i], "\" outside allowed range ", "[", paste(hranges[i,], collapse=","), "]") } hranges } in.range <- function(x, interval, strict=FALSE) { if (!is.numeric(interval) || length(interval)!=2) stop("interval should be a numeric vector of length 2") if (!is.numeric(x)) stop("x should be numeric") if (strict) ( (x > interval[1]) & (x < interval[2]) ) else ( (x >= interval[1]) & (x <= interval[2]) ) } msm.form.initprobs <- function(hmodel, initprobs, mf){ npts <- attr(mf,"npts") if (!is.null(hmodel$phase.states) && is.null(initprobs)) { hmodel$initprobs <- matrix(0, nrow=npts, ncol=hmodel$nstates) initstate <- mf$"(state)"[!duplicated(mf$"(subject)")] hmodel$initprobs[cbind(1:npts, match(initstate, hmodel$pars))] <- 1 if (hmodel$est.initprobs) warning("Not estimating initial state occupancy probabilities: assuming everyone starts at first phase") hmodel$est.initprobs <- FALSE } if (!hmodel$est.initprobs) { if (is.matrix(hmodel$initprobs)) { if (nrow(hmodel$initprobs) != npts) stop("initial state occupancy probability should have ", npts, " (number of subjects) rows if supplied as a matrix, found ",nrow(hmodel$initprobs)) } } hmodel } msm/R/mstate.R0000755000176200001440000000541112322717240012673 0ustar liggesusers## Function to convert data for a msm model fit to data for a coxph model fit msm2Surv <- function(data, # data frame subject, time, state, # names of subject, time and state variables (character) covs=NULL, # names of covariates (character vector) Q # transition intensity matrix. should be zero where transitions are disallowed. ) { if (missing(subject)) stop("subject variable not given") if (missing(time)) stop("time variable not given") if (missing(state)) stop("state variable not given") fpt <- !duplicated(data[,subject]) # indicator for patient's first observation lpt <- !duplicated(data[,subject], fromLast=TRUE) # ... last observation ... nev <- nrow(data[!lpt,]) ## Data frame of observed events ev <- data.frame(id=data[!lpt,subject], from=data[!lpt,state],to=data[!fpt,state], Tstart=data[!lpt,time], Tstop=data[!fpt,time], time=data[!fpt,time]-data[!lpt,time], status=rep(1,nev)) if (is.null(covs)) covs <- setdiff(colnames(data), c(subject, time, state)) ## rename any covariates which clash with standard names in the returned data for (i in c("id", "from", "to","Tstart","Tstop","time","status","trans")) covs[covs==i] <- colnames(data)[colnames(data)==i] <- paste(i, ".2", sep="") for (i in covs) ev[,i] <- data[!lpt, i] neq <- sum(ev$Tstart == ev$Tstop) if (neq > 0) { warning("Omitting ",neq, " rows with two observations at the same time") ev <- ev[ev$Tstart < ev$Tstop,] } diag(Q) <- 0; Q[Q>0] <- 1 if (is.null(rownames(Q))) rownames(Q) <- 1:nrow(Q) if (is.null(colnames(Q))) colnames(Q) <- 1:ncol(Q) Qf <- Q[ev$from,] Qf[cbind(1:nrow(Qf), ev$to)] <- 0 nto <- rowSums(Qf) ncens <- sum(nto) cto <- which(t(Qf)==1,arr.ind=TRUE)[,1] ## Data frame of censored events cens <- data.frame(id=rep(ev$id, nto), from=rep(ev$from, nto), to=cto, Tstart=rep(ev$Tstart, nto), Tstop=rep(ev$Tstop, nto), time=rep(ev$Tstop, nto) - rep(ev$Tstart, nto), status=rep(0, ncens)) for (i in covs) cens[,i] <- rep(ev[,i], nto) surv <- rbind(ev, cens) surv <- surv[order(surv$id, surv$Tstart, surv$to),] surv <- surv[!(surv$from==surv$to),] Qi <- t(Q); Qi[Qi==1] <- seq_along(which(t(Q)==1)); Qi <- t(Qi) surv$trans <- Qi[cbind(surv$from,surv$to)] rownames(surv) <- NULL tmat <- t(Q) tmat[t(Q)==1] <- seq(along=tmat[t(Q)==1]) tmat <- t(tmat); tmat[Q==0] <- NA names(dimnames(tmat)) <- c("from","to") attr(surv, "trans") <- tmat class(surv) <- c("msdata","data.frame") surv } msm/R/boot.R0000755000176200001440000004544612452524041012354 0ustar liggesusers### Reconstruct data for original msm model fit. Replace ### generically-named variables in model data frame ("(subject)", ### "(time)", "(state)" etc.) with the names specified by the user for ### the original model call, to allow model refits for ### cross-validation or bootstrapping using the original call. If not ### found in the usernames attribute, these columns are dropped, ### assuming they're not needed for the refit. Drop imputed ### observations at piecewise constant intensity change points. ### NOTE assuming timeperiod covariate OK to leave as is ### Factor handling: strips factor() from variable names, ## if original data was factor, will be factor in mf as well, so refit will work ## if not factor in df but factor() in formula, stripping factor() allows refit to work ## TODO can test this with simple refits ## test whether labels are OK, check changelog reconstruct.data <- function(mf){ un <- attr(mf, "usernames") par.name <- paste0("(",names(un),")") ids <- match(par.name, names(mf)) names(mf) <- replace(names(mf), ids, un) if (!is.null(mf$"(pci.imp)")) mf <- mf[!mf$"(pci.imp)",] if(is.na(un["subject"])) { un["subject"] <- "subject" mf$subject <- mf$"(subject)" attr(mf, "usernames") <- un } for (i in grep("^\\(.+\\)$", names(mf), value=TRUE)) mf[,i] <- NULL colnames(mf) <- gsub("factor\\((.+)\\)", "\\1", colnames(mf)) mf } ### Take a bootstrap sample from the data contained in a fitted msm ### model. Sample pairs of consecutive observations, i.e. independent ### transitions. Not applicable if model is hidden or some states are ### censored. bootdata.trans.msm <- function(x) { dat <- reconstruct.data(model.frame(x)) un <- attr(dat, "usernames") ## sample random rows of original data, excluding last observation inds <- sample(which(duplicated(dat[,un["subject"]], fromLast=TRUE)), replace=TRUE) ## make new data by interleaving corresponding "from-state" and "to-state" rows ntrans <- length(inds) z <- array(c(unlist(dat[inds,]), # "from-state" data unlist(dat[inds+1,])), # "to-state" data dim=c(ntrans, ncol(dat), 2)) data.boot <- matrix(aperm(z, c(3,1,2)), nrow=2*ntrans, ncol=ncol(dat), dimnames=list(NULL,names(dat))) data.boot <- as.data.frame(data.boot) ## label every transition in new data as from a different subject data.boot[,un["subject"]] <- rep(1:ntrans, each=2) for (i in which(sapply(dat, is.factor))) data.boot[,i] <- factor(data.boot[,i], labels=sort(unique(dat[,i]))) data.boot } ### Take a bootstrap sample from the data contained in a fitted msm ### model. Sample subjects. Used for hidden models or models with ### censoring, in which the transitions within a subject are not ### independent. bootdata.subject.msm <- function(x) { dat <- model.frame(x) subj.num <- match(dat$"(subject)", unique(dat$"(subject)")) subjs <- sample(unique(subj.num), replace=TRUE) inds <- new.subj <- NULL for (i in seq(along=subjs)) { subj.inds <- which(subj.num == subjs[i]) inds <- c(inds, subj.inds) new.subj <- c(new.subj, rep(i, length(subj.inds))) } data.boot <- dat[inds,] data.boot[,"(subject)"] <- new.subj data.boot <- reconstruct.data(data.boot) data.boot } ### Given a fitted msm model, draw a bootstrap dataset, refit the ### model, and optionally compute a statistic on the refitted model. ### Repeat B times, store the results in a list. ### msm objects tend to be large, so it is advised to compute a statistic on them by specifying "stat", instead ### of using this function to return a list of refitted msm objects. ### To compute more than one statistic, specify, e.g. stat=function(x)list(stat1(x),stat2(x)) ### Some of the arguments to the msm call might be user-defined objects. ### e.g. qmatrix, ematrix, hmodel, ... ### Put in help file that these must be in the working environment. boot.msm <- function(x, stat=pmatrix.msm, B=1000, file=NULL, cores=NULL){ boot.fn <- function(dummy){ boot.data <- if (x$hmodel$hidden || x$cmodel$ncens) bootdata.subject.msm(x) else bootdata.trans.msm(x) x$call$data <- substitute(boot.data) res <- try(eval(x$call)) if (!inherits(res, "try-error") && !is.null(stat)) res <- try(stat(res)) res } if (is.null(cores) || cores==1) parallel <- FALSE else parallel <- TRUE; if (parallel) { if (!is.null(cores) && cores=="default") cores <- NULL if (requireNamespace("doParallel", quietly = TRUE)){ ### can't get this working separated out into a function like portable.parallel(). Variable exporting / scoping doesnt' work. if (.Platform$OS.type == "windows") { cl <- parallel::makeCluster(cores) doParallel::registerDoParallel(cl) } else doParallel::registerDoParallel(cores=cores) boot.list <- foreach::"%dopar%"(foreach::foreach(i=1:B, .packages="msm", .export=c("x",ls(.GlobalEnv))), { boot.fn(i) }) if (.Platform$OS.type == "windows") parallel::stopCluster(cl) } else stop("\"parallel\" package not available") } else { boot.list <- vector(B, mode="list") for (i in 1:B) { boot.list[[i]] <- boot.fn() if (!is.null(file)) save(boot.list, file=file) } } boot.list } ### Utilities for calculating bootstrap CIs for particular statistics qmatrix.ci.msm <- function(x, covariates="mean", sojourn=FALSE, cl=0.95, B=1000, cores=NULL) { q.list <- boot.msm(x, function(x)qmatrix.msm(x=x, covariates=covariates)$estimates, B=B, cores=cores) q.array <- array(unlist(q.list), dim=c(dim(q.list[[1]]), length(q.list))) q.ci <- apply(q.array, c(1,2), function(x)(c(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)), sd(x)))) q.ci <- aperm(q.ci, c(2,3,1)) if (sojourn) { soj.array <- apply(q.array, 3, function(x) -1/diag(x)) soj.ci <- apply(soj.array, 1, function(x)(c(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)), sd(x)))) list(q=q.ci, soj=soj.ci) } else q.ci } ematrix.ci.msm <- function(x, covariates="mean", cl=0.95, B=1000, cores=NULL) { e.list <- boot.msm(x, function(x)ematrix.msm(x=x, covariates=covariates)$estimates, B=B, cores=cores) e.array <- array(unlist(e.list), dim=c(dim(e.list[[1]]), length(e.list))) e.ci <- apply(e.array, c(1,2), function(x)(c(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)), sd(x)))) aperm(e.ci, c(2,3,1)) } qratio.ci.msm <- function(x, ind1, ind2, covariates="mean", cl=0.95, B=1000, cores=NULL) { q.list <- boot.msm(x, function(x)qratio.msm(x=x, ind1=ind1, ind2=ind2, covariates=covariates)["estimate"], B=B, cores=cores) q.vec <- unlist(q.list) c(quantile(q.vec, c(0.5 - cl/2, 0.5 + cl/2)), sd(q.vec)) } pnext.ci.msm <- function(x, covariates="mean", cl=0.95, B=1000, cores=NULL) { p.list <- boot.msm(x, function(x)pnext.msm(x=x, covariates=covariates, ci="none")$estimates, B=B, cores=cores) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } pmatrix.ci.msm <- function(x, t, t1, covariates="mean", cl=0.95, B=1000, cores=NULL) { p.list <- boot.msm(x, function(x)pmatrix.msm(x=x, t=t, t1=t1, covariates=covariates,ci="none"), B=B, cores=cores) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } pmatrix.piecewise.ci.msm <- function(x, t1, t2, times, covariates="mean", cl=0.95, B=1000, cores=NULL) { p.list <- boot.msm(x, function(x)pmatrix.piecewise.msm(x=x, t1=t1, t2=t2, times=times, covariates=covariates,ci="none"), B=B, cores=cores) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } totlos.ci.msm <- function(x, start=1, end=NULL, fromt=0, tot=Inf, covariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, discount=0, env=FALSE, cl=0.95, B=1000, cores=NULL,...) { t.list <- boot.msm(x, function(x)totlos.msm(x=x, start=start, end=end, fromt=fromt, tot=tot, covariates=covariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, discount=discount, env=env, ci="none",...), B=B, cores=cores) t.array <- do.call("rbind", t.list) apply(t.array, 2, function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) } efpt.ci.msm <- function(x, qmatrix=NULL, tostate, start, covariates="mean", cl=0.95, B=1000, cores=NULL) { t.list <- boot.msm(x, function(x)efpt.msm(x=x, qmatrix=qmatrix, start=start, tostate=tostate, covariates=covariates, ci="none"), B=B, cores=cores) t.array <- do.call("rbind", t.list) apply(t.array, 2, function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) } ppass.ci.msm <- function(x, qmatrix, tot, start, covariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, cl=0.95, B=1000, cores=NULL,...) { t.list <- boot.msm(x, function(x)ppass.msm(x=x, qmatrix=qmatrix, tot=tot, start=start, covariates=covariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, ci="none",...), B=B, cores=cores) nst <- ncol(t.list[[1]]) t.array <- do.call("rbind", lapply(t.list, as.vector)) ci <- apply(t.array, 2, function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) di <- dimnames(t.list[[1]]) list(L=matrix(ci[1,],ncol=nst,dimnames=di), U=matrix(ci[2,],ncol=nst, dimnames=di)) } phasemeans.ci.msm <- function(x, covariates="mean", cl=0.95, B=1000, cores=NULL, ...) { p.list <- boot.msm(x, function(x)phasemeans.msm(x=x, covariates=covariates, ci="none", ...), B=B, cores=cores) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } expected.ci.msm <- function(x, times=NULL, timezero=NULL, initstates=NULL, covariates="mean", misccovariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, risk=NULL, cl=0.95, B=1000, cores=NULL) { if(is.null(risk)) risk <- observed.msm(x)$risk e.list <- boot.msm(x, function(x){ expected.msm(x, times, timezero, initstates, covariates, misccovariates, piecewise.times, piecewise.covariates, risk) }, B=B, cores=cores) e.tab.array <- array(unlist(lapply(e.list, function(x)x[[1]])), dim=c(dim(e.list[[1]][[1]]), length(e.list))) e.perc.array <- array(unlist(lapply(e.list, function(x)x[[2]])), dim=c(dim(e.list[[1]][[2]]), length(e.list))) e.tab.ci <- apply(e.tab.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) e.perc.ci <- apply(e.perc.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) res <- list(aperm(e.tab.ci, c(2,3,1)), aperm(e.perc.ci, c(2,3,1))) names(res) <- c("Expected", "Expected percentages") res } ### Compute a CI for a statistic using a sample from the assumed MVN ### distribution of MLEs of log Q, logit E and covariate effects on these ### Not user visible: only support statistics based on Q matrix and E matrix ### i.e. statistics computed as functions of x$Qmatrices, x$Ematrices and x$paramdata$params normboot.msm <- function(x, stat, B=1000) { ## simulate from vector of unreplicated parameters, to avoid numerical problems with rmvnorm when lots of correlations are 1 if (!x$foundse) stop("Asymptotic standard errors not available in fitted model") sim <- rmvnorm(B, x$opt$par, x$covmat[x$paramdata$optpars,x$paramdata$optpars]) params <- matrix(nrow=B, ncol=x$paramdata$npars) # replicate constrained parameters. params[,x$paramdata$optpars] <- sim params[,x$paramdata$fixedpars] <- rep(x$paramdata$params[x$paramdata$fixedpars], each=B) params[,x$paramdata$hmmpars] <- rep(msm.mninvlogit.transform(x$paramdata$params[x$paramdata$hmmpars], x$hmodel$plabs, x$hmodel$parstate), each=B) params <- params[, !duplicated(abs(x$paramdata$constr)), drop=FALSE][, abs(x$paramdata$constr), drop=FALSE] * rep(sign(x$paramdata$constr), each=B) sim.stat <- vector(B, mode="list") for (i in 1:B) { x.rep <- x x.rep$paramdata$params <- params[i,] output <- msm.form.output(x.rep, "intens") x.rep$Qmatrices <- output$Qmatrices if (x$emodel$misc) { output <- msm.form.output(x.rep, "misc") x.rep$Ematrices <- output$Ematrices names(x.rep$Ematrices)[1] <- "logitbaseline" } sim.stat[[i]] <- stat(x.rep) } sim.stat } qmatrix.normci.msm <- function(x, covariates="mean", sojourn=FALSE, cl=0.95, B=1000) { q.list <- normboot.msm(x, function(x)qmatrix.msm(x=x, covariates=covariates, ci="none"), B) q.array <- array(unlist(q.list), dim=c(dim(q.list[[1]]), length(q.list))) q.ci <- apply(q.array, c(1,2), function(x)(c(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)), sd(x)))) q.ci <- aperm(q.ci, c(2,3,1)) if (sojourn) { soj.array <- apply(q.array, 3, function(x) -1/diag(x)) soj.ci <- apply(soj.array, 1, function(x)(c(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)), sd(x)))) list(q=q.ci, soj=soj.ci) } else q.ci } ematrix.normci.msm <- function(x, covariates="mean", cl=0.95, B=1000) { e.list <- normboot.msm(x, function(x)ematrix.msm(x=x, covariates=covariates, ci="none"), B) e.array <- array(unlist(e.list), dim=c(dim(e.list[[1]]), length(e.list))) e.ci <- apply(e.array, c(1,2), function(x)(c(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)), sd(x)))) aperm(e.ci, c(2,3,1)) } qratio.normci.msm <- function(x, ind1, ind2, covariates="mean", cl=0.95, B=1000) { q.list <- normboot.msm(x, function(x)qratio.msm(x=x, ind1=ind1, ind2=ind2, covariates=covariates, ci="none")["estimate"], B) q.vec <- unlist(q.list) c(quantile(q.vec, c(0.5 - cl/2, 0.5 + cl/2)), sd(q.vec)) } pnext.normci.msm <- function(x, covariates="mean", cl=0.95, B=1000) { p.list <- normboot.msm(x, function(x)pnext.msm(x=x, covariates=covariates, ci="none")$estimates, B) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } pmatrix.normci.msm <- function(x, t, t1, covariates="mean", cl=0.95, B=1000) { p.list <- normboot.msm(x, function(x)pmatrix.msm(x=x, t=t, t1=t1, covariates=covariates, ci="none"), B) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } pmatrix.piecewise.normci.msm <- function(x, t1, t2, times, covariates="mean", cl=0.95, B=1000) { p.list <- normboot.msm(x, function(x)pmatrix.piecewise.msm(x=x, t1=t1, t2=t2, times=times, covariates=covariates, ci="none"), B) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } totlos.normci.msm <- function(x, start=1, end=NULL, fromt=0, tot=Inf, covariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, discount=0, env=FALSE, cl=0.95, B=1000, ...) { t.list <- normboot.msm(x, function(x)totlos.msm(x=x, start=start, end=end, fromt=fromt, tot=tot, covariates=covariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, discount=discount, env=env, ci="none", ...), B) t.array <- do.call("rbind", t.list) apply(t.array, 2, function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) } efpt.normci.msm <- function(x, qmatrix=NULL, tostate, start, covariates="mean", cl=0.95, B=1000, ...) { t.list <- normboot.msm(x, function(x)efpt.msm(x=x, qmatrix=qmatrix, tostate=tostate, start=start, covariates=covariates, ci="none", ...), B) t.array <- do.call("rbind", t.list) apply(t.array, 2, function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) } ppass.normci.msm <- function(x, qmatrix, tot, start, covariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, cl=0.95, B=1000, ...) { t.list <- normboot.msm(x, function(x)ppass.msm(x=x, qmatrix=qmatrix, tot=tot, start=start, covariates=covariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, ci="none", ...), B) nst <- ncol(t.list[[1]]) t.array <- do.call("rbind", lapply(t.list, as.vector)) ci <- apply(t.array, 2, function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) di <- dimnames(t.list[[1]]) list(L=matrix(ci[1,],ncol=nst,dimnames=di), U=matrix(ci[2,],ncol=nst, dimnames=di)) } expected.normci.msm <- function(x, times=NULL, timezero=NULL, initstates=NULL, covariates="mean", misccovariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, risk=NULL, cl=0.95, B=1000) { if(is.null(risk)) risk <- observed.msm(x)$risk e.list <- normboot.msm(x, function(x){ expected.msm(x, times, timezero, initstates, covariates, misccovariates, piecewise.times, piecewise.covariates, risk) }, B) e.tab.array <- array(unlist(lapply(e.list, function(x)x[[1]])), dim=c(dim(e.list[[1]][[1]]), length(e.list))) e.perc.array <- array(unlist(lapply(e.list, function(x)x[[2]])), dim=c(dim(e.list[[1]][[2]]), length(e.list))) e.tab.ci <- apply(e.tab.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) e.perc.ci <- apply(e.perc.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) res <- list(aperm(e.tab.ci, c(2,3,1)), aperm(e.perc.ci, c(2,3,1))) names(res) <- c("Expected", "Expected percentages") res } phasemeans.normci.msm <- function(x, covariates="mean", cl=0.95, B=1000, ...) { p.list <- normboot.msm(x, function(x)phasemeans.msm(x=x, covariates=covariates, ci="none", ...), B) p.array <- array(unlist(p.list), dim=c(dim(p.list[[1]]), length(p.list))) p.ci <- apply(p.array, c(1,2), function(x)(quantile(x, c(0.5 - cl/2, 0.5 + cl/2)))) aperm(p.ci, c(2,3,1)) } msm/R/msm.R0000755000176200001440000027565312661613502012215 0ustar liggesusersmsm <- function(formula, subject=NULL, data=list(), qmatrix, gen.inits=FALSE, ematrix=NULL, hmodel=NULL, obstype=NULL, obstrue=NULL, covariates = NULL, covinits = NULL, constraint = NULL, misccovariates = NULL, misccovinits = NULL, miscconstraint = NULL, hcovariates = NULL, hcovinits = NULL, hconstraint = NULL, hranges=NULL, qconstraint=NULL, econstraint=NULL, initprobs = NULL, est.initprobs=FALSE, initcovariates = NULL, initcovinits = NULL, deathexact = NULL, death = NULL, exacttimes = FALSE, censor=NULL, censor.states=NULL, pci=NULL, phase.states=NULL, phase.inits = NULL, # TODO merge with inits eventually cl = 0.95, fixedpars = NULL, center=TRUE, opt.method="optim", hessian=NULL, use.deriv=TRUE, use.expm=TRUE, analyticp=TRUE, na.action=na.omit, ...) { call <- match.call() if (missing(formula)) stop("state ~ time formula not given") if (missing(data)) data <- environment(formula) ### MODEL FOR TRANSITION INTENSITIES if (gen.inits) { if (is.null(hmodel) && is.null(ematrix)) { subj <- eval(substitute(subject), data, parent.frame()) qmatrix <- crudeinits.msm(formula, subj, qmatrix, data, censor, censor.states) } else warning("gen.inits not supported for hidden Markov models, ignoring") } qmodel <- qmodel.orig <- msm.form.qmodel(qmatrix, qconstraint, analyticp, use.expm, phase.states) if (!is.null(phase.states)) { qmodel <- msm.phase2qmodel(qmodel, phase.states, phase.inits, qconstraint, analyticp, use.expm) } ### MISCLASSIFICATION MODEL if (!is.null(ematrix)) { msm.check.ematrix(ematrix, qmodel.orig$nstates) if (!is.null(phase.states)){ stop("phase-type models with additional misclassification must be specified through \"hmodel\" with hmmCat() or hmmIdent() constructors, or as HMMs by hand") } emodel <- msm.form.emodel(ematrix, econstraint, initprobs, est.initprobs, qmodel) } else emodel <- list(misc=FALSE, npars=0, ndpars=0) ### GENERAL HIDDEN MARKOV MODEL if (!is.null(hmodel)) { msm.check.hmodel(hmodel, qmodel.orig$nstates) if (!is.null(phase.states)){ hmodel.orig <- hmodel hmodel <- rep(hmodel, qmodel$phase.reps) } hmodel <- msm.form.hmodel(hmodel, hconstraint, initprobs, est.initprobs) } else { if (!is.null(hcovariates)) stop("hcovariates have been specified, but no hmodel") if (!is.null(phase.states)){ hmodel <- msm.phase2hmodel(qmodel, hmodel) } else hmodel <- list(hidden=FALSE, models=rep(0, qmodel$nstates), nipars=0, nicoveffs=0, totpars=0, ncoveffs=0) # might change later if misc } ### CONVERT OLD STYLE MISCLASSIFICATION MODEL TO NEW GENERAL HIDDEN MARKOV MODEL if (emodel$misc) { hmodel <- msm.emodel2hmodel(emodel, qmodel) } else { emodel <- list(misc=FALSE, npars=0, ndpars=0, nipars=0, nicoveffs=0) hmodel$ematrix <- FALSE } ### EXACT DEATH TIMES. Logical values allowed for backwards compatibility (TRUE means final state has exact death time, FALSE means no states with exact death times) if (!is.null(deathexact)) death <- deathexact dmodel <- msm.form.dmodel(death, qmodel, hmodel) # returns death, ndeath, if (dmodel$ndeath > 0 && exacttimes) warning("Ignoring death argument, as all states have exact entry times") ### CENSORING MODEL cmodel <- msm.form.cmodel(censor, censor.states, qmodel$qmatrix) ### SOME CHECKS if (!inherits(formula, "formula")) stop("formula is not a formula") if (!is.null(covariates) && (!(is.list(covariates) || inherits(covariates, "formula")))) stop(deparse(substitute(covariates)), " should be a formula or list of formulae") if (!is.null(misccovariates) && (!inherits(misccovariates, "formula"))) stop(deparse(substitute(misccovariates)), " should be a formula") if (is.list(covariates)) { # different covariates on each intensity covlist <- covariates msm.check.covlist(covlist, qmodel) ter <- lapply(covlist, function(x)attr(terms(x),"term.labels")) covariates <- reformulate(unique(unlist(ter))) # merge the formulae into one } else covlist <- NULL # parameters will be constrained later, see msm.form.cri if (is.null(covariates)) covariates <- ~1 if (emodel$misc && is.null(misccovariates)) misccovariates <- ~1 if (hmodel$hidden && !is.null(hcovariates)) msm.check.hcovariates(hcovariates, qmodel) ### BUILD MODEL FRAME containing all data required for model fit, ### using all variables found in formulae. ## Names include factor() around covariate names, and interactions, ## if specified. Need to build and evaluate a call, instead of ## running model.frame() directly, to find subject and other ## extras. Not sure why. indx <- match(c("data", "subject", "obstrue"), names(call), nomatch = 0) temp <- call[c(1, indx)] temp[[1]] <- as.name("model.frame") temp[["state"]] <- as.name(all.vars(formula[[2]])) temp[["time"]] <- as.name(all.vars(formula[[3]])) varnames <- function(x){if(is.null(x)) NULL else attr(terms(x), "term.labels")} forms <- c(covariates, misccovariates, hcovariates, initcovariates) covnames <- unique(unlist(lapply(forms, varnames))) temp[["formula"]] <- if (length(covnames) > 0) reformulate(covnames) else ~1 temp[["na.action"]] <- na.pass # run na.action later so we can pass aux info to it temp[["data"]] <- data mf <- eval(temp, parent.frame()) ## remember user-specified names for later (e.g. bootstrap/cross validation) attr(mf, "usernames") <- c(state=all.vars(formula[[2]]), time=all.vars(formula[[3]]), subject=as.character(temp$subject), obstype=as.character(substitute(obstype)), obstrue=as.character(temp$obstrue)) if (is.factor(mf$"(state)")){ if (!all(grepl("^[[:digit:]]+$", as.character(mf$"(state)")))) stop("state variable should be numeric or a factor with ordinal numbers as levels") else mf$"(state)" <- as.numeric(as.character(mf$"(state)")) } msm.check.state(qmodel$nstates, mf$"(state)", cmodel$censor, hmodel) if (is.null(mf$"(subject)")) mf$"(subject)" <- rep(1, nrow(mf)) msm.check.times(mf$"(time)", mf$"(subject)", mf$"(state)") obstype <- if (missing(obstype)) NULL else eval(substitute(obstype), data, parent.frame()) # handle separately to allow passing a scalar (1, 2 or 3) mf$"(obstype)" <- msm.form.obstype(mf, obstype, dmodel, exacttimes) mf$"(obstrue)" <- msm.form.obstrue(mf, hmodel, cmodel) mf$"(obs)" <- seq_len(nrow(mf)) # row numbers before NAs omitted, for reporting in msm.check.* basenames <- c("(state)","(time)","(subject)","(obstype)","(obstrue)","(obs)") attr(mf, "covnames") <- setdiff(names(mf), basenames) attr(mf, "covnames.q") <- colnames(attr(terms(covariates), "factors")) # names as in data, plus factor() if user if (emodel$misc) attr(mf, "covnames.e") <- colnames(attr(terms(misccovariates), "factors")) attr(mf, "ncovs") <- length(attr(mf, "covnames")) ### HANDLE MISSING DATA ## Find which cols of model frame correspond to covs which appear only on initprobs ## Pass through to na.action as attribute ic <- all.vars(initcovariates) others <- c(covariates,misccovariates,hcovariates) oic <- ic[!ic %in% unlist(lapply(others, all.vars))] attr(mf, "icovi") <- match(oic, colnames(mf)) if (missing(na.action) || identical(na.action, na.omit) || (identical(na.action,"na.omit"))) mf <- na.omit.msmdata(mf) else if (identical(na.action, na.fail) || (identical(na.action,"na.fail"))) mf <- na.fail.msmdata(mf) else stop ("na.action should be \"na.omit\" or \"na.fail\"") attr(mf, "npts") <- length(unique(mf$"(subject)")) ### UTILITY FOR PIECEWISE-CONSTANT INTENSITIES. Insert censored ## observations into the model frame, add a factor "timeperiod" to ## the data, and add the corresponding term to the formula. ## NOTE pci kept pre-imputed data as msmdata.obs.orig if (!is.null(pci)) { tdmodel <- msm.pci(pci, mf, qmodel, cmodel, covariates) if (!is.null(tdmodel)) { mf <- tdmodel$mf; covariates <- tdmodel$covariates; cmodel <- tdmodel$cmodel pci <- tdmodel$tcut # was returned in msm object } else {pci <- NULL; mf$"(pci.imp)" <- 0} } ### CALCULATE COVARIATE MEANS from data by transition, including means of 0/1 contrasts. forms <- c(covariates, misccovariates, hcovariates, initcovariates) # covariates may have been updated to include timeperiod for pci covnames <- unique(unlist(lapply(forms, varnames))) if (length(covnames) > 0) { mm.mean <- model.matrix(reformulate(covnames), mf) cm <- colMeans(mm.mean[duplicated(mf$"(subject)",fromLast=TRUE),,drop=FALSE]) cm["(Intercept)"] <- 0 } else cm <- NULL attr(mf, "covmeans") <- cm ### MAKE AGGREGATE DATA for computing likelihood of non-hidden models efficiently ### This can also be used externally to extract aggregate data from model frame in msm object mf.agg <- msm.form.mf.agg(list(data=list(mf=mf), qmodel=qmodel, hmodel=hmodel, cmodel=cmodel)) ### Make indicator for which distinct P matrix each observation corresponds to. Only used in HMMs. mf$"(pcomb)" <- msm.form.hmm.agg(mf); ### CONVERT misclassification covariate formula to hidden covariate formula if (inherits(misccovariates, "formula")){ if (!emodel$misc) stop("misccovariates supplied but no ematrix") hcovariates <- lapply(ifelse(rowSums(emodel$imatrix)>0, deparse(misccovariates), deparse(~1)), as.formula) } ### FORM DESIGN MATRICES FOR COVARIATE MODELS ### These can also be used externally to extract design matrices from model frame in msm object mm.cov <- msm.form.mm.cov(list(data=list(mf=mf), covariates=covariates, center=center)) mm.cov.agg <- msm.form.mm.cov.agg(list(data=list(mf.agg=mf.agg), covariates=covariates, hmodel=hmodel, cmodel=cmodel, center=center)) mm.mcov <- msm.form.mm.mcov(list(data=list(mf=mf), misccovariates=misccovariates, emodel=emodel, center=center)) mm.hcov <- msm.form.mm.hcov(list(data=list(mf=mf), hcovariates=hcovariates, qmodel=qmodel, hmodel=hmodel, center=center)) mm.icov <- msm.form.mm.icov(list(data=list(mf=mf), initcovariates=initcovariates, hmodel=hmodel, center=center)) ### MODEL FOR COVARIATES ON INTENSITIES if (!is.null(covlist)) { cri <- msm.form.cri(covlist, qmodel, mf, mm.cov) } else cri <- NULL qcmodel <- if (ncol(mm.cov) > 1) msm.form.covmodel(mf, mm.cov, constraint, covinits, cm, qmodel$npars, cri) else { if (!is.null(constraint)) warning("constraint specified but no covariates") list(npars=0, ncovs=0, ndpars=0) } ### MODEL FOR COVARIATES ON MISCLASSIFICATION PROBABILITIES if (!emodel$misc || is.null(misccovariates)) ecmodel <- list(npars=0, ncovs=0) if (!is.null(misccovariates)) { if (!emodel$misc) { warning("misccovariates have been specified, but misc is FALSE. Ignoring misccovariates.") } else { ecmodel <- msm.form.covmodel(mf, mm.mcov, miscconstraint, misccovinits, cm, emodel$npars, cri=NULL) hcovariates <- msm.misccov2hcov(misccovariates, emodel) hcovinits <- msm.misccovinits2hcovinits(misccovinits, hcovariates, emodel, ecmodel) } } ### MODEL FOR COVARIATES ON GENERAL HIDDEN PARAMETERS if (!is.null(hcovariates)) { if (hmodel$mv) stop("hcovariates not supported for multivariate hidden Markov models") hmodel <- msm.form.hcmodel(hmodel, mm.hcov, hcovinits, hconstraint) if (emodel$misc) hmodel$covconstr <- msm.form.hcovconstraint(miscconstraint, hmodel) } else if (hmodel$hidden) { npars <- if(hmodel$mv) colSums(hmodel$npars) else hmodel$npars hmodel <- c(hmodel, list(ncovs=rep(rep(0, hmodel$nstates), npars), ncoveffs=0)) class(hmodel) <- "hmodel" } if (!is.null(initcovariates)) { if (hmodel$hidden) hmodel <- msm.form.icmodel(hmodel, mm.icov, initcovinits) else warning("initprobs and initcovariates ignored for non-hidden Markov models") } else if (hmodel$hidden) { hmodel <- c(hmodel, list(nicovs=rep(0, hmodel$nstates-1), nicoveffs=0, cri=ecmodel$cri)) class(hmodel) <- "hmodel" } if (hmodel$hidden && !emodel$misc) { hmodel$constr <- msm.form.hconstraint(hconstraint, hmodel) hmodel$covconstr <- msm.form.hcovconstraint(hconstraint, hmodel) } if (hmodel$hidden) hmodel$ranges <- msm.form.hranges(hranges, hmodel) ### INITIAL STATE OCCUPANCY PROBABILITIES IN HMMS if (hmodel$hidden) hmodel <- msm.form.initprobs(hmodel, initprobs, mf) ### FORM LIST OF INITIAL PARAMETERS, MATCHING PROVIDED INITS WITH SPECIFIED MODEL, FIXING SOME PARS IF REQUIRED p <- msm.form.params(qmodel, qcmodel, emodel, hmodel, fixedpars) msmdata <- list(mf=mf, mf.agg=mf.agg, mm.cov=mm.cov, mm.cov.agg=mm.cov.agg, mm.mcov=mm.mcov, mm.hcov=mm.hcov, mm.icov=mm.icov) ### CALCULATE LIKELIHOOD AT INITIAL VALUES OR DO OPTIMISATION (see optim.R) if (p$fixed) opt.method <- "fixed" if (is.null(hessian)) hessian <- !p$fixed p <- msm.optim(opt.method, p, hessian, use.deriv, msmdata, qmodel, qcmodel, cmodel, hmodel, ...) if (p$fixed) { p$foundse <- FALSE p$covmat <- NULL } else { p$params <- msm.rep.constraints(p$params, p, hmodel) hess <- if (hessian) p$opt$hessian else p$information if (!is.null(hess) && all(!is.na(hess)) && all(!is.nan(hess)) && all(is.finite(hess)) && all(eigen(hess)$values > 0)) { p$foundse <- TRUE p$covmat <- matrix(0, nrow=p$npars, ncol=p$npars) p$covmat[p$optpars,p$optpars] <- solve(0.5 * hess) p$covmat <- p$covmat[!duplicated(abs(p$constr)),!duplicated(abs(p$constr)), drop=FALSE][abs(p$constr),abs(p$constr), drop=FALSE] p$ci <- cbind(p$params - qnorm(1 - 0.5*(1-cl))*sqrt(diag(p$covmat)), p$params + qnorm(1 - 0.5*(1-cl))*sqrt(diag(p$covmat))) p$ci[p$fixedpars,] <- NA for (i in 1:2) p$ci[,i] <- gexpit(p$ci[,i], p$ranges[,"lower",drop=FALSE], p$ranges[,"upper",drop=FALSE]) } else { p$foundse <- FALSE p$covmat <- p$ci <- NULL if (!is.null(hess)) warning("Optimisation has probably not converged to the maximum likelihood - Hessian is not positive definite.") } } p$estimates.t <- p$params # Calculate estimates and CIs on natural scale p$estimates.t <- msm.inv.transform(p$params, hmodel, p$ranges) ## calculate CIs for misclassification probabilities (needs multivariate transform and delta method) if (any(p$plabs=="p") && p$foundse){ p.se <- p.se.msm(x=list(data=msmdata,qmodel=qmodel,emodel=emodel,hmodel=hmodel, qcmodel=qcmodel,ecmodel=ecmodel,paramdata=p,center=center), covariates = if(center) "mean" else 0) p$ci[p$plabs %in% c("p","pbase"),] <- as.numeric(unlist(p.se[,c("LCL","UCL")])) } ## calculate CIs for initial state probabilities in HMMs (using normal simulation method) if (p$foundse && any(p$plabs=="initp")) p <- initp.ci.msm(p, cl) ### FORM A MSM OBJECT FROM THE RESULTS msmobject <- list ( call = match.call(), minus2loglik = p$lik, deriv = p$deriv, estimates = p$params, estimates.t = p$estimates.t, fixedpars = p$fixedpars, center = center, covmat = p$covmat, ci = p$ci, opt = p$opt, foundse = p$foundse, data = msmdata, qmodel = qmodel, emodel = emodel, qcmodel = qcmodel, ecmodel = ecmodel, hmodel = hmodel, cmodel = cmodel, pci = pci, paramdata=p, cl=cl, covariates=covariates, misccovariates=misccovariates, hcovariates=hcovariates, initcovariates=initcovariates ) attr(msmobject, "fixed") <- p$fixed class(msmobject) <- "msm" ### Form lists of matrices from parameter estimates msmobject <- msm.form.output(msmobject, "intens") ### Include intensity and misclassification matrices on natural scales q <- qmatrix.msm(msmobject, covariates=(if(center) "mean" else 0)) msmobject$Qmatrices$baseline <- q$estimates msmobject$QmatricesSE$baseline <- q$SE msmobject$QmatricesL$baseline <- q$L msmobject$QmatricesU$baseline <- q$U if (hmodel$hidden) { msmobject$hmodel <- msm.form.houtput(hmodel, p, msmdata) } if (emodel$misc) { msmobject <- msm.form.output(msmobject, "misc") e <- ematrix.msm(msmobject, covariates=(if(center) "mean" else 0)) msmobject$Ematrices$baseline <- e$estimates msmobject$EmatricesSE$baseline <- e$SE msmobject$EmatricesL$baseline <- e$L msmobject$EmatricesU$baseline <- e$U } msmobject$msmdata[!names(msmobject$msmdata)=="mf"] <- NULL # only keep model frame in returned data. drop at last minute, as might be needed in msm.form.houtput. ### Include mean sojourn times msmobject$sojourn <- sojourn.msm(msmobject, covariates=(if(center) "mean" else 0)) msmobject } msm.check.qmatrix <- function(qmatrix) { if (!is.numeric(qmatrix) || ! is.matrix(qmatrix)) stop("qmatrix should be a numeric matrix") if (nrow(qmatrix) != ncol(qmatrix)) stop("Number of rows and columns of qmatrix should be equal") q2 <- qmatrix; diag(q2) <- 0 if (any(q2 < 0)) stop("off-diagonal entries of qmatrix should not be negative") invisible() } msm.fixdiag.qmatrix <- function(qmatrix) { diag(qmatrix) <- 0 diag(qmatrix) <- - rowSums(qmatrix) qmatrix } msm.fixdiag.ematrix <- function(ematrix) { diag(ematrix) <- 0 diag(ematrix) <- 1 - rowSums(ematrix) ematrix } msm.form.qmodel <- function(qmatrix, qconstraint=NULL, analyticp=TRUE, use.expm=FALSE, phase.states=NULL) { msm.check.qmatrix(qmatrix) nstates <- dim(qmatrix)[1] qmatrix <- msm.fixdiag.qmatrix(qmatrix) if (is.null(rownames(qmatrix))) rownames(qmatrix) <- colnames(qmatrix) <- paste("State", seq(nstates)) else if (is.null(colnames(qmatrix))) colnames(qmatrix) <- rownames(qmatrix) imatrix <- ifelse(qmatrix > 0, 1, 0) inits <- t(qmatrix)[t(imatrix)==1] npars <- sum(imatrix) ## for phase-type models, leave processing qconstraint until after phased Q matrix has been formed in msm.phase2qmodel if (!is.null(qconstraint) && is.null(phase.states)) { if (!is.numeric(qconstraint)) stop("qconstraint should be numeric") if (length(qconstraint) != npars) stop("baseline intensity constraint of length " ,length(qconstraint), ", should be ", npars) constr <- match(qconstraint, unique(qconstraint)) } else constr <- 1:npars ndpars <- max(constr) ipars <- t(imatrix)[t(lower.tri(imatrix) | upper.tri(imatrix))] graphid <- paste(which(ipars==1), collapse="-") if (analyticp && graphid %in% names(.msm.graphs[[paste(nstates)]])) { ## analytic P matrix is implemented for this particular intensity matrix iso <- .msm.graphs[[paste(nstates)]][[graphid]]$iso perm <- .msm.graphs[[paste(nstates)]][[graphid]]$perm qperm <- order(perm) # diff def in 1.2.3, indexes q matrices not vectors } else { iso <- 0 perm <- qperm <- NA } qmodel <- list(nstates=nstates, iso=iso, perm=perm, qperm=qperm, npars=npars, imatrix=imatrix, qmatrix=qmatrix, inits=inits, constr=constr, ndpars=ndpars, expm=as.numeric(use.expm)) class(qmodel) <- "msmqmodel" qmodel } msm.check.ematrix <- function(ematrix, nstates) { if (!is.numeric(ematrix) || ! is.matrix(ematrix)) stop("ematrix should be a numeric matrix") if (nrow(ematrix) != ncol(ematrix)) stop("Number of rows and columns of ematrix should be equal") if (!all(dim(ematrix) == nstates)) stop("Dimensions of qmatrix and ematrix should be the same") if (!all ( ematrix >= 0 | ematrix <= 1) ) stop("Not all elements of ematrix are between 0 and 1") invisible() } msm.form.emodel <- function(ematrix, econstraint=NULL, initprobs=NULL, est.initprobs, qmodel) { diag(ematrix) <- 0 imatrix <- ifelse(ematrix > 0 & ematrix < 1, 1, 0) # don't count as parameters if perfect misclassification (1.4.2 bug fix) diag(ematrix) <- 1 - rowSums(ematrix) if (is.null(rownames(ematrix))) rownames(ematrix) <- colnames(ematrix) <- paste("State", seq(qmodel$nstates)) else if (is.null(colnames(ematrix))) colnames(ematrix) <- rownames(ematrix) dimnames(imatrix) <- dimnames(ematrix) npars <- sum(imatrix) nstates <- nrow(ematrix) inits <- t(ematrix)[t(imatrix)==1] if (is.null(initprobs)) { initprobs <- if (est.initprobs) rep(1/qmodel$nstates, qmodel$nstates) else c(1, rep(0, qmodel$nstates-1)) } else { if (!is.numeric(initprobs)) stop("initprobs should be numeric") if (is.matrix(initprobs)) { if (ncol(initprobs) != qmodel$nstates) stop("initprobs matrix has ", ncol(initprobs), " columns, should be number of states = ", qmodel$nstates) if (est.initprobs) { warning("Not estimating initial state occupancy probabilities since supplied as a matrix") } initprobs <- initprobs / rowSums(initprobs) est.initprobs <- FALSE } else { if (length(initprobs) != qmodel$nstates) stop("initprobs vector of length ", length(initprobs), ", should be vector of length ", qmodel$nstates, " or a matrix") initprobs <- initprobs / sum(initprobs) if (est.initprobs && any(initprobs==1)) { est.initprobs <- FALSE warning("Not estimating initial state occupancy probabilities, since some are fixed to 1") } } } nipars <- if (est.initprobs) qmodel$nstates else 0 if (!is.null(econstraint)) { if (!is.numeric(econstraint)) stop("econstraint should be numeric") if (length(econstraint) != npars) stop("baseline misclassification constraint of length " ,length(econstraint), ", should be ", npars) constr <- match(econstraint, unique(econstraint)) } else constr <- seq(length=npars) ndpars <- if(npars>0) max(constr) else 0 nomisc <- isTRUE(all.equal(as.vector(diag(ematrix)),rep(1,nrow(ematrix)))) # degenerate ematrix with no misclassification: all 1 on diagonal if (nomisc) emodel <- list(misc=FALSE, npars=0, ndpars=0) else emodel <- list(misc=TRUE, npars=npars, nstates=nstates, imatrix=imatrix, ematrix=ematrix, inits=inits, constr=constr, ndpars=ndpars, nipars=nipars, initprobs=initprobs, est.initprobs=est.initprobs) class(emodel) <- "msmemodel" emodel } ### Check elements of state vector. For simple models and misc models specified with ematrix ### No check is performed for hidden models msm.check.state <- function(nstates, state, censor, hmodel) { if (hmodel$hidden){ if (!is.null(ncol(state))) { pl1 <- if (ncol(state) > 1) "s" else "" pl2 <- if (max(hmodel$nout) > 1) "s" else "" if ((ncol(state) != max(hmodel$nout)) && (max(hmodel$nout) > 1)) stop(sprintf("outcome matrix in data has %d column%s, but outcome models have a maximum of %d dimension%s", ncol(state), pl1, max(hmodel$nout), pl2)) } } else { states <- c(1:nstates, censor) state <- na.omit(state) # NOTE added in 1.4 if (!is.null(ncol(state)) && ncol(state) > 1) stop("Matrix outcomes only allowed for hidden Markov models") if (!is.null(state)) { statelist <- if (nstates==2) "1, 2" else if (nstates==3) "1, 2, 3" else paste("1, 2, ... ,",nstates) if (length(setdiff(unique(state), states)) > 0) stop("State vector contains elements not in ",statelist) miss.state <- setdiff(states, unique(state)) ## Don't do this for misclassification models: it's OK to have particular state not observed by chance if (length(miss.state) > 0 && !hmodel$ematrix) warning("State vector doesn't contain observations of ",paste(miss.state, collapse=",")) } } invisible() } msm.check.times <- function(time, subject, state=NULL) { final.rows <- !is.na(subject) & !is.na(time) if (!is.null(state)) { nas <- if (is.matrix(state)) apply(state, 1, function(x)all(is.na(x))) else is.na(state) final.rows <- final.rows & !nas state <- if (is.matrix(state)) state[final.rows, ,drop=FALSE] else state[final.rows] } final.rows <- which(final.rows) time <- time[final.rows]; subject <- subject[final.rows] ### Check if any individuals have only one observation (after excluding missing data) ### Note this shouldn't happen after 1.2 subj.num <- match(subject,unique(subject)) # avoid problems with factor subjects with empty levels nobspt <- table(subj.num) if (any (nobspt == 1)) { badsubjs <- unique(subject)[ nobspt == 1 ] andothers <- if (length(badsubjs)>3) " and others" else "" if (length(badsubjs)>3) badsubjs <- badsubjs[1:3] badlist <- paste(badsubjs, collapse=", ") plural <- if (length(badsubjs)==1) "" else "s" has <- if (length(badsubjs)==1) "has" else "have" warning ("Subject", plural, " ", badlist, andothers, " only ", has, " one complete observation") } ### Check if observations within a subject are adjacent ind <- tapply(seq_along(subj.num), subj.num, length) imin <- tapply(seq_along(subj.num), subj.num, min) imax <- tapply(seq_along(subj.num), subj.num, max) adjacent <- (ind == imax-imin+1) if (any (!adjacent)) { badsubjs <- unique(subject)[ !adjacent ] andothers <- if (length(badsubjs)>3) " and others" else "" if (length(badsubjs)>3) badsubjs <- badsubjs[1:3] badlist <- paste(badsubjs, collapse=", ") plural <- if (length(badsubjs)==1) "" else "s" stop ("Observations within subject", plural, " ", badlist, andothers, " are not adjacent in the data") } ### Check if observations are ordered in time within subject orderedpt <- ! tapply(time, subj.num, is.unsorted) if (any (!orderedpt)) { badsubjs <- unique(subject)[ !orderedpt ] andothers <- if (length(badsubjs)>3) " and others" else "" if (length(badsubjs)>3) badsubjs <- badsubjs[1:3] badlist <- paste(badsubjs, collapse=", ") plural <- if (length(badsubjs)==1) "" else "s" stop ("Observations within subject", plural, " ", badlist, andothers, " are not ordered by time") } ### Check if any consecutive observations are made at the same time, but with different states if (!is.null(state)){ if (is.matrix(state)) state <- apply(state, 1, paste, collapse=",") prevsubj <- c(-Inf, subj.num[seq_along(subj.num)-1]) prevtime <- c(-Inf, time[1:length(time)-1]) prevstate <- c(-Inf, state[1:length(state)-1]) sametime <- final.rows[subj.num==prevsubj & prevtime==time & prevstate!=state] badlist <- paste(paste(sametime-1, sametime, sep=" and "), collapse=", ") if (any(sametime)) warning("Different states observed at the same time on the same subject at observations ", badlist) } invisible() } msm.form.obstype <- function(mf, obstype, dmodel, exacttimes) { if (!is.null(obstype)) { if (!is.numeric(obstype)) stop("obstype should be numeric") if (length(obstype) == 1) obstype <- rep(obstype, nrow(mf)) else if (length(obstype)!=nrow(mf)) stop("obstype of length ", length(obstype), ", should be length 1 or ",nrow(mf)) if (any(! obstype[duplicated(mf$"(subject)")] %in% 1:3)) stop("elements of obstype should be 1, 2, or 3") # ignore obstypes at subject's first observation } else if (!is.null(exacttimes) && exacttimes) obstype <- rep(2, nrow(mf)) else { obstype <- rep(1, nrow(mf)) if (dmodel$ndeath > 0) obstype[mf$"(state)" %in% dmodel$obs] <- 3 } obstype } ### On exit, obstrue will contain the true state (if known) or 0 (if unknown) ### Any NAs should be replaced by 0 - logically if you don't know whether the state is known or not, that means you don't know the state ### TODO For cases where true state is known, ### distinguish between cases where the state data contains the true state or a misclassified version of the true state msm.form.obstrue <- function(mf, hmodel, cmodel) { obstrue <- mf$"(obstrue)" if (!is.null(obstrue)) { if (!hmodel$hidden) { warning("Specified obstrue for a non-hidden model, ignoring.") obstrue <- rep(1, nrow(mf)) } else if (!is.numeric(obstrue) && !is.logical(obstrue)) stop("obstrue should be logical or numeric") else { if (is.logical(obstrue) || (all(na.omit(obstrue) %in% 0:1) && !any(is.na(obstrue)))){ ## obstrue is an indicator. Actual state should then be supplied in the outcome vector ## (typically misclassification models) ## interpret presence of NAs as indicating true state supplied here if (!is.null(ncol(mf$"(state)")) && ncol(mf$"(state)") > 1) stop("obstrue must contain NA or the true state for a multiple outcome HMM, not an 0/1 indicator") obstrue <- ifelse(obstrue, mf$"(state)", 0) } else { ## obstrue contains the actual state (used when we have another outcome conditionally on this) if (!all(na.omit(obstrue) %in% 0:hmodel$nstates)){ stop("Interpreting \"obstrue\" as containing true states, but it contains values not in 0,1,...,", hmodel$nstates) } obstrue[is.na(obstrue)] <- 0 # true state assumed unknown if NA ## If misclassification model specified through "ematrix", interpret the state data as the true state. ## If specified through hmodel (including hmmCat), interpret the state as a misclassified/HMM outcome generated conditionally on the true state. ## Though that doesn't allow a mixture of true/misclassified states in the same model ## If we know the true state, we might sometimes want ## to model a misclassified version of it to ## strengthen estimation of misclassification probs. ## In theory we could put NA in the state then to ## indicate that true state is passed through from ## obstrue, and misclassified version isn't known. ## But don't do this until someone asks for it. } } } else if (hmodel$hidden) obstrue <- rep(0, nrow(mf)) else obstrue <- mf$"(state)" if (cmodel$ncens > 0){ ## If censoring and obstrue, put the first of the possible states into obstrue ## Used in Viterbi for (i in seq_along(cmodel$censor)) obstrue[obstrue==cmodel$censor[i] & obstrue > 0] <- cmodel$states[cmodel$index[i]] } obstrue } ## Replace censored states by state with highest probability that they ## could represent. Used in msm.check.model to check consistency of ## data with transition parameters msm.impute.censored <- function(fromstate, tostate, Pmat, cmodel) { ## e.g. cmodel$censor 99,999; cmodel$states 1,2,1,2,3; cmodel$index 1, 3, 6 ## Both from and to are censored wb <- which ( fromstate %in% cmodel$censor & tostate %in% cmodel$censor) for (i in wb) { si <- which(cmodel$censor==fromstate[i]) fc <- cmodel$states[(cmodel$index[si]) : (cmodel$index[si+1]-1)] ti <- which(cmodel$censor==tostate[i]) tc <- cmodel$states[(cmodel$index[ti]) : (cmodel$index[ti+1]-1)] mp <- which.max(Pmat[fc, tc]) fromstate[i] <- fc[row(Pmat[fc, tc])[mp]] tostate[i] <- tc[col(Pmat[fc, tc])[mp]] } ## Only from is censored wb <- which(fromstate %in% cmodel$censor) for (i in wb) { si <- which(cmodel$censor==fromstate[i]) fc <- cmodel$states[(cmodel$index[si]) : (cmodel$index[si+1]-1)] fromstate[i] <- fc[which.max(Pmat[fc, tostate[i]])] } ## Only to is censored wb <- which(tostate %in% cmodel$censor) for (i in wb) { si <- which(cmodel$censor==tostate[i]) tc <- cmodel$states[(cmodel$index[si]) : (cmodel$index[si+1]-1)] tostate[i] <- tc[which.max(Pmat[fromstate[i], tc])] } list(fromstate=fromstate, tostate=tostate) } ### CHECK THAT TRANSITION PROBABILITIES FOR DATA ARE ALL NON-ZERO ### (e.g. check for backwards transitions when the model is irreversible) ### obstype 1 must have unitprob > 0 ### obstype 2 must have qunit != 0, and unitprob > 0. ### obstype 3 must have unitprob > 0 msm.check.model <- function(fromstate, tostate, obs, subject, obstype=NULL, qmatrix, cmodel) { n <- length(fromstate) qmatrix <- qmatrix / mean(qmatrix[qmatrix>0]) # rescale to avoid false warnings with small rates Pmat <- MatrixExp(qmatrix) Pmat[Pmat < .Machine$double.eps] <- 0 imputed <- msm.impute.censored(fromstate, tostate, Pmat, cmodel) fs <- imputed$fromstate; ts <- imputed$tostate unitprob <- apply(cbind(fs, ts), 1, function(x) { Pmat[x[1], x[2]] } ) qunit <- apply(cbind(fs, ts), 1, function(x) { qmatrix[x[1], x[2]] } ) if (identical(all.equal(min(unitprob, na.rm=TRUE), 0), TRUE)) { badobs <- which.min(unitprob) warning ("Data may be inconsistent with transition matrix for model without misclassification:\n", "individual ", if(is.null(subject)) "" else subject[badobs], " moves from state ", fromstate[badobs], " to state ", tostate[badobs], " at observation ", obs[badobs], "\n") } if (any(qunit[obstype==2]==0)) { badobs <- min (obs[qunit==0 & obstype==2], na.rm = TRUE) warning ("Data may be inconsistent with intensity matrix for observations with exact transition times and no misclassification:\n", "individual ", if(is.null(subject)) "" else subject[obs==badobs], " moves from state ", fromstate[obs==badobs], " to state ", tostate[obs==badobs], " at observation ", badobs) } absorbing <- absorbing.msm(qmatrix=qmatrix) absabs <- (fromstate %in% absorbing) & (tostate %in% absorbing) if (any(absabs)) { badobs <- min( obs[absabs] ) warning("Absorbing - absorbing transition at observation ", badobs) } invisible() } msm.check.constraint <- function(constraint, mm){ if (is.null(constraint)) return(invisible()) covlabels <- colnames(mm)[-1] aa <- attr(mm, "assign") covfactor <- rep(table(aa), table(aa)) > 1 if (!is.list(constraint)) stop(deparse(substitute(constraint)), " should be a list") if (!all(sapply(constraint, is.numeric))) stop(deparse(substitute(constraint)), " should be a list of numeric vectors") ## check and parse the list of constraints on covariates for (i in names(constraint)) if (!(is.element(i, covlabels))){ factor.warn <- if ((i %in% names(covfactor)) && covfactor[i]) "\n\tFor factor covariates, specify constraints using covnameCOVVALUE = c(...)" else "" stop("Covariate \"", i, "\" in constraint statement not in model.", factor.warn) } } msm.check.covinits <- function(covinits, covlabels){ if (!is.list(covinits)) warning(deparse(substitute(covinits)), " should be a list") else if (!all(sapply(covinits, is.numeric))) warning(deparse(substitute(covinits)), " should be a list of numeric vectors") else { notin <- setdiff(names(covinits), covlabels) if (length(notin) > 0){ plural <- if (length(notin) > 1) "s " else " " warning("covariate", plural, paste(notin, collapse=", "), " in ", deparse(substitute(covinits)), " unknown") } } } ### Process covariates constraints, in preparation for being passed to the likelihood optimiser ### This function is called for both sets of covariates (transition rates and the misclassification probs) msm.form.covmodel <- function(mf, mm, constraint, covinits, covmeans, nmatrix, # number of transition intensities / misclassification probs cri ) { if (!is.null(cri)) return(msm.form.covmodel.byrate(mf, mm, constraint, covinits, covmeans, nmatrix, cri)) ncovs <- ncol(mm) - 1 covlabels <- colnames(mm)[-1] if (is.null(constraint)) { constraint <- rep(list(1:nmatrix), ncovs) names(constraint) <- covlabels constr <- 1:(nmatrix*ncovs) } else { msm.check.constraint(constraint, mm) constr <- inits <- numeric() maxc <- 0 for (i in seq(along=covlabels)){ ## build complete vectorised list of constraints for covariates in covariates statement ## so. e.g. constraints = (x1=c(3,3,4,4,5), x2 = (0.1,0.2,0.3,0.4,0.4)) ## turns into constr = c(1,1,2,2,3,4,5,6,7,7) with seven distinct covariate effects ## Allow constraints such as: some elements are minus others. Use negative elements of constr to do this. ## e.g. constr = c(1,1,-1,-1,2,3,4,5) ## obtained by match(abs(x), unique(abs(x))) * sign(x) if (is.element(covlabels[i], names(constraint))) { if (length(constraint[[covlabels[i]]]) != nmatrix) stop("\"",covlabels[i],"\" constraint of length ", length(constraint[[covlabels[i]]]),", should be ",nmatrix) } else constraint[[covlabels[i]]] <- seq(nmatrix) constr <- c(constr, (maxc + match(abs(constraint[[covlabels[i]]]), unique(abs(constraint[[covlabels[i]]]))))*sign(constraint[[covlabels[i]]]) ) maxc <- max(abs(constr)) } } inits <- numeric() if (!is.null(covinits)) msm.check.covinits(covinits, covlabels) for (i in seq(along=covlabels)) { if (!is.null(covinits) && is.element(covlabels[i], names(covinits))) { thisinit <- covinits[[covlabels[i]]] if (!is.numeric(thisinit)) { warning("initial values for covariates should be numeric, ignoring") thisinit <- rep(0, nmatrix) } if (length(thisinit) != nmatrix) { warning("\"", covlabels[i], "\" initial values of length ", length(thisinit), ", should be ", nmatrix, ", ignoring") thisinit <- rep(0, nmatrix) } inits <- c(inits, thisinit) } else { inits <- c(inits, rep(0, nmatrix)) } } npars <- ncovs*nmatrix ndpars <- max(unique(abs(constr))) list(npars=npars, ndpars=ndpars, # number of distinct covariate effect parameters ncovs=ncovs, constr=constr, covlabels=covlabels, # factors as separate contrasts inits = inits, covmeans = attr(mm, "means") ) } ## Process constraints and initial values for covariates supplied as a ## list of transition-specific formulae. Convert to form needed for a ## single covariates formula common to all transitions, which can be ## processed with msm.form.covmodel. msm.form.covmodel.byrate <- function(mf, mm, constraint, # as supplied by user covinits, # as supplied by user covmeans, nmatrix, cri ){ covs <- colnames(mm)[-1] ## Convert short form constraints to long form msm.check.constraint(constraint, mm) constr <- inits <- numeric() for (i in seq(along=covs)){ if (covs[i] %in% names(constraint)){ if (length(constraint[[covs[i]]]) != sum(cri[,i])) stop("\"",covs[i],"\" constraint of length ", length(constraint[[covs[i]]]),", should be ",sum(cri[,i])) con <- match(constraint[[covs[i]]], unique(constraint[[covs[i]]])) + 1 constraint[[covs[i]]] <- rep(1, nmatrix) constraint[[covs[i]]][cri[,i]==1] <- con } else constraint[[covs[i]]] <- seq(length=nmatrix) } ## convert short to long initial values in the same way if (!is.null(covinits)) msm.check.covinits(covinits, covs) for (i in seq(along=covs)) { if (!is.null(covinits) && (covs[i] %in% names(covinits))) { if (!is.numeric(covinits[[covs[i]]])) { warning("initial values for covariates should be numeric, ignoring") covinits[[covs[i]]] <- rep(0, nmatrix) } thisinit <- rep(0, nmatrix) if (length(covinits[[covs[i]]]) != sum(cri[,i])) { warning("\"", covs[i], "\" initial values of length ", length(covinits[[covs[i]]]), ", should be ", sum(cri[,i]), ", ignoring") covinits[[covs[i]]] <- rep(0, nmatrix) } else thisinit[cri[,i]==1] <- covinits[[covs[i]]] covinits[[covs[i]]] <- thisinit } } qcmodel <- msm.form.covmodel(mf, mm, constraint, covinits, covmeans, nmatrix, cri=NULL) qcmodel$cri <- cri qcmodel } msm.form.dmodel <- function(death, qmodel, hmodel) { nstates <- qmodel$nstates statelist <- if (nstates==2) "1, 2" else if (nstates==3) "1, 2, 3" else paste("1, 2, ... ,",nstates) if (is.null(death)) death <- FALSE if (is.logical(death) && death==TRUE) states <- nstates else if (is.logical(death) && death==FALSE) states <- numeric(0) ## Will be changed to -1 when passing to C else if (!is.numeric(death)) stop("Death states indicator must be numeric") else if (length(setdiff(death, 1:nstates)) > 0) stop("Death states indicator contains states not in ",statelist) else states <- death ndeath <- length(states) if (hmodel$hidden) { ## Form death state info from hmmIdent parameters. ## Special observations in outcome data which denote death states ## are given as the parameter to hmmIdent() if (!all(hmodel$models[states] == match("identity", .msm.HMODELS))) stop("Death states should have the identity hidden distribution hmmIdent()") obs <- ifelse(hmodel$npars[states]>0, hmodel$pars[hmodel$parstate %in% states], states) } else obs <- states if (any (states %in% transient.msm(qmatrix=qmodel$qmatrix))) stop("Not all the \"death\" states are absorbing states") list(ndeath=ndeath, states=states, obs=obs) } msm.form.cmodel <- function(censor=NULL, censor.states=NULL, qmatrix) { if (is.null(censor)) { ncens <- 0 if (!is.null(censor.states)) warning("censor.states supplied but censor not supplied") } else { if (!is.numeric(censor)) stop("censor must be numeric") if (any(censor %in% 1:nrow(qmatrix))) warning("some censoring indicators are the same as actual states") ncens <- length(censor) if (is.null(censor.states)) { if (ncens > 1) { warning("more than one type of censoring given, but censor.states not supplied. Assuming only one type of censoring") ncens <- 1; censor <- censor[1] } censor.states <- transient.msm(qmatrix=qmatrix) states.index <- c(1, length(censor.states)+1) } else { if (ncens == 1) { if (!is.vector(censor.states) || (is.list(censor.states) && (length(censor.states) > 1)) ) stop("if one type of censoring, censor.states should be a vector, or a list with one vector element") if (!is.numeric(unlist(censor.states))) stop("censor.states should be all numeric") states.index <- c(1, length(unlist(censor.states))+1) } else { if (!is.list(censor.states)) stop("censor.states should be a list") if (length(censor.states) != ncens) stop("expected ", ncens, " elements in censor.states list, found ", length(censor.states)) states.index <- cumsum(c(0, lapply(censor.states, length))) + 1 } censor.states <- unlist(censor.states) } } if (ncens==0) censor <- censor.states <- states.index <- NULL ## Censoring information to be passed to C list(ncens = ncens, # number of censoring states censor = censor, # vector of their labels in the data states = censor.states, # possible true states that the censoring represents index = states.index # index into censor.states for the start of each true-state set, including an extra length(censor.states)+1 ) } ### Transform set of sets of probs {prs} to {log(prs/pr1)} msm.mnlogit.transform <- function(pars, plabs, states){ res <- pars if (any(plabs=="p")) { whichst <- match(states[plabs == "p"], unique(states[plabs == "p"])) for (i in unique(whichst)) # recalculate baseline prob if necessary, e.g. if constraints applied res[plabs=="pbase"][i] <- 1 - sum(res[plabs=="p"][whichst==i]) res[plabs == "p"] <- log(pars[plabs=="p"] / res[plabs=="pbase"][whichst]) } res } ### Transform set of sets of murs = {log(prs/pr1)} to probs {prs} ### ie psum = sum(exp(mus)), pr1 = 1 / (1 + psum), prs = exp(mus) / (1 + psum) msm.mninvlogit.transform <- function(pars, plabs, states){ res <- pars if (any(plabs=="p")) { whichst <- match(states[plabs=="p"], unique(states[plabs=="p"])) if (is.matrix(pars)) {# will be used when applying covariates for (i in unique(whichst)) { psum <- colSums(exp(pars[which(plabs=="p")[whichst==i],,drop=FALSE])) res[which(plabs=="pbase")[i],] <- 1 / (1 + psum) res[which(plabs=="p")[whichst==i],] <- exp(pars[plabs=="p",,drop=FALSE][whichst==i,]) / rep(1 + psum, each=sum(whichst==i)) } } else { psum <- tapply(exp(pars[plabs=="p"]), states[plabs=="p"], sum) res[plabs=="pbase"][unique(states[plabs=="p"])] <- 1 / (1 + psum) # don't transform pbase if no p's for this state, i.e. if no/perfect misclassification res[plabs=="p"] <- exp(pars[plabs=="p"]) / (1 + psum[whichst]) } } res } ## transform parameters from natural scale to real-line optimisation scale msm.transform <- function(pars, hmodel, ranges){ labs <- names(pars) pars <- glogit(pars, ranges[,"lower"], ranges[,"upper"]) hpinds <- which(!(labs %in% c("qbase","qcov","hcov","initpbase","initp","initp0","initpcov"))) hpars <- pars[hpinds] hpars <- msm.mnlogit.transform(hpars, hmodel$plabs, hmodel$parstate) pars[hpinds] <- hpars pars[labs=="initp"] <- log(pars[labs=="initp"] / pars[labs=="initpbase"]) pars } ## transform parameters from real-line optimisation scale to natural scale msm.inv.transform <- function(pars, hmodel, ranges){ labs <- names(pars) pars <- gexpit(pars, ranges[,"lower"], ranges[,"upper"]) hpinds <- which(!(labs %in% c("qbase","qcov","hcov","initp","initp0","initpcov"))) hpars <- pars[hpinds] hpars <- msm.mninvlogit.transform(hpars, hmodel$plabs, hmodel$parstate) pars[hpinds] <- hpars ep <- exp(pars[labs=="initp"]) pars[labs=="initp"] <- ep / (1 + sum(ep)) pars[labs=="initpbase"] <- 1 / (1 + sum(ep)) pars } ## Collect all model parameters together ready for optimisation ## Handle parameters fixed at initial values or constrained to equal other parameters msm.form.params <- function(qmodel, qcmodel, emodel, hmodel, fixedpars) { ## Transition intensities ni <- qmodel$npars ## Covariates on transition intensities nc <- qcmodel$npars ## HMM response parameters nh <- sum(hmodel$npars) ## Covariates on HMM response distribution nhc <- sum(hmodel$ncoveffs) ## Initial state occupancy probabilities in HMM nip <- hmodel$nipars ## Covariates on initial state occupancy probabilities. nipc <- hmodel$nicoveffs npars <- ni + nc + nh + nhc + nip + nipc inits <- as.numeric(c(qmodel$inits, qcmodel$inits, hmodel$pars, unlist(hmodel$coveffect))) plabs <- c(rep("qbase",ni), rep("qcov", nc), hmodel$plabs, rep("hcov", nhc)) if (nip > 0) { inits <- c(inits, hmodel$initprobs) initplabs <- c("initpbase", rep("initp",nip-1)) initplabs[hmodel$initprobs==0] <- "initp0" # those initialised to zero will be fixed at zero plabs <- c(plabs, initplabs) if (nipc > 0) { inits <- c(inits, unlist(hmodel$icoveffect)) plabs <- c(plabs, rep("initpcov",nipc)) } } ## store indicator for which parameters are HMM location parameters (not HMM cov effects or initial state probs) hmmpars <- which(!(plabs %in% c("qbase","qcov","hcov","initpbase","initp","initp0","initpcov"))) hmmparscov <- which(!(plabs %in% c("qbase","qcov","initpbase","initp","initp0","initpcov"))) names(inits) <- plabs ranges <- .msm.PARRANGES[plabs,,drop=FALSE] if (!is.null(hmodel$ranges)) ranges[hmmparscov,] <- hmodel$ranges inits <- msm.transform(inits, hmodel, ranges) ## Form constraint vector for complete set of parameters ## No constraints allowed on initprobs and their covs for the moment constr <- c(qmodel$constr, if(is.null(qcmodel$constr)) NULL else (ni + abs(qcmodel$constr))*sign(qcmodel$constr), ni + nc + hmodel$constr, ni + nc + nh + hmodel$covconstr, ni + nc + nh + nhc + seq(length=nip), ni + nc + nh + nhc + nip + seq(length=nipc)) constr <- match(abs(constr), unique(abs(constr)))*sign(constr) ## parameters which are always fixed and not included in user-supplied fixedpars auxpars <- which(plabs %in% .msm.AUXPARS) duppars <- which(duplicated(abs(constr))) realpars <- setdiff(seq(npars), union(auxpars, duppars)) nrealpars <- npars - length(auxpars) - length(duppars) ## if transition-specific covariates, then fixedpars indices generally smaller nshortpars <- nrealpars - sum(qcmodel$cri[!duplicated(qcmodel$constr)]==0) if (is.logical(fixedpars)) fixedpars <- if (fixedpars == TRUE) seq(nshortpars) else numeric() if (any(! (fixedpars %in% seq(length=nshortpars)))) stop ( "Elements of fixedpars should be in 1, ..., ", nshortpars) if (!is.null(qcmodel$cri)) { ## Convert user-supplied fixedpars indexing transition-specific covariates ## to fixedpars indexing transition-common covariates inds <- rep(1, nrealpars) inds[qmodel$ndpars + qcmodel$constr[!duplicated(qcmodel$constr)]] <- qcmodel$cri[!duplicated(qcmodel$constr)] inds[inds==1] <- seq(length=nshortpars) fixedpars <- match(fixedpars, inds) ## fix covariate effects not included in model to zero fixedpars <- sort(c(fixedpars, which(inds==0))) } notfixed <- realpars[setdiff(seq_along(realpars),fixedpars)] fixedpars <- sort(c(realpars[fixedpars], auxpars)) # change fixedpars to index unconstrained pars allinits <- inits optpars <- intersect(notfixed, which(!duplicated(abs(constr)))) inits <- inits[optpars] fixed <- (length(fixedpars) + length(duppars) == npars) # TRUE if all parameters are fixed, then no optimisation needed, just evaluate likelihood names(allinits) <- plabs; names(fixedpars) <- plabs[fixedpars]; names(plabs) <- NULL paramdata <- list(inits=inits, plabs=plabs, allinits=allinits, hmmpars=hmmpars, fixed=fixed, fixedpars=fixedpars, optpars=optpars, auxpars=auxpars, constr=constr, npars=npars, duppars=duppars, nfix=length(fixedpars), nopt=length(optpars), ndup=length(duppars), ranges=ranges) paramdata } ## Unfix all fixed parameters in a paramdata object p (as ## returned by msm.form.params). Used for calculating deriv / ## information over all parameters for models with fixed parameters. ## Don't unfix auxiliary pars such as binomial denominators ## Don't unconstrain constraints msm.unfixallparams <- function(p) { npars <- length(p$allinits) p$fixed <- FALSE p$optpars <- setdiff(1:npars, union(p$auxpars,p$duppars)) p$fixedpars <- p$auxpars p$nopt <- length(p$optpars) p$nfix <- npars - length(p$optpars) p$inits <- p$allinits[p$optpars] p } msm.rep.constraints <- function(pars, # transformed pars paramdata, hmodel){ plabs <- names(pars) p <- paramdata ## Handle constraints on misclassification probs / HMM cat probs separately ## This is fiddly. First replicate within states, on log(pr/pbase) scale if (any(hmodel$plabs=="p")) { for (i in 1:hmodel$nstates){ inds <- (hmodel$parstate==i & hmodel$plabs=="p") hpc <- hmodel$constr[inds] pars[p$hmmpars][inds] <- pars[p$hmmpars][inds][match(hpc, unique(hpc))] } } ## ...then replicate them between states, on pr scale, so that constraint applies ## to pr not log(pr/pbase). After, transform back pars[p$hmmpars] <- msm.mninvlogit.transform(pars[p$hmmpars], hmodel$plabs, hmodel$parstate) plabs <- plabs[!duplicated(abs(p$constr))][abs(p$constr)] pars <- pars[!duplicated(abs(p$constr))][abs(p$constr)]*sign(p$constr) pars[p$hmmpars] <- msm.mnlogit.transform(pars[p$hmmpars], hmodel$plabs, hmodel$parstate) names(pars) <- plabs pars } ## Apply covariates to transition intensities. Parameters enter this ## function already log transformed and replicated, and exit on ## natural scale. msm.add.qcovs <- function(qmodel, pars, mm){ labs <- names(pars) beta <- rbind(pars[labs=="qbase"], matrix(pars[labs=="qcov"], ncol=qmodel$npars, byrow=TRUE)) qvec <- exp(mm %*% beta) imat <- t(qmodel$imatrix); row <- col(imat)[imat==1]; col <- row(imat)[imat==1] qmat <- array(0, dim=c(qmodel$nstates, qmodel$nstates, nrow(mm))) for (i in 1:qmodel$npars) { qmat[row[i],col[i],] <- qvec[,i] } for (i in 1:qmodel$nstates) ## qmat[i,i,] <- -apply(qmat[i,,,drop=FALSE], 3, sum) qmat[i,i,] <- -colSums(qmat[i,,,drop=FALSE], , 2) qmat } ## Derivatives of intensity matrix Q wrt unique log q and beta, after ## applying constraints. By observation with covariates applied. ## e.g. qmodel$constr 1 1 2, qcmodel$constr 1 -1 2 3 3 -3 ## returns derivs w.r.t pars named p1 p2 p3 p4 p5 ## i.e. with baseline q on the log scale ## qo = exp(p1 + p3x1 + p5x2) ## q1 = exp(p1 + -p3x1 + p5x2) ## q2 = exp(p2 + p4x1 - p5x2) msm.form.dq <- function(qmodel, qcmodel, pars, paramdata, mm){ labs <- names(pars) q0 <- pars[labs=="qbase"] beta <- rbind(q0, matrix(pars[labs=="qcov"], ncol=qmodel$npars, byrow=TRUE)) qvec <- exp(mm %*% beta) covs <- mm[,-1,drop=FALSE] qrvec <- exp(covs %*% beta[-1,,drop=FALSE]) nopt <- qmodel$ndpars + qcmodel$ndpars # after constraint but before omitting fixed dqvec <- array(pars[labs=="qbase"], dim=c(nrow(mm), qmodel$npars, nopt)) for (i in seq_len(qmodel$npars)) { ind <- rep(0, qmodel$ndpars); ind[qmodel$constr[i]] <- 1 cind <- 1:qmodel$ndpars # dqvec[,i,cind] = qrvec[,i] * rep(ind, each=nrow(mm)) dqvec[,i,cind] = qrvec[,i] * rep(ind, each=nrow(mm)) * exp(q0[i]) if (qcmodel$npars > 0) for (k in 1:qcmodel$ncovs) { con <- qcmodel$constr[(k-1)*qmodel$npars + 1:qmodel$npars] ucon <- match(abs(con), unique(abs(con))) ind <- rep(0, max(ucon)); ind[ucon[i]] <- sign(con[i]) cind <- max(cind) + unique(ucon) dqvec[,i,cind] <- covs[,k] * qvec[,i] * rep(ind, each=nrow(mm)) } } dqmat <- array(0, dim=c(qmodel$nstates, qmodel$nstates, nopt, nrow(mm))) imat <- t(qmodel$imatrix); row <- col(imat)[imat==1]; col <- row(imat)[imat==1] for (i in 1:qmodel$npars) dqmat[row[i],col[i],,] <- t(dqvec[,i,]) for (i in 1:qmodel$nstates) ## dqmat[i,i,,] <- -apply(dqmat[i,,,,drop=FALSE], c(3,4), sum) dqmat[i,i,,] <- -colSums(dqmat[i,,,,drop=FALSE], , 2) p <- paramdata # leave fixed parameters out fixed <- p$fixedpars[p$plabs[p$fixedpars] %in% c("qbase","qcov")] con <- abs(p$constr[p$plabs %in% c("qbase","qcov")]) ## FIXME if (any(fixed)) dqmat <- dqmat[,,-con[fixed],,drop=FALSE] dqmat } ## Apply covariates to HMM location parameters ## Parameters enter transformed, and exit on natural scale msm.add.hmmcovs <- function(hmodel, pars, mml){ labs <- names(pars) hpinds <- which(!(labs %in% c("qbase","qcov","hcov","initpbase","initp","initp0","initpcov"))) n <- nrow(mml[[1]]) hpars <- matrix(rep(pars[hpinds], n), ncol=n, dimnames=list(labs[hpinds], NULL)) ito <- 0 for (i in which(hmodel$ncovs > 0)) { mm <- mml[[hmodel$parstate[i]]] ## TODO is this cleaner with hmodel$coveffstate ? ## TODO is this correct for misc covs: two matrices ifrom <- ito + 1; ito <- ito + hmodel$ncovs[i] beta <- pars[names(pars)=="hcov"][ifrom:ito] hpars[i,] <- hpars[i,] + mm[,-1,drop=FALSE] %*% beta } for (i in seq_along(hpinds)){ hpars[i,] <- gexpit(hpars[i,], hmodel$ranges[i,"lower"], hmodel$ranges[i,"upper"]) } hpars <- msm.mninvlogit.transform(hpars, hmodel$plabs, hmodel$parstate) hpars } ### Derivatives of HMM pars w.r.t HMM baseline pars (on transformed, ### e.g. log, scale) and covariate effects ## Account for parameter constraints, e.g. ## hmodel$constr 1 2 3 2 4, hmodel$covconstr 1 2 1 3 ## mu0 = g(p1 + p5x1 + p6x2); g is id for mean, g'(p)=1, or exp for sigma ## sd0 = g(p2) ## mu1 = g(p3 + p5x1 + p7x2) ## sd1 = g(p2) ## id1 = g(p4) ## want deriv wrt p1,p2,...,p7 msm.form.dh <- function(hmodel, pars, # before adding covariates, and on transformed scale newpars, # after adding covariates, and on natural scale paramdata, mml){ labs <- names(pars) hpinds <- which(!(labs %in% c("qbase","qcov","hcov","initpbase","initp","initp0","initpcov"))) # baseline HMM parameters n <- nrow(mml[[1]]) hpars <- matrix(rep(pars[hpinds], n), ncol=n, dimnames=list(labs[hpinds], NULL)) nh <- sum(hmodel$npars) nopt <- length(unique(hmodel$constr)) + length(unique(hmodel$covconstr)) # TODO store in hmodel dh <- array(0, dim=c(nh, nopt, n)) for (i in 1:nh){ ind <- rep(0, length(unique(hmodel$constr))) ind[hmodel$constr[i]] <- 1 cind <- 1:length(unique(hmodel$constr)) if (labs[hpinds][i] != "p") { a <- hmodel$ranges[i,"lower"]; b <- hmodel$ranges[i,"upper"] gdash <- dgexpit(glogit(newpars[i,], a, b), a, b) dh[i,cind,] <- rep(ind, n)*rep(gdash, each=length(cind)) if (hmodel$ncovs[i] > 0) { mm <- mml[[hmodel$parstate[i]]][,-1,drop=FALSE] con <- hmodel$covconstr[hmodel$coveffstate == hmodel$parstate[i]] cind <- max(cind) + unique(con) dh[i,cind,] <- t(mm) * rep(gdash, each=length(cind)) } } } dh <- msm.dmninvlogit(hmodel, hpars, mml, pars[names(pars)=="hcov"], dh) p <- paramdata # leave fixed parameters out dhinds <- which(!(labs %in% c("qbase","qcov","initpbase","initp","initp0","initpcov"))) fixed <- intersect(p$fixedpars, dhinds) # index into full par vec fixed <- match(fixed, setdiff(dhinds, p$duppars)) # index into constrained hmm par vec if (any(fixed)) dh <- dh[,-fixed,,drop=FALSE] dh } ### Derivatives of outcome probabilities w.r.t baseline log odds and covariate effects ### in a HMM categorical outcome distribution ### Constraints on probabilities not supported, seems too fiddly. ### Could generalize for use in est.initprobs, if ever support derivatives for that ### log(p_r/pbase) = lp_r + beta_r ' x ### p_r / pbase = exp(lp_r + beta_r'x) ### (p1 +...+ pR) / pbase = 1/pbase = sum_allR(exp()), so ### pbase = 1/sum_allR(exp()) ### p_r = exp(lp_r + beta_r'x) / sum_all(exp(lp_s + beta_s'x)), where pars 0 for s=pbase ### d/dlp_s pbase = -exp(lp_s + beta_s'x)/ (sum_all())^2 ### d/dbeta_sk pbase = (-x_sk * exp(lp_s + beta_s'x)/ (sum_all())^2 ### for r!=s, d/dlp_s p_r = exp(lp_r + beta_r'x) * -exp(lp_s + beta_s'x)/ (sum_all())^2 ### for r=s, d/dlp_s p_r = exp(lp_r + beta_r'x) / sum_all() + ### exp(lp_r + beta_r'x) * -exp(lp_r + beta_r'x)/ (sum_all())^2 ### for r!=s, d/dbeta_sk p_r = exp(lp_r + beta_r'x) * (-x_sk * exp(lp_s + beta_s'x)/ (sum_all())^2 ### for r=s, d/dbeta_sk p_r = x_sk exp(lp_r + beta_r'x) / sum_all() + ### exp(lp_r + beta_r'x) * (-x_sk * exp(lp_r + beta_r'x)/ (sum_all())^2 ### if no covs: p_r = exp(lp_r) / sum_all(exp(lp_s)). lp_r = log(p_r/pbase) ### d/dlp_s p_r = ### for r!=s, exp(lp_r) * (-exp(lp_s)/ (sum_all())^2 ### for r=s, d/dlp_s p_r = exp(lp_r) / sum_all() - exp(lp_r)^2 / (sum_all())^2 msm.dmninvlogit <- function(hmodel, pars, mml, hcov, dh){ plabs <- hmodel$plabs states <- hmodel$parstate n <- nrow(mml[[1]]) nh <- sum(hmodel$npars) if (any(plabs=="p")) { whichst <- match(states[plabs=="p"], unique(states[plabs=="p"])) for (i in unique(whichst)) { labsi <- plabs[states==i] ppars <- which(labsi %in% c("p","pbase","p0")) lp <- matrix(pars[states==i ,1][ppars], nrow=n, ncol=length(ppars), byrow=TRUE, dimnames=list(NULL,labsi[ppars])) ncovs <- hmodel$ncovs[states==i][ppars] beta <- hcov[hmodel$coveffstate==i] X <- mml[[states[i]]][,-1,drop=FALSE] ito <- 0 for (j in which(ncovs > 0)){ ifrom <- ito + 1; ito <- ito + ncovs[j] betaj <- beta[ifrom:ito] lp[,j] <- lp[,j] + X %*% betaj } elp <- lp elp[,labsi[ppars]=="p"] <- exp(elp[,labsi[ppars]=="p"]) psum <- 1 + rowSums(elp[,labsi[ppars]=="p",drop=FALSE]) pil <- which(states==i & plabs=="p") pis <- which(colnames(elp) == "p") for (r in seq_along(pil)){ ito <- 0 for (s in seq_along(pil)){ dh[pil[r],pil[s],] <- if (r == s) elp[,pis[r]] / psum * (1 - elp[,pis[r]] / psum) else - elp[,pis[r]] * elp[,pis[s]] / psum^2 if (ncovs[pis[s]] > 0){ ifrom <- ito + 1; ito <- ito + ncovs[pis[s]] bil <- nh + which(hmodel$coveffstate==i)[ifrom:ito] for (k in seq_along(bil)) dh[pil[r],bil[k],] <- if (r == s) X[,k] * elp[,pis[r]] / psum * (1 - elp[,pis[r]] / psum) else - X[,k] * elp[,pis[r]] * elp[,pis[s]] / psum^2 } } } pib <- which(states==i & plabs=="pbase") ito <- 0 for (s in seq_along(pil)){ dh[pib,pil[s],] <- - elp[,pis[s]] / psum^2 if (ncovs[pis[s]] > 0){ ifrom <- ito + 1; ito <- ito + ncovs[pis[s]] bil <- nh + which(hmodel$coveffstate==i)[ifrom:ito] for (k in seq_along(bil)) dh[pib,bil[k],] <- - X[,k] * elp[,pis[s]] / psum^2 } } } } dh } msm.initprobs2mat <- function(hmodel, pars, mm, mf){ npts <- attr(mf, "npts") ## Convert vector initial state occupancy probs to matrix by patient if (!hmodel$hidden) return(0) if (hmodel$est.initprobs) { initp <- pars[names(pars) %in% c("initpbase","initp","initp0")] initp <- matrix(rep(initp, each=npts), nrow=npts, dimnames=list(NULL, names(pars)[names(pars) %in% c("initpbase","initp","initp0")])) ## Multiply baselines (entering on mnlogit scale) by current covariate ## effects, giving matrix of patient-specific initprobs est <- which(colnames(initp)=="initp") ip <- initp[,est,drop=FALSE] if (hmodel$nicoveffs > 0) { ## cov effs ordered by states (excluding state 1) within covariates coveffs <- pars[names(pars)=="initpcov"] coveffs <- matrix(coveffs, nrow=max(hmodel$nicovs), byrow=TRUE) ip <- ip + as.matrix(mm[,-1,drop=FALSE]) %*% coveffs } initp[,est] <- exp(ip) / (1 + rowSums(exp(ip))) initp[,"initpbase"] <- 1 / (1 + rowSums(exp(ip))) } else if (!is.matrix(hmodel$initprobs)) initp <- matrix(rep(hmodel$initprobs,each=npts),nrow=npts) else initp <- hmodel$initprobs initp } ## Entry point to C code for calculating the likelihood and related quantities Ccall.msm <- function(params, do.what="lik", msmdata, qmodel, qcmodel, cmodel, hmodel, paramdata) { p <- paramdata pars <- p$allinits pars[p$optpars] <- params pars <- msm.rep.constraints(pars, paramdata, hmodel) agg <- if (!hmodel$hidden && cmodel$ncens==0 && do.what %in% c("lik","deriv","info")) TRUE else FALSE # data as aggregate transition counts, as opposed to individual observations ## Add covariates to hpars and q here. Inverse-transformed to natural scale on exit mm.cov <- if (agg) msmdata$mm.cov.agg else msmdata$mm.cov Q <- msm.add.qcovs(qmodel, pars, mm.cov) DQ <- if (do.what %in% c("deriv","info","deriv.subj","dpmat")) msm.form.dq(qmodel, qcmodel, pars, p, mm.cov) else NULL H <- if (hmodel$hidden) msm.add.hmmcovs(hmodel, pars, msmdata$mm.hcov) else NULL DH <- if (hmodel$hidden && (do.what %in% c("deriv","info","deriv.subj"))) msm.form.dh(hmodel, pars, H, paramdata, msmdata$mm.hcov) else NULL initprobs <- msm.initprobs2mat(hmodel, pars, msmdata$mm.icov, msmdata$mf) mf <- msmdata$mf; mf.agg <- msmdata$mf.agg ## In R, ordinal variables indexed from 1. In C, these are indexed from 0. mf.agg$"(fromstate)" <- mf.agg$"(fromstate)" - 1 mf.agg$"(tostate)" <- mf.agg$"(tostate)" - 1 firstobs <- c(which(!duplicated(model.extract(mf, "subject"))), nrow(mf)+1) - 1 mf$"(subject)" <- match(mf$"(subject)", unique(mf$"(subject)")) ntrans <- sum(duplicated(model.extract(mf, "subject"))) hmodel$models <- hmodel$models - 1 nagg <- if(is.null(mf.agg)) 0 else nrow(mf.agg) mf$"(pcomb)" <- mf$"(pcomb)" - 1 npcombs <- length(unique(na.omit(model.extract(mf, "pcomb")))) qmodel$nopt <- if (is.null(DQ)) 0 else dim(DQ)[3] hmodel$nopt <- if (is.null(DH)) 0 else dim(DH)[2] nopt <- qmodel$nopt + hmodel$nopt ## coerce types here to avoid PROTECT faff with doing this in C mfac <- list("(fromstate)" = as.integer(mf.agg$"(fromstate)"), "(tostate)" = as.integer(mf.agg$"(tostate)"), "(timelag)" = as.double(mf.agg$"(timelag)"), "(nocc)" = as.integer(mf.agg$"(nocc)"), "(noccsum)" = as.integer(mf.agg$"(noccsum)"), "(whicha)" = as.integer(mf.agg$"(whicha)"), "(obstype)" = as.integer(mf.agg$"(obstype)")) mfc <- list("(subject)" = as.integer(mf$"(subject)"), "(time)" = as.double(mf$"(time)"), ## supply matrix outcomes to C by row so multivariate outcomes are together ## Also, state data for misclassification HMMs are indexed from 1 not 0 in C "(state)" = as.double(t(mf$"(state)")), "(obstype)" = as.integer(mf$"(obstype)"), "(obstrue)" = as.integer(mf$"(obstrue)"), "(pcomb)" = as.integer(mf$"(pcomb)")) auxdata <- list(nagg=as.integer(nagg),n=as.integer(nrow(mf)),npts=as.integer(attr(mf,"npts")), ntrans=as.integer(ntrans), npcombs=as.integer(npcombs), nout = as.integer(if(is.null(ncol(mf$"(state)"))) 1 else ncol(mf$"(state)")), nliks=as.integer(get("nliks",msm.globals)),firstobs=as.integer(firstobs)) qmodel <- list(nstates=as.integer(qmodel$nstates), npars=as.integer(qmodel$npars), nopt=as.integer(qmodel$nopt), iso=as.integer(qmodel$iso), perm=as.integer(qmodel$perm), qperm=as.integer(qmodel$qperm), expm=as.integer(qmodel$expm)) cmodel <- list(ncens=as.integer(cmodel$ncens), censor=as.integer(cmodel$censor), states=as.integer(cmodel$states), index=as.integer(cmodel$index - 1)) hmodel <- list(hidden=as.integer(hmodel$hidden), mv=as.integer(hmodel$mv), models=as.integer(hmodel$models), totpars=as.integer(hmodel$totpars), firstpar=as.integer(hmodel$firstpar), npars=as.integer(hmodel$npars), nopt=as.integer(hmodel$nopt), ematrix=as.integer(hmodel$ematrix)) pars <- list(Q=as.double(Q),DQ=as.double(DQ),H=as.double(H),DH=as.double(DH), initprobs=as.double(initprobs),nopt=as.integer(nopt)) .Call("msmCEntry", as.integer(match(do.what, .msm.CTASKS) - 1), mfac, mfc, auxdata, qmodel, cmodel, hmodel, pars, PACKAGE="msm") } lik.msm <- function(params, ...) { ## number of likelihood evaluations so far including this one ## used for error message for iffy initial values in HMMs assign("nliks", get("nliks",msm.globals) + 1, envir=msm.globals) Ccall.msm(params, do.what="lik", ...) } deriv.msm <- function(params, ...) { Ccall.msm(params, do.what="deriv", ...) } information.msm <- function(params, ...) { Ccall.msm(params, do.what="info", ...) } ## Convert vector of MLEs into matrices and append them to the model object msm.form.output <- function(x, whichp) { model <- if (whichp=="intens") x$qmodel else x$emodel cmodel <- if (whichp=="intens") x$qcmodel else x$ecmodel p <- x$paramdata Matrices <- MatricesSE <- MatricesL <- MatricesU <- MatricesFixed <- list() basename <- if (whichp=="intens") "logbaseline" else "logitbaseline" fixedpars.logical <- p$constr %in% p$constr[p$fixedpars] for (i in 0:cmodel$ncovs) { matrixname <- if (i==0) basename else cmodel$covlabels[i] # name of the current output matrix. mat <- t(model$imatrix) # state matrices filled by row, while R fills them by column. if (whichp=="intens") parinds <- if (i==0) which(p$plabs=="qbase") else which(p$plabs=="qcov")[(i-1)*model$npars + 1:model$npars] if (whichp=="misc") parinds <- if (i==0) which(p$plabs=="p") else which(p$plabs=="hcov")[i + cmodel$ncovs*(1:model$npars - 1)] if (any(parinds)) mat[t(model$imatrix)==1] <- p$params[parinds] else mat[mat==1] <- Inf ## if no parinds are "p", then there are off-diag 1s in ematrix mat <- t(mat) dimnames(mat) <- dimnames(model$imatrix) fixed <- array(FALSE, dim=dim(model$imatrix)) if (p$foundse && !p$fixed){ intenscov <- p$covmat[parinds, parinds] intensse <- sqrt(diag(as.matrix(intenscov))) semat <- lmat <- umat <- t(model$imatrix) if (any(parinds)){ semat[t(model$imatrix)==1] <- intensse lmat[t(model$imatrix)==1] <- p$ci[parinds,1] umat[t(model$imatrix)==1] <- p$ci[parinds,2] fixed[t(model$imatrix)==1] <- fixedpars.logical[parinds] } else semat[semat==1] <- lmat[lmat==1] <- umat[umat==1] <- Inf semat <- t(semat); lmat <- t(lmat); umat <- t(umat); fixed <- t(fixed) diag(semat) <- diag(lmat) <- diag(umat) <- 0 for (i in 1:nrow(fixed)){ foff <- fixed[i,-i][model$imatrix[i,-i]==1] fixed[i,i] <- (length(foff)>1) && all(foff) } if (whichp=="misc") fixed[which(x$hmodel$model==match("identity", .msm.HMODELS)),] <- TRUE dimnames(semat) <- dimnames(mat) } else { semat <- lmat <- umat <- NULL } Matrices[[matrixname]] <- mat MatricesSE[[matrixname]] <- semat MatricesL[[matrixname]] <- lmat MatricesU[[matrixname]] <- umat MatricesFixed[[matrixname]] <- fixed } nam <- if(whichp=="intens") "Qmatrices" else "Ematrices" x[[nam]] <- Matrices; x[[paste0(nam, "SE")]] <- MatricesSE; x[[paste0(nam, "L")]] <- MatricesL x[[paste0(nam, "U")]] <- MatricesU; x[[paste0(nam, "Fixed")]] <- MatricesFixed x } ## Format hidden Markov model estimates and CIs msm.form.houtput <- function(hmodel, p, msmdata) { hmodel$pars <- p$estimates.t[!(p$plabs %in% c("qbase","qcov","hcov","initp","initpbase","initp0","initpcov"))] hmodel$coveffect <- p$estimates.t[p$plabs == "hcov"] hmodel$fitted <- !p$fixed hmodel$foundse <- p$foundse if (hmodel$nip > 0) { iplabs <- p$plabs[p$plabs %in% c("initp","initp0")] whichst <- which(iplabs == "initp") + 1 # init probs for which states have covs on them (not the zero probs) if (hmodel$foundse) { hmodel$initprobs <- rbind(cbind(p$estimates.t[p$plabs %in% c("initpbase","initp","initp0")], p$ci[p$plabs %in% c("initpbase","initp","initp0"),,drop=FALSE])) rownames(hmodel$initprobs) <- paste("State",1:hmodel$nstates) colnames(hmodel$initprobs) <- c("Estimate", "LCL", "UCL") if (any(hmodel$nicovs > 0)) { covnames <- names(hmodel$icoveffect) hmodel$icoveffect <- cbind(p$estimates.t[p$plabs == "initpcov"], p$ci[p$plabs == "initpcov",,drop=FALSE]) rownames(hmodel$icoveffect) <- paste(covnames, paste("State",whichst), sep=", ") colnames(hmodel$icoveffect) <- c("Estimate", "LCL", "UCL") } } else { hmodel$initprobs <- c(1 - sum(p$estimates.t[p$plabs == "initp"]), p$estimates.t[p$plabs %in% c("initp","initp0")]) names(hmodel$initprobs) <- paste("State", 1:hmodel$nstates) if (any(hmodel$nicovs > 0)) { covnames <- names(hmodel$icoveffect) hmodel$icoveffect <- p$estimates.t[p$plabs == "initpcov"] # names(hmodel$icoveffect) <- paste(covnames, paste("State",2:hmodel$nstates), sep=", ") names(hmodel$icoveffect) <- paste(covnames, paste("State",whichst), sep=", ") } } } hmodel$initpmat <- msm.initprobs2mat(hmodel, p$estimates, msmdata$mm.icov, msmdata$mf) if (hmodel$foundse) { hmodel$ci <- p$ci[!(p$plabs %in% c("qbase","qcov","hcov","initpbase","initp","initp0","initpcov")), , drop=FALSE] hmodel$covci <- p$ci[p$plabs %in% c("hcov"), ] } names(hmodel$pars) <- hmodel$plabs hmodel } ## Table of 'transitions': previous state versus current state statetable.msm <- function(state, subject, data=NULL) { if(!is.null(data)) { data <- as.data.frame(data) state <- eval(substitute(state), data, parent.frame()) } n <- length(state) if (!is.null(data)) subject <- if(missing(subject)) rep(1,n) else eval(substitute(subject), data, parent.frame()) subject <- match(subject, unique(subject)) prevsubj <- c(NA, subject[1:(n-1)]) previous <- c(NA, state[1:(n-1)]) previous[prevsubj!=subject] <- NA ntrans <- table(previous, state) # or simpler as # ntrans <- table(state[duplicated(subject,fromLast=TRUE)], state[duplicated(subject)]) names(dimnames(ntrans)) <- c("from", "to") ntrans } ## Calculate crude initial values for transition intensities by assuming observations represent the exact transition times crudeinits.msm <- function(formula, subject, qmatrix, data=NULL, censor=NULL, censor.states=NULL) { cens <- msm.form.cmodel(censor, censor.states, qmatrix) mf <- model.frame(formula, data=data, na.action=NULL) state <- mf[,1] time <- mf[,2] n <- length(state) if (missing(subject)) subject <- rep(1, n) else if (!is.null(data)) subject <- eval(substitute(subject), as.list(data), parent.frame()) if (is.null(subject)) subject <- rep(1, n) notna <- !is.na(subject) & !is.na(time) & !is.na(state) subject <- subject[notna]; time <- time[notna]; state <- state[notna] msm.check.qmatrix(qmatrix) msm.check.state(nrow(qmatrix), state, cens$censor, list(hidden=FALSE)) msm.check.times(time, subject, state) nocens <- (! (state %in% cens$censor) ) state <- state[nocens]; subject <- subject[nocens]; time <- time[nocens] n <- length(state) lastsubj <- !duplicated(subject, fromLast=TRUE) timecontrib <- ifelse(lastsubj, NA, c(time[2:n], 0) - time) tottime <- tapply(timecontrib[!lastsubj], state[!lastsubj], sum) # total time spent in each state ntrans <- statetable.msm(state, subject, data=NULL) # table of transitions nst <- nrow(qmatrix) estmat <- matrix(0, nst, nst) rownames(estmat) <- colnames(estmat) <- paste(1:nst) tab <- sweep(ntrans, 1, tottime, "/") for (i in 1:nst) # Include zero rows for states for which there were no transitions for (j in 1:nst) if ((paste(i) %in% rownames(tab)) && (paste(j) %in% colnames(tab))) estmat[paste(i), paste(j)] <- tab[paste(i),paste(j)] estmat[qmatrix == 0] <- 0 # estmat <- msm.fixdiag.qmatrix(estmat) rownames(estmat) <- rownames(qmatrix) colnames(estmat) <- colnames(qmatrix) estmat } ### Construct a model with time-dependent transition intensities. ### Form a new dataset with censored states and extra covariate, and ### form a new censor model, given change times in tcut msm.pci <- function(tcut, mf, qmodel, cmodel, covariates) { if (!is.numeric(tcut)) stop("Expected \"tcut\" to be a numeric vector of change points") ## Make new dataset with censored observations at time cut points ntcut <- length(tcut) npts <- length(unique(model.extract(mf, "subject"))) nextra <- ntcut*npts basenames <- c("(state)","(time)","(subject)","(obstype)","(obstrue)","(obs)","(pci.imp)") covnames <- setdiff(colnames(mf), basenames) extra <- mf[rep(1,nextra),] extra$"(state)" = rep(NA, nextra) extra$"(time)" = rep(tcut, npts) extra$"(subject)" <- rep(unique(model.extract(mf, "subject")), each=ntcut) extra$"(obstype)" = rep(1, nextra) extra$"(obstrue)" = rep(TRUE, nextra) extra$"(obs)" <- NA extra$"(pci.imp)" = 1 extra[, covnames] <- NA mf$"(pci.imp)" <- 0 ## Merge new and old observations new <- rbind(mf, extra) new <- new[order(new$"(subject)", new$"(time)"),] label <- if (cmodel$ncens > 0) max(cmodel$censor)*2 else qmodel$nstates + 1 new$"(state)"[is.na(new$"(state)")] <- label ## Only keep cutpoints within range of each patient's followup mintime <- tapply(mf$"(time)", mf$"(subject)", min)[as.character(unique(mf$"(subject)"))] maxtime <- tapply(mf$"(time)", mf$"(subject)", max)[as.character(unique(mf$"(subject)"))] nobspt <- as.numeric(table(new$"(subject)")[as.character(unique(new$"(subject)"))]) new <- new[new$"(time)" >= rep(mintime, nobspt) & new$"(time)" <= rep(maxtime, nobspt), ] ## Drop imputed observations at times when there was already an observation ## assumes there wasn't already duplicated obs times prevsubj <- c(NA,new$"(subject)"[1:(nrow(new)-1)]); nextsubj <- c(new$"(subject)"[2:nrow(new)], NA) prevtime <- c(NA,new$"(time)"[1:(nrow(new)-1)]); nexttime <- c(new$"(time)"[2:nrow(new)], NA) prevstate <- c(NA,new$"(state)"[1:(nrow(new)-1)]); nextstate <- c(new$"(state)"[2:nrow(new)], NA) new <- new[!((new$"(subject)"==prevsubj & new$"(time)"==prevtime & new$"(state)"==label & prevstate!=label) | (new$"(subject)"==nextsubj & new$"(time)"==nexttime & new$"(state)"==label & nextstate!=label)) ,] ## Carry last value forward for other covariates if (length(covnames) > 0) { eind <- which(is.na(new[,covnames[1]]) & new$"(pci.imp)"==1) while(length(eind) > 0){ new[eind,covnames] <- new[eind - 1, covnames] eind <- which(is.na(new[,covnames[1]])) } } ## Check range of cut points if (any(tcut <= min(mf$"(time)"))) warning("Time cut point", if (sum(tcut <= min(mf$"(time)")) > 1) "s " else " ", paste(tcut[tcut<=min(mf$"(time)")],collapse=","), " less than or equal to minimum observed time of ",min(mf$"(time)")) if (any(tcut >= max(mf$"(time)"))) warning("Time cut point", if (sum(tcut >= max(mf$"(time)")) > 1) "s " else " ", paste(tcut[tcut>=max(mf$"(time)")],collapse=","), " greater than or equal to maximum observed time of ",max(mf$"(time)")) tcut <- tcut[tcut > min(mf$"(time)") & tcut < max(mf$"(time)")] ntcut <- length(tcut) if (ntcut==0) res <- NULL # no cut points in range of data, continue with no time-dependent model else { ## Insert new covariate in data representing time period tcovlabel <- "timeperiod" if (any(covnames=="timeperiod")) stop("Cannot have a covariate called \"timeperiod\" if \"pci\" is supplied") tcov <- factor(cut(new$"(time)", c(-Inf,tcut,Inf), right=FALSE)) levs <- levels(tcov) levels(tcov) <- gsub(" ","", levs) # get rid of spaces in e.g. [10, Inf) levels assign(tcovlabel, tcov) new[,tcovlabel] <- tcov ## Add "+ timeperiod" to the Q covariates formula. current.covs <- if(attr(mf,"ncovs")>0) attr(terms(covariates), "term.labels") else NULL covariates <- reformulate(c(current.covs, tcovlabel)) attr(new, "covnames") <- c(attr(mf, "covnames"), "timeperiod") attr(new, "covnames.q") <- c(attr(mf, "covnames.q"), "timeperiod") attr(new, "ncovs") <- attr(mf, "ncovs") + 1 ## New censoring model cmodel$ncens <- cmodel$ncens + 1 cmodel$censor <- c(cmodel$censor, label) cmodel$states <- c(cmodel$states, 1:qmodel$nstates) cmodel$index <- if (is.null(cmodel$index)) 1 else cmodel$index cmodel$index <- c(cmodel$index, length(cmodel$states) + 1) res <- list(mf=new, covariates=covariates, cmodel=cmodel, tcut=tcut) } res } msm.check.covlist <- function(covlist, qemodel) { check.numnum <- function(str) length(grep("^[0-9]+-[0-9]+$", str)) == length(str) num <- sapply(names(covlist), check.numnum) if (!all(num)) { badnums <- which(!num) plural1 <- if (length(badnums)>1) "s" else ""; plural2 <- if (length(badnums)>1) "e" else ""; badnames <- paste(paste("\"",names(covlist)[badnums],"\"",sep=""), collapse=",") badnums <- paste(badnums, collapse=",") stop("Name", plural1, " ", badnames, " of \"covariates\" formula", plural2, " ", badnums, " not in format \"number-number\"") } for (i in seq(along=covlist)) if (!inherits(covlist[[i]], "formula")) stop("\"covariates\" should be a formula or list of formulae") trans <- sapply(strsplit(names(covlist), "-"), as.numeric) tm <- if(inherits(qemodel,"msmqmodel")) "transition" else "misclassification" qe <- if(inherits(qemodel,"msmqmodel")) "qmatrix" else "ematrix" imat <- qemodel$imatrix for (i in seq(length=ncol(trans))){ if (imat[trans[1,i],trans[2,i]] != 1) stop("covariates on ", names(covlist)[i], " ", tm, " requested, but this is not permitted by the ", qe, ".") } } ## Form indicator matrix for effects that will be fixed to zero when ## "covariates" specified as a list of transition-specific formulae msm.form.cri <- function(covlist, qmodel, mf, mm) { imat <- t(qmodel$imatrix) # order named transitions / misclassifications by row tnames <- paste(col(imat)[imat==1],row(imat)[imat==1],sep="-") covlabs <- colnames(mm)[-1] npars <- qmodel$npars cri <- matrix(0, nrow=npars, ncol=length(covlabs), dimnames = list(tnames, covlabs)) sorti <- function(x) { ## converts, e.g. c("b:a:c","d:f","f:e") to c("a:b:c", "d:f", "e:f") sapply(lapply(strsplit(x, ":"), sort), paste, collapse=":") } for (i in 1:npars) { if (tnames[i] %in% names(covlist)) { covlabsi <- colnames(model.matrix(covlist[[tnames[i]]], data=mf))[-1] cri[i, match(sorti(covlabsi), sorti(covlabs))] <- 1 } } cri } ## adapted from stats:::na.omit.data.frame. ignore handling of ## non-atomic, matrix within df na.omit.msmdata <- function(object, ...) { omit <- na.find.msmdata(object) xx <- object[!omit, , drop = FALSE] if (any(omit > 0L)) { temp <- setNames(seq(omit)[omit], attr(object, "row.names")[omit]) attr(temp, "class") <- "omit" attr(xx, "na.action") <- temp } xx } na.fail.msmdata <- function(object, ...) { omit <- na.find.msmdata(object) if (any(omit)) stop("Missing values or subjects with only one observation in data") else object } na.find.msmdata <- function(object, ...) { subj <- as.character(object[,"(subject)"]) firstobs <- !duplicated(subj) lastobs <- !duplicated(subj, fromLast=TRUE) nm <- names(object) omit <- FALSE for (j in seq(along=object)) { ## Drop all NAs in time, subject as usual if (nm[j] %in% c("(time)", "(subject)")) omit <- omit | is.na(object[[j]]) if (nm[j] == "(state)") { ## For matrix HMM outcomes ("states"), only drop a row if all columns are NA nas <- if (is.matrix(object[[j]])) apply(object[[j]], 1, function(x)all(is.na(x))) else is.na(object[[j]]) omit <- omit | nas } ## Don't drop NAs in obstype at first observation for a subject else if (nm[j]=="(obstype)") omit <- omit | (is.na(object[[j]]) & !firstobs) ## covariates on initial state probs - only drop if NA at initial observation else if (j %in% attr(object, "icovi")) omit <- omit | (is.na(object[[j]]) & firstobs) ## Don't drop NAs in covariates at last observation for a subject ## Note NAs in obstrue should have previously been replaced by zeros in msm.form.obstrue, so could assert for this here. else if (nm[j]!="(obstrue)") omit <- omit | (is.na(object[[j]]) & !lastobs) } ## Drop obs with only one subject remaining after NAs have been omitted nobspt <- table(subj[!omit])[subj] omit <- omit | (nobspt==1) omit } msm.form.mf.agg <- function(x){ mf <- x$data$mf; qmodel <- x$qmodel; hmodel <- x$hmodel; cmodel <- x$cmodel if (!hmodel$hidden && cmodel$ncens==0){ mf.trans <- msm.obs.to.fromto(mf) msm.check.model(mf.trans$"(fromstate)", mf.trans$"(tostate)", mf.trans$"(obs)", mf.trans$"(subject)", mf.trans$"(obstype)", qmodel$qmatrix, cmodel) ## Aggregate over unique from/to/timelag/cov/obstype mf.agg <- msm.aggregate.data(mf.trans) } else mf.agg <- NULL mf.agg } msm.obs.to.fromto <- function(mf) { n <- nrow(mf) subj <- model.extract(mf, "subject") time <- model.extract(mf, "time") state <- model.extract(mf, "state") firstsubj <- !duplicated(subj) lastsubj <- !duplicated(subj, fromLast=TRUE) mf.trans <- mf[!lastsubj,,drop=FALSE] ## retains all covs corresp to the start of the transition names(mf.trans)[names(mf.trans)=="(state)"] <- "(fromstate)" mf.trans$"(tostate)" <- if(is.matrix(state)) state[!firstsubj,,drop=FALSE] else state[!firstsubj] mf.trans$"(obstype)" <- model.extract(mf, "obstype")[!firstsubj] # obstype matched with end of transition mf.trans$"(obs)" <- model.extract(mf, "obs")[!firstsubj] mf.trans$"(timelag)" <- diff(time)[!firstsubj[-1]] ## NOTE not kept constants npts, ncovs, covlabels, covdata, hcovdata, covmeans ## NOTE: orig returned dat$time, dat$obstype.obs of orig length, assume not needed ## NOTE: firstsubj in old only used in msm.aggregate.hmmdata, which is not used mf.trans } ### Aggregate the data by distinct values of time lag, covariate values, from state, to state, observation type ### Result is passed to the C likelihood function (for non-hidden multi-state models) msm.aggregate.data <- function(mf.trans) { n <- nrow(mf.trans) apaste <- do.call("paste", mf.trans[,c("(fromstate)","(tostate)","(timelag)","(obstype)", attr(mf.trans, "covnames"))]) mf.agg <- mf.trans[!duplicated(apaste),] mf.agg <- mf.agg[order(unique(apaste)),] mf.agg$"(nocc)" <- as.numeric(table(apaste)) apaste2 <- mf.agg[,"(timelag)"] if (attr(mf.agg, "ncovs") > 0) apaste2 <- paste(apaste2, do.call("paste", mf.agg[,attr(mf.agg, "covnames"),drop=FALSE])) ## which unique timelag/cov combination each row of aggregated data corresponds to ## lik.c needs this to know when to recalculate the P matrix. mf.agg$"(whicha)" <- match(apaste2, sort(unique(apaste2))) mf.agg <- mf.agg[order(apaste2,mf.agg$"(fromstate)",mf.agg$"(tostate)"),] ## for Fisher information: number of obs over timelag/covs starting in ## fromstate, replicated for all tostates. apaste2 <- paste(mf.agg$"(fromstate)", apaste2) mf.agg$"(noccsum)" <- unname(tapply(mf.agg$"(nocc)", apaste2, sum)[apaste2]) ## NOTE not kept covdata, hcovdata, npts, covlabels, covmeans, nobs, ntrans mf.agg } ### Form indicator for which unique timelag/obstype/cov each observation belongs to ### Used in HMMs/censoring to calculate P matrices efficiently in C msm.form.hmm.agg <- function(mf){ mf.trans <- msm.obs.to.fromto(mf) mf.trans$"(apaste)" <- do.call("paste", mf.trans[,c("(timelag)","(obstype)",attr(mf.trans,"covnames"))]) mf.trans$"(pcomb)" <- match(mf.trans$"(apaste)", unique(mf.trans$"(apaste)")) mf$"(pcomb)" <- NA mf$"(pcomb)"[duplicated(model.extract(mf,"subject"))] <- mf.trans$"(pcomb)" mf$"(pcomb)" } ### FORM DESIGN MATRICES FOR COVARIATE MODELS. msm.form.mm.cov <- function(x){ mm.cov <- model.matrix.wrap(x$covariates, x$data$mf) msm.center.covs(mm.cov, attr(x$data$mf,"covmeans"), x$center) } msm.form.mm.cov.agg <- function(x){ mm.cov.agg <- if (x$hmodel$hidden || (x$cmodel$ncens > 0)) NULL else model.matrix(x$covariates, x$data$mf.agg) msm.center.covs(mm.cov.agg, attr(x$data$mf.agg,"covmeans"), x$center) } msm.form.mm.mcov <- function(x){ mm.mcov <- if (x$emodel$misc) model.matrix.wrap(x$misccovariates, x$data$mf) else NULL msm.center.covs(mm.mcov, attr(x$data$mf,"covmeans"), x$center) } msm.form.mm.hcov <- function(x){ hcov <- x$hcovariates nst <- x$qmodel$nstates if (x$hmodel$hidden) { mm.hcov <- vector(mode="list", length=nst) if (is.null(hcov)) hcov <- rep(list(~1), nst) for (i in seq_len(nst)){ if (is.null(hcov[[i]])) hcov[[i]] <- ~1 mm.hcov[[i]] <- model.matrix.wrap(hcov[[i]], x$data$mf) mm.hcov[[i]] <- msm.center.covs(mm.hcov[[i]], attr(x$data$mf,"covmeans"), x$center) } } else mm.hcov <- NULL mm.hcov } msm.form.mm.icov <- function(x){ if (x$hmodel$hidden) { if (is.null(x$initcovariates)) x$initcovariates <- ~1 mm.icov <- model.matrix.wrap(x$initcovariates, x$data$mf[!duplicated(x$data$mf$"(subject)"),]) } else mm.icov <- NULL msm.center.covs(mm.icov, attr(x$data$mf,"covmeans"), x$center) } model.matrix.wrap <- function(formula, data){ mm <- model.matrix(formula, data) polys <- unlist(attr(mm, "contrasts") == "contr.poly") covlist <- paste(names(polys),collapse=",") if (any(polys)) warning(sprintf("Polynomial factor contrasts (found for covariates \"%s\") not supported in msm output functions. Use treatment contrasts for ordered factors", covlist)) mm } msm.center.covs <- function(covmat, cm, center=TRUE){ if (is.null(covmat)||is.null(cm)) return(covmat) means <- cm[colnames(covmat)] attr(covmat, "means") <- means[-1] if (center) covmat <- sweep(covmat, 2, means) covmat } expand.data <- function(x){ x$data$mf.agg <- msm.form.mf.agg(x) x$data$mm.cov <- msm.form.mm.cov(x) x$data$mm.cov.agg <- msm.form.mm.cov.agg(x) x$data$mm.mcov <- msm.form.mm.mcov(x) x$data$mm.hcov <- msm.form.mm.hcov(x) x$data$mm.icov <- msm.form.mm.icov(x) x$data } model.frame.msm <- function(formula, agg=FALSE, ...){ x <- formula if (agg) x$data$mf.agg else x$data$mf } model.matrix.msm <- function(object, model="intens", state=1, ...){ switch(model, intens=msm.form.mm.cov(object), misc=msm.form.mm.mcov(object), hmm=msm.form.mm.hcov(object)[[state]], init=msm.form.mm.icov(object)) } .onLoad <- function(libname, pkgname) { assign("msm.globals", new.env(), envir=parent.env(environment())) assign("nliks", 0, envir=msm.globals) } msm/R/phase.R0000755000176200001440000002210712456235136012506 0ustar liggesusersmsm.phase2qmodel <- function(qmodel, phase.states, inits, qconstraint, analyticp, use.expm){ if (any(!(phase.states %in% 1:qmodel$nstates))) stop("phase.states should be in 1,...,",qmodel$nstates) markov.states <- setdiff(1:qmodel$nstates, phase.states) nst <- 2*length(phase.states) + length(markov.states) reps <- rep(1, qmodel$nstates) reps[phase.states] <- 2 pars <- rep(1:qmodel$nstates, reps) # index of each new state in old states if (!is.null(inits)){ if (!is.list(inits)) stop("phase.inits should be a list") if (!length(inits)==length(phase.states)) stop(sprintf("phase.inits of length %d, but there are %d phased states", length(inits), length(phase.states))) for (i in seq(along=inits)){ if (!length(inits[[i]])==2) stop(sprintf("phase.inits[[%d]] list of length %d, should be 2", i, length(inits[[i]]))) if (is.null(names(inits[[i]]))) names(inits[[i]]) <- c("trans","exit") if (is.vector(inits[[i]]$trans)) inits[[i]]$trans <- matrix(inits[[i]]$trans, nrow=1) if (is.vector(inits[[i]]$exit)) inits[[i]]$exit <- matrix(inits[[i]]$exit, nrow=1) if (length(inits[[i]]$trans)!=1) stop(sprintf("phase.inits[[%d]]$trans of length %d, should be 1", i, length(inits[[i]]$trans))) if (ncol(inits[[i]]$exit)!=2) stop(sprintf("phase.inits[[%d]]$exit has %d columns, should be 2", i, length(inits[[i]]$exit))) } } ## TODO warn for identical exit rates ## Form new transition intensity matrix qmatrix.new <- matrix(0, nrow=nst, ncol=nst) rn <- rownames(qmodel$qmatrix)[pars]; cn <- colnames(qmodel$qmatrix)[pars] pp <- pars %in% phase.states rn[pp] <- paste(rn[pp], " [P", rep(1:2, length(phase.states)), "]", sep="") cn[pp] <- paste(cn[pp], " [P", rep(1:2, length(phase.states)), "]", sep="") ## also form short state names here (used in viterbi) sn <- pars; sn[pp] <- paste0(sn[pp], rep(c("P1","P2"), length(phase.states))) dimnames(qmatrix.new) <- list(rn, cn) ## Transition rates between non-phased states mpars <- which(pars %in% markov.states) qmatrix.new[mpars,mpars] <- qmodel$qmatrix[markov.states,markov.states,drop=FALSE] ## Phase entry transition rates phase1 <- which(pars%in%phase.states & !duplicated(pars)) qmatrix.new[mpars,phase1] <- qmodel$qmatrix[markov.states,phase.states,drop=FALSE] ## Unsure if we need to keep all of these. TODO document them qaux <- list(phase.states=phase.states, markov.states=markov.states, phase.reps=reps, phase.pars=pars, oldstates=pars, phase.labs=sn, imatrix.orig=qmodel$imatrix, qmatrix.orig=qmodel$qmatrix, pdests=list(), pdests.orig=list(), phase1.ind=numeric(), phase2.ind=numeric()) for (i in seq(along=phase.states)){ ## possible destination states from current phase state in ## original and expanded model respectively dests <- which(qmodel$imatrix[phase.states[i],]==1) dests.new <- which(pars %in% dests & !duplicated(pars)) erates <- qmodel$qmatrix[phase.states[i],dests] if (is.null(inits)) { ## Phase exit transition rates erates1 <- erates*0.8 erates2 <- erates*1.2 } else { if (nrow(inits[[i]]$exit) != length(dests)){ plural <- if (nrow(inits[[i]]$exit) > 1) "s" else "" stop(sprintf("phase.inits[[%d]]$exit has %d row%s, but there are %d exit states from this state", i, nrow(inits[[i]]$exit), plural, length(dests))) } erates1 <- inits[[i]]$exit[,1]; erates2 <- inits[[i]]$exit[,2] } phase1 <- which(pars==phase.states[i])[1] phase2 <- which(pars==phase.states[i])[2] qmatrix.new[phase1,dests.new] <- erates1 qmatrix.new[phase2,dests.new] <- erates2 ## default to 0.5 for p2 if (is.null(inits)) { trans <- 0.5/sum(erates1) } else trans <- inits[[i]]$trans qmatrix.new[phase1,phase2] <- trans qaux$pdests.orig[[i]] <- dests; qaux$pdests[[i]] <- dests.new qaux$phase1.ind[i] <- phase1; qaux$phase2.ind[i] <- phase2 } q.new <- msm.form.qmodel(qmatrix=qmatrix.new, qconstraint=qconstraint, analyticp=analyticp, use.expm=use.expm, phase.states=NULL) q.new <- c(q.new, qaux) q.new } msm.phase2hmodel <- function(qmodel, hmodel){ if (is.null(hmodel)) { hmodel <- vector(qmodel$nstates, mode="list") for (i in 1:qmodel$nstates) hmodel[[i]] <- hmmIdent(qmodel$phase.pars[i]) } ## dummy initprobs here: actually defined later in msm.form.initprobs, since needs knowledge of the data hmodel <- c(msm.form.hmodel(hmodel=hmodel, initprobs=c(1,rep(0,qmodel$nstates-1)), est.initprobs=FALSE), list(phase.states=qmodel$phase.states)) hmodel } ## Convert parameters of fitted phase-type model to mixture representation phasemeans.msm <- function(x, covariates="mean", ci=c("none","normal","bootstrap"), cl=0.95, B=1000, cores=NULL){ ps <- x$qmodel$phase.states Q <- qmatrix.msm(x, ci="none", covariates=covariates) res <- matrix(nrow=length(ps), ncol=3) pnames <- c("Short stay mean", "Long stay mean", "Long stay probability") rownames(res) <- rownames(x$qmodel$imatrix.orig)[x$qmodel$phase.states] colnames(res) <- pnames for (i in seq_along(ps)){ p1 <- x$qmodel$phase1.ind[i]; p2 <- x$qmodel$phase2.ind[i] lam1 <- Q[p1, p2] mu1 <- sum(Q[p1, -c(p1, p2)]) mu2 <- sum(Q[p2, -p2]) mean1 <- 1/(lam1 + mu1) mean2 <- mean1 + 1/mu2 prob2 <- lam1*mean1 res[i,] <- c(mean1, mean2, prob2) } ci <- match.arg(ci) p.ci <- switch(ci, normal = phasemeans.normci.msm(x=x, covariates=covariates, cl=cl, B=B), bootstrap = phasemeans.ci.msm(x=x, covariates=covariates, cl=cl, B=B, cores=cores), none = NULL) res <- if (ci=="none") res else list(estimates = res, L=p.ci[,,1], U=p.ci[,,2]) class(res) <- "msm.est" res } d2phase <- function(x, l1, mu1, mu2, log=FALSE){ t <- x ret <- numeric(length(t)) ret[t<0] <- 0 ret[l1<0 | mu1<0 | mu2<0] <- NaN ind <- (l1>=0 & mu1>=0 & mu2>=0 & t>=0) l1 <- rep(l1, length=length(t)); mu1 <- rep(mu1, length=length(t)); mu2 <- rep(mu2, length=length(t)); if(any(ind)) { ## same as MatrixExp(Q*t)[1,] %*% c(mu1, mu2, 0) if (log) { tmp <- ifelse(l1+mu1==mu2, -(l1+mu1)*t + log(mu1 + (l1+mu1)*l1*t), log((-(l1+mu1)*exp(-(l1+mu1)*t)*(-mu1+mu2) + mu2*l1*exp(-mu2*t))/(l1+mu1-mu2))) } else { tmp <- ifelse(l1+mu1==mu2, exp(-(l1+mu1)*t)*(mu1 + (l1+mu1)*l1*t), (-(l1+mu1)*exp(-(l1+mu1)*t)*(-mu1+mu2) + mu2*l1*exp(-mu2*t))/(l1+mu1-mu2)) } ret[ind] <- tmp[ind] } ret } p2phase <- function(q, l1, mu1, mu2, lower.tail=TRUE, log.p=FALSE){ t <- q ret <- numeric(length(t)) ret[t<0] <- 0 ret[l1<0 | mu1<0 | mu2<0] <- NaN ind <- (l1>=0 & mu1>=0 & mu2>=0 & t>=0) if(any(ind)) { if (l1+mu1==mu2) { if (!lower.tail && log) tmp <- -(l1+mu1)*t + log(1 + l1*t) else { tmp <- 1 - exp(-(l1+mu1)*t)*(1 + l1*t) if (!lower.tail) tmp <- 1 - tmp if (log.p) tmp <- log(tmp) } } else { ## same as MatrixExp(Q*t)[1,3] tmp <- 1 + exp(-(l1+mu1)*t)*(-mu1+mu2)/(l1+mu1-mu2) - l1*exp(-mu2*t)/(l1+mu1-mu2) if (!lower.tail) tmp <- 1 - tmp if (log.p) tmp <- log(tmp) } ret[ind] <- tmp[ind] } ret } q2phase <- function(p, l1, mu1, mu2, lower.tail=TRUE, log.p=FALSE){ qgeneric(p2phase, p=p, l1=l1, mu1=mu1, mu2=mu2, lower.tail=lower.tail, log.p=log.p) } r2phase <- function(n, l1, mu1, mu2){ if (length(n) > 1) n <- length(n) ret <- numeric(n) ret[l1<0 | mu1<0 | mu2<0] <- NaN ind <- (l1>=0 & mu1>=0 & mu2>=0) if(any(ind)) { l1 <- rep(l1, length=n); mu1 <- rep(mu1, length=n); mu2 <- rep(mu2, length=n) l1 <- l1[ind]; mu1 <- mu1[ind]; mu2 <- mu2[ind]; n <- sum(ind) ptrans <- l1/(l1+mu1) ret[ind] <- rexp(n,l1+mu1) + rbinom(n, 1, ptrans)*rexp(n, mu2) } ret } h2phase <- function(x, l1, mu1, mu2, log=FALSE) { t <- x ret <- numeric(length(x)) ret[t<0] <- 0 ret[l1<0 | mu1<0 | mu2<0] <- NaN ind <- (l1>=0 & mu1>=0 & mu2>=0 & t>=0) if(any(ind)) { if (l1+mu1==mu2) { tmp <- (mu1 + (l1+mu1)*l1*t) / (1 + l1*t) # clearer formula if (log) tmp <- log(tmp) } else { if (log) tmp <- d2phase(t,l1,mu1,mu2,log=TRUE) - p2phase(t,l1,mu1,mu2,lower.tail=FALSE,log.p=TRUE) else tmp <- d2phase(t,l1,mu1,mu2) / p2phase(t,l1,mu1,mu2,lower.tail=FALSE) } ret[ind] <- tmp[ind] } ret } msm/R/optim.R0000755000176200001440000002745412616472252012550 0ustar liggesusersderiv.supported <- function(msmdata, hmodel, cmodel){ (!hmodel$hidden || (hmodel$hidden && ## Models where derivatives not supported: ## multiple outcomes # (is.null(ncol(msmdata$mf$"(state)")) || (ncol(msmdata$mf$"(state)")==1)) && ## unknown initial state probs !hmodel$est.initprobs && ## constraints on misclassification / categorical outcome probabilities (!any(duplicated(hmodel$constr[hmodel$plabs=="p"]))) && (!any(duplicated(hmodel$covconstr[.msm.HMODELS[hmodel$models[hmodel$coveffstate]]=="categorical"]))) && all(.msm.HMODELS[hmodel$models %in% .msm.HMODELS.DERIV]) )) } info.supported <- function(msmdata, hmodel, cmodel){ ## only panel data and either non-hidden or misclassification models deriv.supported(msmdata, hmodel, cmodel) && all(msmdata$mf$"(obstype)"==1) && (!hmodel$hidden || (hmodel$hidden && all(.msm.HMODELS[hmodel$models] %in% .msm.HMODELS.INFO))) } ### GENERIC OPTIMISATION FUNCTION msm.optim <- function(opt.method, p, hessian, use.deriv, msmdata, qmodel, qcmodel, cmodel, hmodel, ...){ p$params <- p$allinits gr <- if (deriv.supported(msmdata,hmodel,cmodel) && use.deriv) deriv.msm else NULL optfn <- paste("msm.optim", opt.method, sep=".") if (!exists(optfn)) stop("Unknown optimisation method \"", opt.method, "\"") assign("nliks", 0, envir=msm.globals) args <- c(list(p=p, gr=gr, hessian=hessian, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel), list(...)) p <- do.call(optfn, args) assign("nliks", 0, envir=msm.globals) if (isTRUE(getOption("msm.test.analytic.derivatives"))){ if (!deriv.supported(msmdata,hmodel,cmodel)) warning("Analytic derivatives not available for this model") else p$deriv.test <- deriv.test(msmdata, qmodel, qcmodel, cmodel, hmodel, msm.unfixallparams(p)) } ## Attach derivative and information matrix at the MLE. ## If all parameters fixed, do this at the initial values for all. pp <- if (opt.method=="fixed") msm.unfixallparams(p) else p pi <- pp$params[pp$optpars] if (deriv.supported(msmdata,hmodel,cmodel)) { p$deriv <- deriv.msm(pi, msmdata, qmodel, qcmodel, cmodel, hmodel, pp) if (info.supported(msmdata,hmodel,cmodel)) { p$information <- information.msm(pi, msmdata, qmodel, qcmodel, cmodel, hmodel, pp) } } p } ## SPECIFIC OPTIMISATION METHODS ## All should take same arguments ## All should add $lik, $params, $opt terms to "paramdata" object "p" ### This allows the user to just drop in a new method without touching the rest of the msm package code ## Trivial one where all the parameters are fixed at their initial values msm.optim.fixed <- function(p, gr, hessian, msmdata, qmodel, qcmodel, cmodel, hmodel, ...) { p$lik <- lik.msm(p$inits, msmdata, qmodel, qcmodel, cmodel, hmodel, p) p$opt <- list(par = p$allinits[!duplicated(abs(p$constr))]) p$params <- msm.rep.constraints(p$params, p, hmodel) p$allinits[!duplicated(abs(p$constr))][abs(p$constr)]*sign(p$constr) p.unfix <- msm.unfixallparams(p) if (hessian) p$opt$hessian <- optimHess(par=p.unfix$inits, fn=lik.msm, gr=gr, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p.unfix) p } msm.optim.optim <- function(p, gr, hessian, msmdata, qmodel, qcmodel, cmodel, hmodel, ...) { optim.args <- list(...) if (is.null(optim.args$method)) optim.args$method <- if (deriv.supported(msmdata, hmodel, cmodel) || (length(p$inits)==1)) "BFGS" else "Nelder-Mead" if (is.null(optim.args$control)) optim.args$control <- list() # this might cause more trouble than it solves. # * R/optim.R: Pass fnscale to optim() automatically, if not already # provided, using the likelihood at the initial values. Wastes a # likelihood calculation but should improve convergence. # if (is.null(optim.args$control$fnscale)) # optim.args$control$fnscale <- lik.msm(p$inits, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, # cmodel=cmodel, hmodel=hmodel, paramdata=p) optim.args <- c(optim.args, list(par=p$inits, fn=lik.msm, hessian=hessian, gr=gr, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p)) opt <- do.call("optim", optim.args) if (opt$convergence==1) warning("Iteration limit in optim() reached without convergence. Reported estimates are not the maximum likelihood. Increase \"maxit\" or change optimisation method - see help(optim) and help(msm).") else if (opt$convergence==10) warning("Not converged: Nelder-Mead simplex is degenerate. Reported estimates are not the maximum likelihood.") else if (opt$convergence %in% 51:52) warning("Not converged: error in L-BFGS-B, see help(optim). Reported estimates are not the maximum likelihood.") ctrace <- !is.null(optim.args$control$trace) && optim.args$control$trace > 0 if (ctrace){ cat("Used", opt$counts[1], "function and", opt$counts[2], "gradient evaluations\n") } if (!is.null(opt$message)) warning("optim() returned a message: ",opt$message) p$lik <- opt$value p$params[p$optpars] <- opt$par p$opt <- opt p } msm.optim.nlm <- function(p, gr, hessian, msmdata, qmodel, qcmodel, cmodel, hmodel, ...) { nlmfn <- function(par) { ret <- lik.msm(par, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) if (!is.null(gr)) attr(ret, "gradient") <- deriv.msm(par, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) ret } optim.args <- c(list(...), list(f=nlmfn, p=p$inits, hessian=hessian)) ## suspect this check is excessively precise if (!is.null(optim.args$check.analyticals)) warning("Forcing check.analyticals=FALSE in \"nlm\"") optim.args$check.analyticals <- FALSE opt <- do.call("nlm", optim.args) if (opt$code==4) warning("Iteration limit in nlm() reached without convergence. Reported estimates are not the maximum likelihood. Increase \"iterlim\" or change optimisation method - see help(nlm) and help(msm).") else if (opt$code==3) warning("Not converged: local minimum or step size too small. Reported estimates are not the maximum likelihood. See help(nlm)") else if (opt$code==5) warning("Not converged: maximum step size exceeded five consecutive times. Reported estimates are not the maximum likelihood. See help(nlm)") ctrace <- !is.null(list(...)$print.level) && list(...)$print.level > 0 if (ctrace) cat("Used", opt$iterations, "iterations\n") p$lik <- opt$minimum p$params[p$optpars] <- opt$estimate p$opt <- opt p } msm.optim.fisher <- function(p, gr, hessian, msmdata, qmodel, qcmodel, cmodel, hmodel, ...) { if (hmodel$hidden) stop("Fisher scoring not supported for hidden Markov models or censored states") if (cmodel$ncens > 0) stop("Fisher scoring not supported with censored states") if (any(msmdata$mf$"(obstype)"==2)) stop("Fisher scoring not supported with exact transition times") if (any(msmdata$mf$"(obstype)"==3)) stop("Fisher scoring not supported with exact death times") optim.args <- list(...) if (is.null(optim.args$control$reltol)) reltol <- sqrt(.Machine$double.eps) damp <- if (is.null(optim.args$control$damp)) 0 else optim.args$control$damp theta <- p$inits lik.old <- -lik.msm(theta, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) converged <- FALSE iterations <- 1 ctrace <- !is.null(optim.args$control$trace) && optim.args$control$trace > 0 while(!converged) { if (ctrace) cat("-2loglik=",-lik.old,", pars=",theta,"\n") Info <- information.msm(theta, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) V <- -deriv.msm(theta, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) Info <- Info + diag(damp, nrow(Info)) theta <- theta + solve(Info, V) lik.new <- -lik.msm(theta, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) iterations <- iterations + 1 if (abs(lik.old - lik.new) < reltol*(abs(lik.old) + reltol)) converged <- TRUE else lik.old <- lik.new } if (ctrace) cat("Used", iterations, "evaluations of likelihood and information\n") p$lik <- -lik.new p$params[p$optpars] <- theta opt <- list(minimum=-lik.new, estimate=theta, value=-lik.new, par=theta, iterations=iterations) if (hessian) opt$hessian <- optimHess(par=theta, fn=lik.msm, gr=gr, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) p$opt <- opt p } msm.optim.bobyqa <- function(p, gr, hessian, msmdata, qmodel, qcmodel, cmodel, hmodel, ...) { optim.args <- list(...) optim.args <- c(optim.args, list(par=p$inits, fn=lik.msm, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p)) if (requireNamespace("minqa", quietly = TRUE)){ opt <- do.call("bobyqa", optim.args) } else stop("\"minqa\" package not available") if (opt$ierr %in% 1:5) warning(opt$msg, ". Reported estimates are not the maximum likelihood. See help(bobyqa) and help(msm).") if (hessian) opt$hessian <- optimHess(par=opt$par, fn=lik.msm, gr=gr, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) ctrace <- !is.null(optim.args$control$iprint) && optim.args$control$iprint > 0 if (ctrace) cat("Used", opt$feval, "function evaluations\n") p$lik <- opt$fval p$params[p$optpars] <- opt$par p$opt <- opt p } ### Test analytic against numeric derivatives deriv.test <- function(msmdata, qmodel, qcmodel, cmodel, hmodel, p){ an.d <- deriv.msm(p$inits, msmdata, qmodel, qcmodel, cmodel, hmodel, p) # if (0){ ## fiddly method using stats::numericDeriv likwrap <- function(x, ...){ pars <- list(unlist(list(...))) do.call("lik.msm", c(pars, x)) } myenv <- new.env() assign("x", list(msmdata, qmodel, qcmodel, cmodel, hmodel, p), envir = myenv) for (i in 1:p$nopt) assign(paste("p", i, sep=""), p$inits[i], envir = myenv) pvec <- paste("p",1:p$nopt,sep="") foo <- numericDeriv(as.call(lapply(as.list(c("likwrap", "x", pvec)), as.name)), pvec, myenv) num.d <- attr(foo,"gradient") err <- mean(abs(an.d - num.d)) #} # err <- num.d <- NULL ## much cleaner method. appears to be more accurate as well if (requireNamespace("numDeriv", quietly = TRUE)) numd2 <- numDeriv::grad(lik.msm, p$inits, msmdata=msmdata, qmodel=qmodel, qcmodel=qcmodel, cmodel=cmodel, hmodel=hmodel, paramdata=p) else stop("\"numDeriv\" package not available") err2 <- mean(abs(an.d - numd2)) res <- cbind(analytic=an.d, numeric.base=as.vector(num.d), numeric.nd=numd2) rownames(res) <- names(p$inits) list(res=res, error=c(base=err, nd=err2)) } msm/R/olddata.R0000755000176200001440000000626212325432125013012 0ustar liggesusers## forget about data.orig, this was just without pci imputation ## not supported whichcovh.orig ## could use unname to remove names on stuff recreate.olddata <- function(x) { x$data <- expand.data(x) mf <- x$data$mf; mf.agg <- x$data$mf.agg; mm.cov <- x$data$mm.cov; mm.cov.agg <- x$data$mm.cov.agg; mm.mcov <- x$data$mm.mcov; mm.hcov <- x$data$mm.hcov; mm.icov <- x$data$mm.icov get.covdata <- function(mm, mf) { list(covlabels=colnames(mm)[-1], ncovs=ncol(mm)-1, covfactor=sapply(mf, is.factor), covfactorlevels=lapply(mf, levels), covmat=mm, covmat.orig=mf, covlabels.orig=colnames(mf) ## forget about covrows.kept ) } covdata <- get.covdata(mm.cov, mf) misccovdata <- if (x$emodel$misc) get.covdata(mm.mcov, mf) else NULL if (x$hmodel$hidden) { hcovdata <- list() for (i in seq(x$qmodel$nstates)) hcovdata[[i]] <- get.covdata(mm.hcov[[i]], mf) icovdata <- get.covdata(mm.icov, mf) whichcovh <- lapply(mm.hcov, function(x)match(colnames(x)[-1], colnames(mm)[-1])) for (i in seq(x$qmodel$nstates)) hcovdata[[i]]$whichcov <- whichcovh[[i]] } else hcovdata <- icovdata <- NULL ## TESTME - watch for factors, interactions and intercept, reduce if no covs. mmh <- if (!is.null(mm.hcov)) do.call("cbind",mm.hcov) else NULL mm <- cbind(mm.cov, mm.icov, mmh) mm <- mm[,unique(colnames(mm))] covdata$whichcov <- match(colnames(mm.cov)[-1], colnames(mm)[-1]) covdata$whichcov.orig <- match(attr(mf, "covnames.q"), attr(mf, "covnames")) misccovdata$whichcov <- match(colnames(mm.mcov)[-1], colnames(mm)[-1]) # names should be in mm.hcov icovdata$whichcov <- match(colnames(mm.icov)[-1], colnames(mm)[-1]) ret <- list( fromstate = model.extract(mf.agg, "fromstate"), tostate = model.extract(mf.agg, "tostate"), timelag = model.extract(mf.agg, "timelag"), nocc = model.extract(mf.agg, "nocc"), whicha = model.extract(mf.agg, "whicha"), noccsum = model.extract(mf.agg, "noccsum"), obstype = if (!is.null(mf.agg)) model.extract(mf.agg, "obstype") else model.extract(mf, "obstype"), covmat = mm.cov.agg[,-1,drop=FALSE], covdata = covdata, misccovdata = misccovdata, hcovdata = hcovdata, icovdata = icovdata, npts = length(unique(model.extract(mf, "subject"))), covlabels = names(attr(mf, "covmeans"))[-1], covmeans = attr(mf, "covmeans")[-1], nobs = if (!is.null(mf.agg)) nrow(mf.agg) else nrow(mf), ntrans = sum(duplicated(model.extract(mf, "subject"))), time = mf[,2], state = mf[,1], subject = model.extract(mf, "subject"), n = nrow(mf), obstype.obs = model.extract(mf, "obstype"), firstobs = c(which(!duplicated(model.extract(mf, "subject"))), nrow(mf)+1), obstrue = model.extract(mf, "obstrue"), pci.imp = model.extract(mf, "pci.imp"), cov = mm[,-1,drop=FALSE], cov.orig = mf[,attr(mf,"covnames")], covlabels.orig = attr(mf,"covnames") ) ret } msm/R/outputs.R0000755000176200001440000026747712605160210013140 0ustar liggesusers### METHODS FOR MSM OBJECTS qmatrix.msm <- function(x, covariates="mean", sojourn=FALSE, ci=c("delta","normal","bootstrap","none"), cl=0.95, B=1000, cores=NULL) { if (!inherits(x, "msm")) stop("expected x to be a msm model") nst <- x$qmodel$nstates ni <- x$qmodel$npars covlist <- msm.parse.covariates(x, covariates, x$qcmodel) nc <- length(covlist) # number of effects we need to adjust baseline for if ((cl < 0) || (cl > 1)) stop("expected cl in [0,1]") se <- lse <- fixed <- numeric(ni) logest <- x$Qmatrices$logbaseline if (is.null(x$QmatricesFixed)) x <- msm.form.output(x, "intens") # for back-compat with pre 1.4.1 model objects fixed <- x$QmatricesFixed$logbaseline for (i in seq_len(nc)) { logest <- logest + x$Qmatrices[[i+1]] * covlist[[i]] fixed <- fixed & x$QmatricesFixed[[i+1]] # Only true if all coefficients contributing to the estimate are fixed. Used in print functions } mat <- exp(logest) mat[x$qmodel$imatrix == 0] <- 0 mat <- msm.fixdiag.qmatrix(mat) if (sojourn) soj = -1 / diag(mat) ci <- match.arg(ci) if (x$foundse && (ci!="none")) { if (ci == "delta") { ## Work out standard errors. ## Transformation for delta method is (intensities) ## exp (x1 + x2 (cov1 - covmean1) + x3 (cov2 - covmean2) + ... ) ## expit(sum covs) / (1 + expit(sum(covs))) or 1 / (1 + expit(sum(covs))) ## Use delta method to find approximate SE of the transform on log scale ## Work out a CI for this by assuming normal and transforming back coefs <- c(1, covlist) semat <- lsemat <- lmat <- umat <- matrix(0, nst, nst) form <- as.formula(paste("~", expsum(seq(nc + 1), coefs))) lform <- as.formula(paste("~", lsum(seq(nc + 1), coefs))) ## indices into estimates vector of all intens/miscs, intens covs / misc covs inds <- seq(length=x$qmodel$npars + x$qcmodel$npars) for (i in 1 : ni){ ## indices into estimates vector of all intens/miscs, intens covs / misc covs for that particular fromstate-tostate. parinds <- inds[seq(i, (nc * ni + i), ni)] ests <- x$estimates[parinds] cov <- x$covmat[parinds, parinds] se[i] <- deltamethod(form, ests, cov) lse[i] <- deltamethod(lform, ests, cov) } ivector <- as.numeric(t(x$qmodel$imatrix)) semat[ivector == 1] <- se; semat <- t(semat) lsemat[ivector == 1] <- lse; lsemat <- t(lsemat) lmat <- exp(logest - qnorm(1 - 0.5*(1 - cl))*lsemat) umat <- exp(logest + qnorm(1 - 0.5*(1 - cl))*lsemat) imatrix <- x$qmodel$imatrix lmat[imatrix == 0] <- umat[imatrix == 0] <- 0 ## SEs of diagonal entries diagse <- qmatrix.diagse.msm(x, covlist, sojourn, ni, ivector, nc) diag(semat) <- diagse$diagse diag(lmat) <- sign(diag(mat)) * (exp(log(abs(diag(mat))) - sign(diag(mat)) * qnorm(1 - 0.5*(1 - cl))*diagse$diaglse)) diag(umat) <- sign(diag(mat)) * (exp(log(abs(diag(mat))) + sign(diag(mat)) * qnorm(1 - 0.5*(1 - cl))*diagse$diaglse)) if (sojourn) { sojse <- diagse$sojse sojl <- exp(log(soj) - qnorm(1 - 0.5*(1 - cl))*diagse$sojlse) soju <- exp(log(soj) + qnorm(1 - 0.5*(1 - cl))*diagse$sojlse) } } else if (ci %in% c("normal","bootstrap")) { q.ci <- if (ci=="normal") qmatrix.normci.msm(x, covariates, sojourn, cl, B) else qmatrix.ci.msm(x, covariates, sojourn, cl, B, cores) if (sojourn) { soj.ci <- q.ci$soj q.ci <- q.ci$q sojl <- soj.ci[1,]; soju <- soj.ci[2,]; sojse <- soj.ci[3,] } lmat <- q.ci[,,1]; umat <- q.ci[,,2]; semat <- q.ci[,,3] } dimnames(semat) <- dimnames(lmat) <- dimnames(umat) <- dimnames(x$qmodel$qmatrix) } else semat <- lmat <- umat <- sojse <- sojl <- soju <- NULL dimnames(mat) <- dimnames(x$qmodel$qmatrix) if (ci=="none") res <- if (sojourn) soj else mat else { if (sojourn) res <- list(estimates=mat, SE=semat, L=lmat, U=umat, fixed=fixed, sojourn=soj, sojournSE=sojse, sojournL=sojl, sojournU=soju) else res <- list(estimates=mat, SE=semat, L=lmat, U=umat, fixed=fixed) class(res) <- "msm.est" } res } ematrix.msm <- function(x, covariates="mean", ci=c("delta","normal","bootstrap","none"), cl=0.95, B=1000, cores=NULL) { if (!inherits(x, "msm")) stop("expected x to be a msm model") if (!x$emodel$misc) return(NULL) nst <- x$qmodel$nstates ni <- x$emodel$npars covlist <- msm.parse.covariates(x, covariates, x$ecmodel) nc <- length(covlist) if ((cl < 0) || (cl > 1)) stop("expected cl in [0,1]") se <- lse <- numeric(ni) logest <- x$Ematrices$logitbaseline if (is.null(x$EmatricesFixed)) x <- msm.form.output(x, "misc") # for back-compat with pre 1.4.1 model objects fixed <- x$EmatricesFixed$logitbaseline for (i in seq_len(nc)) { logest <- logest + x$Ematrices[[i+1]] * covlist[[i]] fixed <- fixed & x$EmatricesFixed[[i+1]] # Only true if all coefficients contributing to the estimate are fixed. Used in print functions } plabs <- x$emodel$imatrix plabs[x$emodel$imatrix==1] <- "p" diag(plabs)[rowSums(x$emodel$imatrix)>0] <- "pbase" mat <- matrix(msm.mninvlogit.transform(as.vector(t(logest)), as.vector(t(plabs)), rep(1:nst, each=nst)), nrow=nst, byrow=TRUE) ## true states with no misclassification or perfect misclassification mat[cbind(which(x$hmodel$model==match("identity", .msm.HMODELS)), x$hmodel$pars[names(x$hmodel$pars)=="which"])] <- 1 ci <- match.arg(ci) if (x$foundse && (ci!="none")) { if (ci == "delta") { ## Work out standard errors. ## Transformation for delta method is ## expit(sum covs) / (1 + expit(sum(covs))) or 1 / (1 + expit(sum(covs))) semat <- lmat <- umat <- matrix(0, nst, nst) p.se <- p.se.msm(x, covariates) ivector <- as.numeric(t(x$emodel$imatrix)) if (any(p.se$lab %in% c("p","pbase"))){ semat[ivector==1] <- p.se$se[p.se$lab=="p"]; semat <- t(semat) lmat[ivector==1] <- p.se$LCL[p.se$lab=="p"]; lmat <- t(lmat) umat[ivector==1] <- p.se$UCL[p.se$lab=="p"]; umat <- t(umat) diag(semat)[rowSums(x$emodel$imatrix)>0] <- p.se$se[p.se$lab=="pbase"] diag(lmat)[rowSums(x$emodel$imatrix)>0] <- p.se$LCL[p.se$lab=="pbase"] diag(umat)[rowSums(x$emodel$imatrix)>0] <- p.se$UCL[p.se$lab=="pbase"] } lmat[mat==1] <- umat[mat==1] <- 1 } else if (ci=="normal") { e.ci <- ematrix.normci.msm(x, covariates, cl, B) lmat <- e.ci[,,1]; umat <- e.ci[,,2]; semat <- e.ci[,,3] } else if (ci=="bootstrap") { e.ci <- ematrix.ci.msm(x, covariates, cl, B, cores) lmat <- e.ci[,,1]; umat <- e.ci[,,2]; semat <- e.ci[,,3] } dimnames(semat) <- dimnames(lmat) <- dimnames(umat) <- dimnames(x$qmodel$qmatrix) } else semat <- lmat <- umat <- NULL dimnames(mat) <- dimnames(x$qmodel$qmatrix) if (ci=="none") res <- mat else { res <- list(estimates=mat, SE=semat, L=lmat, U=umat, fixed=fixed) class(res) <- "msm.est" } res } ## Convert "covariates" argument supplied in output function (like ## qmatrix.msm) to a list of values, one per covariate effect ## (e.g. one per factor contrast). Handle special arguments 0 and ## "mean". msm.parse.covariates <- function(x, covariates, mod, consider.center=TRUE){ nc <- mod$ncovs if (nc == 0){ if (is.list(covariates) && (length(covariates) > 0)) warning("Ignoring covariates - no covariates in this part of the model") return(list()) } if (consider.center) { ## no adjustment needed: baseline is what we want if (!is.list(covariates) && ((covariates==0 && !x$center) || (covariates=="mean" && x$center))) return(list()) } if (!is.list(covariates)) { covlist <- list() if (covariates == 0) { for (i in 1:nc) covlist[[mod$covlabels[i]]] <- 0 } else if (covariates == "mean") { for (i in 1:nc) covlist[[mod$covlabels[i]]] <- mod$covmeans[i] } else stop("covariates argument must be 0, \"mean\", or a list of values for each named covariate") } else { ## Check supplied list of covariate values, convert factors to numeric contrasts, expand interactions, set unknown values to zero. covlist <- factorcov2numeric.msm(covariates, x, mod) } if (x$center && consider.center) for (i in 1:nc) covlist[[mod$covlabels[i]]] <- covlist[[mod$covlabels[i]]] - mod$covmeans[i] covlist } ### Given a "covariates" argument of an extractor function containing ### factor covariates, convert the factor covariates to numeric ### contrasts. For example, for a categorical covariate "smoke" with ### three levels "NON","CURRENT","EX", with baseline level "NON", ### convert list(smoke="CURRENT") to list(smokeCURRENT=1, smokeEX=0) ### Any unspecified covariate values are set to zero. ### Any unknown covariates are dropped with a warning. factorcov2numeric.msm <- function(covariates, x, mod=NULL) { if (is.null(mod)) mod <- x$qcmodel covdata.mf <- x$data$mf[attr(x$data$mf,"covnames")] covnames.mm <- mod$covlabels covfactor <- sapply(covdata.mf, is.factor) covfactorlevels <- lapply(covdata.mf, levels) covnames <- names(covdata.mf) if (is.null(names(covariates))) { if (length(covariates)!=length(covnames)) stop("Expected covariate list of length ",length(covnames)) names(covariates) <- covnames } all.covnames <- union(covnames.mm,covnames) # including both factor and contrast names miss.covs <- ! names(covariates) %in% all.covnames if (any(miss.covs)){ plural <- if(sum(miss.covs)>1) "s" else "" warning("Covariate",plural," \"", paste(names(covariates)[which(!names(covariates) %in% all.covnames)], collapse=", "), "\" unknown, ignoring") } cfac <- covariates[names(covariates) %in% covnames[which(covfactor)]] cnum <- covariates[! names(covariates) %in% covnames[which(covfactor)]] cfac.new <- list() for (i in seq(along=cfac)) { levs.i <- covfactorlevels[[names(cfac)[[i]]]] cfac.i <- rep(0, length(levs.i)) if (! cfac[[i]] %in% levs.i) stop("Level \"", cfac[[i]], "\" of covariate ", names(cfac)[[i]], " unknown") cfac.i[match(cfac[[i]], levs.i)] <- 1 names(cfac.i) <- paste(names(cfac)[[i]], levs.i, sep="") cfac.i <- as.list(cfac.i[-1]) cfac.new <- c(cfac.new, cfac.i) } covlabels.noint <- covnames.mm[setdiff(seq(along=covnames.mm), grep(":", covnames.mm))] covs.out <- as.list(numeric(length(covlabels.noint))) names(covs.out) <- covlabels.noint covs.out[names(cnum)] <- cnum covs.out[names(cfac.new)] <- cfac.new covs.out <- expand.interactions.msm(covs.out, covnames.mm) covs.out } ### Work out SE and CIs of misclassification probabilities for given covariate values. ### Know SEs of beta_rs, use delta method to calculate. ### SE of p_rs = exp(beta_rs x) / (1 + sum(exp(beta_rs x))) (non-baseline p) or 1 / (1 + sum(exp(beta_rs x))) (baseline p). ### To calculate symmetric CI for resulting p_rs, assume logit(p_rs) normal, and use SE(logit(p_rs)) calculated by delta method. p.se.msm <- function(x, covariates) { qmodel <- x$qmodel; emodel <- x$emodel; hmodel <- x$hmodel; qcmodel <- x$qcmodel; ecmodel <- x$ecmodel; paramdata <- x$paramdata nst <- qmodel$nstates inds <- (qmodel$npars + qcmodel$npars + 1) : (qmodel$npars + qcmodel$npars + sum(hmodel$npars) + hmodel$ncoveffs) ni <- emodel$npars covlist <- msm.parse.covariates(x, covariates, ecmodel) nc <- length(covlist) coefs <- c(1, covlist) ppars <- hmodel$plabs %in% c("p","pbase") res <- data.frame(lab=hmodel$plabs[ppars]) hmmallpars <- !(paramdata$plabs %in% c("qbase","qcov","initp","initp0","initpcov")) res$est <- msm.mninvlogit.transform(paramdata$params[paramdata$hmmpars], hmodel$plabs, hmodel$parstate)[ppars] res$parstate <- hmodel$parstate[ppars] if (any(ppars)) res$se <- res$lse <- res$LCL <- res$UCL <- res$inds <- res$strs <- 0 cur.i <- 1 for (i in unique(res$parstate)) { nir <- sum(hmodel$parstate[hmodel$plabs=="p"] == i) # number of independent misc probs for current state if (nir > 0){ # might be perfect misclassification p.inds <- which(hmodel$plabs=="p" & hmodel$parstate==i) # indices into HMM parameter vector of logit baseline p for that state cov.inds <- sum(hmodel$npars) + (cur.i-1)*nc + seq(length=(nc*nir)) # indices into HMM parameter vector of corresp cov effects parinds <- numeric(); formstr <- character(nir) for (j in 1:nir) { formstr[j] <- expsum(1:((nc+1)*nir), coefs) # string of form exp(1*x1+beta1*x2*beta2*x3), exp(x4+beta*x5+...) parinds <- c(parinds, p.inds[j], cov.inds[(j-1)*nc + seq(length=nc)]) # indices into HMM par vector corresp to x1,x2,x3,... } sumstr <- paste(formstr, collapse = " + ") # "parinds" are formstr <- paste("1 / (1 + ", sumstr, ")") form <- as.formula(paste("~ ",formstr)) lform <- as.formula(paste("~ log( (", formstr, ") / (1 - ", formstr, "))")) ests <- paramdata$params[hmmallpars][parinds] cov <- paramdata$covmat[hmmallpars,hmmallpars][parinds, parinds] res$se[res$parstate==i & res$lab=="pbase"] <- deltamethod(form, ests, cov) res$lse[res$parstate==i & res$lab=="pbase"] <- deltamethod(lform, ests, cov) res$strs[res$parstate==i & res$lab=="pbase"] <- paste(as.character(form),collapse="") res$inds[res$parstate==i & res$lab=="pbase"] <- paste(parinds,collapse=",") for (j in 1:nir){ istr <- expsum(((j-1)*(nc+1)+1):(j*(nc+1)), coefs) formstr <- paste(istr, "/ (1 + ", sumstr, ")") form <- as.formula(paste("~ ",formstr)) lform <- as.formula(paste("~ log( (", formstr, ") / (1 - ", formstr, "))")) res$se[res$parstate==i & res$lab=="p"][j] <- deltamethod(form, ests, cov) res$lse[res$parstate==i & res$lab=="p"][j] <- deltamethod(lform, ests, cov) res$strs[res$parstate==i & res$lab=="p"][j] <- paste(as.character(form), collapse="") res$inds[res$parstate==i & res$lab=="p"][j] <- paste(parinds,collapse=",") } cur.i <- cur.i + nir } } res$LCL <- plogis(qlogis(res$est) - qnorm(0.975)*res$lse) res$UCL <- plogis(qlogis(res$est) + qnorm(0.975)*res$lse) res } ### Work out standard error of a ratio of intensities using delta method ### Uuugh. What a fuss for one little number. qratio.se.msm <- function(x, ind1, ind2, covariates, cl=0.95) { nst <- x$qmodel$nstates ni <- x$qmodel$npars covlist <- msm.parse.covariates(x, covariates, x$qcmodel) nc <- length(covlist) indmat <- t(x$qmodel$imatrix) indmat[indmat == 1] <- seq(length = x$qmodel$npars) indmat <- t(indmat) # matrix of indices of estimate vector inds <- seq(length = x$qmodel$npars+x$qcmodel$npars) # identifiers for q and beta parameters coefs <- c(1, unlist(covlist)) parinds <- numeric() indmatrow.n <- indmat[ind1[1],-ind1[1]] nir.n <- sum(indmatrow.n > 0) indmatrow.d <- indmat[ind2[1],-ind2[1]] nir.d <- sum(indmatrow.d > 0) formstr.n <- character(nir.n) formstr.d <- character(nir.d) if (ind1[1]!=ind1[2] && ind2[1]!=ind2[2]) { # both intensities are off-diagonal parinds <- c(inds[indmat[ind1[1],ind1[2]] - 1 + seq(1, (nc * ni + 1), ni)], inds[indmat[ind2[1],ind2[2]] - 1 + seq(1, (nc * ni + 1), ni)]) parinds2 <- sort(unique(parinds)) xinds <- rank(parinds2)[match(parinds, parinds2)] formstr.n <- expsum(xinds[1:(nc+1)], coefs) formstr.d <- expsum(xinds[1:(nc+1) + nc+1] , coefs) } else if (ind1[1]!=ind1[2] && ind2[1]==ind2[2]) { # numerator off-diagonal, denom diagonal parinds <- inds[indmat[ind1[1],ind1[2]] - 1 + seq(1, (nc * ni + 1), ni)] cur.i <- min(indmatrow.d[indmatrow.d>0]) for (j in 1:nir.d) parinds <- c(parinds, inds[cur.i - 1 + seq(j, (nc * ni + j), ni)]) parinds2 <- sort(unique(parinds)) xinds <- rank(parinds2)[match(parinds, parinds2)] formstr.n <- expsum(xinds[1:(nc+1)], coefs) for (j in 1:nir.d) formstr.d[j] <- expsum(xinds[1:(nc+1) + j*(nc+1)], coefs) } else if (ind1[1]==ind1[2] && ind2[1]!=ind2[2]) { # numerator diagonal, denom off-diagonal cur.i <- min(indmatrow.n[indmatrow.n>0]) for (j in 1:nir.n) parinds <- c(parinds, inds[cur.i - 1 + seq(j, (nc * ni + j), ni)]) parinds <- c(parinds, inds[indmat[ind2[1],ind2[2]] - 1 + seq(1, (nc * ni + 1), ni)]) parinds2 <- sort(unique(parinds)) xinds <- rank(parinds2)[match(parinds, parinds2)] for (j in 1:nir.n) formstr.n[j] <- expsum(xinds[1:(nc+1) + (j-1)*(nc+1)], coefs) formstr.d <- expsum(xinds[nir.n*(nc+1) + 1:(nc+1)], coefs) } else if (ind1[1]==ind1[2] && ind2[1]==ind2[2]) { # both intensities diagonal cur.i <- min(indmatrow.n[indmatrow.n>0]) for (j in 1:nir.n) parinds <- c(parinds, inds[cur.i - 1 + seq(j, (nc * ni + j), ni)]) cur.i <- min(indmatrow.d[indmatrow.d>0]) for (j in 1:nir.d) parinds <- c(parinds, inds[cur.i - 1 + seq(j, (nc * ni + j), ni)]) parinds2 <- sort(unique(parinds)) xinds <- rank(parinds2)[match(parinds, parinds2)] for (j in 1:nir.n) formstr.n[j] <- expsum(xinds[1:(nc+1) + (j-1)*(nc+1)], coefs) for (j in 1:nir.d) formstr.d[j] <- expsum(xinds[nir.n*(nc+1) + 1:(nc+1) + (j-1)*(nc+1)], coefs) } num <- paste(formstr.n, collapse = " + ") denom <- paste(formstr.d, collapse = " + ") form <- as.formula(paste("~", "(", num, ") / (", denom, ")")) lform <- as.formula(paste("~ ", "log (", num, ") - log (", denom, ")")) ests <- x$estimates[parinds2] cov <- x$covmat[parinds2,parinds2] se <- deltamethod(form, ests, cov) lse <- deltamethod(lform, ests, cov) list(se=se, lse=lse) } ### Work out standard errors of diagonal entries of intensity matrix, or sojourn times, using delta method qmatrix.diagse.msm <- function(x, covlist, sojourn, ni, ivector, nc) { nst <- x$qmodel$nstates diagse <- diaglse <- sojse <- sojlse <- numeric(nst) indmat <- matrix(ivector, nst, nst) indmat[indmat==1] <- seq(length = ni) indmat <- t(indmat) # matrix of indices of estimate vector inds <- seq(length = ni + ni*nc) cur.i <- 1 coefs <- c(1, unlist(covlist)) for (i in 1:nst){ ## Transformation for delta method is ## exp(x1 + x2 (cov1 - covmean1) + x3 (cov2 - covmean2) + ... ) + ## exp(x4 + x5 (cov1 - covmean1) + x6 (cov2 - covmean2) + ... ) + (or expit(...)) nir <- sum(indmat[i,-i] > 0) # number of intens/misc for current state if (nir > 0) { qf <- expsum.formstr(nir, inds, cur.i, ni, nc, coefs) form <- as.formula(paste("~", paste(qf$formstr, collapse = " + "))) lform <- as.formula(paste("~ log (", paste(qf$formstr, collapse = " + "), ")")) ests <- x$estimates[qf$parinds2] cov <- x$covmat[qf$parinds2, qf$parinds2] diagse[i] <- deltamethod(form, ests, cov) diaglse[i] <- deltamethod(lform, ests, cov) if (sojourn){ ## Mean sojourn times are -1 / diagonal entries of q matrix. Calculate their SEs and CIs. form <- as.formula(paste("~ 1 / (", paste(qf$formstr, collapse = " + "), ")")) lform <- as.formula(paste("~ log ( 1 / (", paste(qf$formstr, collapse = " + "), ")", ")")) sojse[i] <- deltamethod(form, ests, cov) sojlse[i] <- deltamethod(lform, ests, cov) } cur.i <- cur.i + nir } else diagse[i] <- 0 } list(diagse=diagse, diaglse=diaglse, sojse=sojse, sojlse=sojlse) } ### Make a list of covariate lists to supply to pmatrix.piecewise.msm for models with "pci" time-dependent intensities. ### One for each time period, with time constant covariates replicated. ### For use in model assessment functions ### Returns factor covariates as contrasts, not factor levels. msm.fill.pci.covs <- function(x, covariates="mean"){ nc <- x$qcmodel$ncovs ## indices of covariates representing time periods ti <- grep("timeperiod\\[.+\\)", x$qcmodel$covlabels) ni <- setdiff(1:nc, ti) # indices of other covariates covlist <- msm.parse.covariates(x, covariates, x$qcmodel, consider.center=FALSE) for (i in names(covariates)) if (length(grep("^timeperiod",i))==0) { if (i %in% union(attr(x$data$mf, "covnames"),x$qcmodel$covlabels)) covlist[[i]] <- covariates[[i]] else warning("Covariate ",i," unknown") } for (i in ti) covlist[[i]] <- 0 ## set contrasts for each successive time period to 1 ncut <- length(x$pci) covlistlist <- vector(ncut+1, mode="list") names(covlistlist) <- levels(x$data$mf$timeperiod) covlistlist[[1]] <- covlist for (i in seq(length=ncut)){ covlistlist[[i+1]] <- covlist covlistlist[[i+1]][[ti[i]]] <- 1 } covlistlist } printold.msm <- function(x, ...) { cat("\nCall:\n", deparse(x$call), "\n\n", sep = "") if (!attr(x,"fixed")) { cat ("Maximum likelihood estimates: \n") covmessage <- if (x$qcmodel$ncovs == 0) "" else paste("with covariates set to", (if (x$center) "their means" else "0")) for (i in c("baseline", x$qcmodel$covlabels)) { title <- if (i == "baseline") paste("Transition intensity matrix",covmessage,"\n") else paste("Log-linear effects of", i, "\n") cat (title, "\n") print.ci(x$Qmatrices[[i]], x$QmatricesL[[i]], x$QmatricesU[[i]]) cat("\n") } if (x$emodel$misc) { misccovmessage <- if (x$ecmodel$ncovs == 0) "" else paste("with covariates set to", (if (x$center) "their means" else "0")) for (i in c("baseline", x$ecmodel$covlabels)) { title <- if (i == "baseline") paste("Misclassification matrix",misccovmessage,"\n") else paste("Effects of", i, "on log (P(state r)/P(baseline state))\n") cat (title, "\n") print.ci(x$Ematrices[[i]], x$EmatricesL[[i]], x$EmatricesU[[i]]) cat("\n") } if (any(x$paramdata$plabs[x$paramdata$optpars] == "initp")) { cat("Initial state occupancy probabilities\n\n") print(x$hmodel$initprobs) cat("\n") if (any(x$hmodel$nicovs > 0)) { cat("Covariates on logit initial state probabilities\n") print(x$hmodel$icoveffect) } cat("\n") } } else if (x$hmodel$hidden && is.null(x$qmodel$phase.states)) { print(x$hmodel); cat("\n") } } cat ("-2 * log-likelihood: ", x$minus2loglik, "\n") # cat("[Note: a cleaner summary is available from \"printnew.msm\",\n which will be the default in future versions.]\n") } ### Convert three-transition-matrices (estimate,lower,upper) format to three-columns format mattotrans <- function(x, matrix, lower, upper, fixed, keep.diag=FALSE, intmisc="intens"){ imat <- if (intmisc=="intens") x$qmodel$imatrix else x$emodel$imatrix if (keep.diag) diag(imat) <- as.numeric(rowSums(imat) > 0) keep <- which(t(imat)==1, arr.ind=TRUE) keep <- keep[,2:1,drop=FALSE] # order by row(from-state), not column(to-state) fromlabs <- rownames(imat)[keep[,1]] tolabs <- colnames(imat)[keep[,2]] res <- matrix(nrow=sum(imat), ncol=4) rnames <- if (intmisc=="intens") paste(fromlabs, "-", tolabs) else paste("Obs", tolabs, "|", fromlabs) dimnames(res) <- list(rnames, c("Estimate", "L", "U","Fixed")) res[,1] <- matrix[keep] res[,2] <- lower[keep] res[,3] <- upper[keep] res[,4] <- fixed[keep] res } ### Format transition intensities and their covariate effects in one tidy matrix msm.form.qoutput <- function(x, covariates="mean", cl=0.95, digits=4, ...){ qbase <- qmatrix.msm(x, covariates=covariates, cl=cl) if (is.null(x$QmatricesFixed)) x <- msm.form.output(x, "intens") # for back-compat with pre 1.4.1 model objects y <- mattotrans(x, qbase$estimates, qbase$L, qbase$U, qbase$fixed, keep.diag=TRUE) ret <- data.frame(base=y) fres <- matrix("", nrow=nrow(y), ncol=x$qcmodel$ncovs+1) colnames(fres) <- c("Baseline", x$qcmodel$covlabels) rownames(fres) <- rownames(y) fres[,1] <- format.ci(y[,1],y[,2],y[,3],y[,4],digits=digits,...) im <- t(x$qmodel$imatrix); diag(im) <- -colSums(im); nd <- which(im[im!=0]==1) for (i in seq(length=x$qcmodel$ncovs)){ nm <- x$qcmodel$covlabels[[i]] hrs <- mattotrans(x, x$Qmatrices[[nm]], x$QmatricesL[[nm]], x$QmatricesU[[nm]], x$QmatricesFixed[[nm]], keep.diag=FALSE) hrs[,1:3] <- exp(hrs[,1:3]) ret[nm] <- matrix(ncol=3, nrow=nrow(ret), dimnames=list(NULL,colnames(hrs)[1:3])) ret[nd,nm] <- hrs[,1:3,drop=FALSE] fres[nd,1+i] <- format.ci(hrs[,1], hrs[,2], hrs[,3], hrs[,4], digits=digits, ...) } attr(ret, "formatted") <- fres # as strings with formatted CIs instead of numbers ret } ### Format misclassification intensities and their covariate effects in one tidy matrix msm.form.eoutput <- function(x, covariates="mean", cl=0.95, digits=4, ...){ ebase <- ematrix.msm(x, covariates=covariates, cl=cl) if (is.null(x$EmatricesFixed)) x <- msm.form.output(x, "misc") # for back-compat with pre 1.4.1 model objects y <- mattotrans(x, ebase$estimates, ebase$L, ebase$U, ebase$fixed, keep.diag=TRUE, intmisc="misc") rete <- data.frame(base=y) frese <- matrix("", nrow=nrow(y), ncol=x$ecmodel$ncovs+1) colnames(frese) <- c("Baseline", x$ecmodel$covlabels) rownames(frese) <- rownames(y) frese[,1] <- format.ci(y[,1],y[,2],y[,3],y[,4],digits=digits,...) im <- t(x$emodel$imatrix); diag(im) <- -colSums(im); nd <- which(im[im!=0]==1) for (i in seq(length=x$ecmodel$ncovs)){ nm <- x$ecmodel$covlabels[[i]] ors <- mattotrans(x, x$Ematrices[[nm]], x$EmatricesL[[nm]], x$EmatricesU[[nm]], x$EmatricesFixed[[nm]], keep.diag=FALSE, intmisc="misc") ors[,1:3] <- exp(ors[,1:3]) rete[nm] <- matrix(ncol=3, nrow=nrow(rete), dimnames=list(NULL,colnames(ors)[1:3])) rete[nd,nm] <- ors[,1:3] frese[nd,1+i] <- format.ci(ors[,1], ors[,2], ors[,3], ors[,4], digits=digits,...) } attr(rete, "formatted") <- frese # as strings with formatted CIs instead of numbers rete } ## New more helpful and tidier print output print.msm <- function(x, covariates=NULL, digits=4, ...) { cat("\nCall:\n", deparse(x$call), "\n\n", sep = "") ret <- NULL if (!x$foundse & !attr(x, "fixed")) { cat("Optimisation probably not converged to the maximum likelihood.\noptim() reported convergence but estimated Hessian not positive-definite.\n") } else { if (is.null(x$cl)) { cl <- 0.95 warning("Found msm object saved before version 1.3. Models will need to be refitted under the newer version for output functions to work") } else cl <- x$cl if (!attr(x,"fixed")) { if (is.null(covariates)) { covvalue <- (if (x$center) "their means" else "0") covariates <- if (x$center) "mean" else 0 } else covvalue <- "the values supplied in \"covariates\"" covmessage <- if (attr(x$data$mf, "ncovs")==0) "" else paste0("\nBaselines are with covariates set to ", covvalue) cat("Maximum likelihood estimates", covmessage, "\n", sep="") if (x$qcmodel$ncovs> 0) hrmessage <- paste0(" with hazard ratios for each covariate") else hrmessage <- "" q.header <- paste0("Transition intensities", hrmessage, "\n") ret <- msm.form.qoutput(x, covariates, cl=cl, digitets=digits, ...) fres <- attr(ret, "formatted") cat("\n"); cat(q.header) print(fres, quote=FALSE) if (x$emodel$misc) { ormessage <- if (x$ecmodel$ncovs>0) paste0(" with odds ratios for each covariate") else "" e.header <- paste0("Misclassification probabilities", ormessage, "\n") rete <- msm.form.eoutput(x, covariates, cl=cl, digits=digits, ...) frese <- attr(rete, "formatted") cat("\n"); cat(e.header) print(frese, quote=FALSE) if (any(x$paramdata$plabs[x$paramdata$optpars] == "initp")) { i.header <- paste0("Initial state occupancy probabilities\n") cat("\n"); cat(i.header) print(x$hmodel$initprobs) if (any(x$hmodel$nicovs > 0)) { ic.header <- "Covariates on logit initial state probabilities\n" cat("\n"); cat(ic.header) print(x$hmodel$icoveffect) } } } else if (x$hmodel$hidden && (is.null(x$hmodel$phase.only) || !x$hmodel$phase.only)){ cat("\n") print(x$hmodel) } if (!is.null(x$qmodel$phase.states)) { cat("\nPhase-type model\n") print(phasemeans.msm(x)) } } } cat ("\n-2 * log-likelihood: ", x$minus2loglik, "\n") cat("[Note, to obtain old print format, use \"printold.msm\"]\n",sep="") invisible(ret) } printnew.msm <- print.msm summary.msm <- function(object, # fitted model hazard.scale = 1, ... ) { if (!inherits(object, "msm")) stop("expected object to be a msm model") prevalences <- prevalence.msm(object, ...) if (object$qcmodel$ncovs > 0) { if (missing (hazard.scale)) hazard.scale <- rep(1, object$qcmodel$ncovs) hazard <- hazard.msm(object) } else {hazard <- hazard.scale <- NULL} ret <- list(prevalences=prevalences, hazard=hazard, hazard.scale=hazard.scale) class(ret) <- "summary.msm" ret } print.summary.msm <- function(x,...) { if (!is.null(x$prevalences)) { cat("\nObserved numbers of individuals occupying states at each time\n\n") print(x$prevalences$Observed) cat("\nExpected numbers of individuals occupying states at each time\n\n") print(x$prevalences$Expected) cat("\nObserved prevalences of states (percentages of population at risk)\n\n") print(x$prevalences$"Observed percentages") cat("\nExpected prevalences of states (percentages of population at risk)\n\n") print(x$prevalences$"Expected percentages") } i <- 1 for (cov in names(x$hazard)) { cat ("\nTransition hazard ratios corresponding to covariate effects\n\n" ) cat (cov, " ( unit of",x$hazard.scale[i],")\n") print(round(x$hazard[[cov]], 2)) i <- i+1 } invisible() } ### Estimated survival probability from each state plot.msm <- function(x, from=NULL, to=NULL, range=NULL, covariates="mean", legend.pos=NULL, xlab="Time", ylab="Fitted survival probability", lwd=1,...) { if (!inherits(x, "msm")) stop("expected x to be a msm model") if (is.null(from)) from <- transient.msm(x) else { if (!is.numeric(from)) stop("from must be numeric") if (any (! (from %in% 1:x$qmodel$nstates ) ) ) stop("from must be a vector of states in 1, ..., ", x$qmodel$nstates) } if (is.null(to)) to <- max(absorbing.msm(x)) else { if (!is.numeric(to)) stop("to must be numeric") if (! (to %in% absorbing.msm(x) ) ) stop("to must be an absorbing state") } if (is.null(range)) rg <- range(model.extract(x$data$mf, "time")) else { if (!is.numeric(range) || length(range)!= 2) stop("range must be a numeric vector of two elements") rg <- range } timediff <- (rg[2] - rg[1]) / 50 times <- seq(rg[1], rg[2], timediff) pr <- numeric() cols <- rainbow(length(from)) for (t in times) pr <- c(pr, pmatrix.msm(x, t, times[1], covariates)[from[1], to]) plot(times, 1 - pr, type="l", xlab=xlab, ylab=ylab, lwd=lwd, ylim=c(0,1), lty = 1, col=cols[1],...) lt <- 2 for (st in from[-1]){ pr <- numeric() for (t in times) pr <- c(pr, pmatrix.msm(x, t, times[1], covariates)[st, to]) lines(times, 1 - pr, type="l", lty = lt, lwd=lwd, col=cols[lt],...) lt <- lt+1 } if (!is.numeric(legend.pos) || length(legend.pos) != 2) legend.pos <- c(max(times) - 15*timediff, 1) legend(legend.pos[1], legend.pos[2], legend=paste("From state",from), lty = seq(lt-1), col=cols, lwd=lwd) invisible() } ### Plot KM estimate of time to first occurrence of each state plotprog.msm <- function(formula, subject, data, legend.pos=NULL, xlab="Time", ylab="1 - incidence probability", lwd=1, xlim=NULL, mark.time=TRUE, ...) { data <- na.omit(data) mf <- model.frame(formula, data=data) state <- mf[,1] time <- mf[,2] if (!is.null(data)) subject <- eval(substitute(subject), as.list(data), parent.frame()) subject <- match(subject, unique(subject)) rg <- range(time) if (is.null(xlim)) xlim=rg plot(0, xlim=xlim, ylim=c(0,1), type="n", xlab=xlab, ylab=ylab, ...) states <- sort(unique(state))[-1] cols <- rainbow(length(states)) for (i in states) { dat <- cbind(subject, time, state) st <- as.data.frame( do.call("rbind", by(dat, subject, function(x) { c(anystate = if(any(x[,"state"]>=i)) 1 else 0, mintime = if(any(x[,"state"]>=i)) min(x[x[,"state"] >= i, "time"]) else max(x[,"time"])) } ))) # slow lines(survfit(Surv(st$mintime,st$anystate) ~ 1), col=cols[i-1], lty=i-1, lwd=lwd, mark.time=mark.time, ...) } timediff <- (rg[2] - rg[1]) / 50 if (!is.numeric(legend.pos) || length(legend.pos) != 2) legend.pos <- c(max(time) - 25*timediff, 1) legend(legend.pos[1], legend.pos[2], lty=states-1, lwd=lwd, col=cols, legend=paste("To state", states, c(rep("or greater", length(states)-1), ""))) invisible() } ### Likelihood surface plots surface.msm <- function(x, params=c(1,2), np=10, type=c("contour","filled.contour","persp","image"), point=NULL, xrange=NULL, yrange=NULL,...) { type <- match.arg(type) if (is.null(point)) point <- x$paramdata$opt$par se <- sqrt(diag(x$covmat[x$paramdata$optpars,x$paramdata$optpars])) i1 <- params[1]; i2 <- params[2] if (is.null(xrange)) { pmin <- point[i1] - 2*se[i1] pmax <- point[i1] + 2*se[i1] p1 <- seq(pmin, pmax, length=np) } else p1 <- seq(xrange[1], xrange[2], length=np) if (is.null(yrange)){ pmin <- point[i2] - 2*se[i2] pmax <- point[i2] + 2*se[i2] p2 <- seq(pmin, pmax, length=np) } else p2 <- seq(yrange[1], yrange[2], length=np) z <- matrix(nrow=np, ncol=np) for (i in 1:np) { for (j in 1:np) { point[i1] <- p1[i]; point[i2] <- p2[j] z[i,j] <- -0.5*Ccall.msm(point, "lik", expand.data(x), x$qmodel, x$qcmodel, x$cmodel, x$hmodel, x$paramdata) } } switch(type, contour = contour(p1, p2, z, ...), filled.contour = filled.contour(p1, p2, z, ...), image = image(p1, p2, z, ...), persp = persp(p1, p2, z, zlab="Log-likelihood",...) ) invisible() } contour.msm <- function(x, ...) { surface.msm(x, type="contour",...) } persp.msm <- function(x, ...) { surface.msm(x, type="persp",...) } image.msm <- function(x, ...) { surface.msm(x, type="image",...) } ### Given a "covariates" argument of an extractor function containing ### covariates which interact in the model, form the corresponding ### "covariates" argument with the interactions expanded. expand.interactions.msm <- function(covariates, covlabels){ cn.nointer <- names(covariates) elist <- strsplit(covlabels, ":") elist <- lapply(elist, function(x)covariates[x]) elist <- lapply(elist, function(x)prod(unlist(x))) names(elist) <- covlabels elist } print.msm.est <- function(x, digits=NULL, ...) { if (is.list(x)) print.ci(x$estimates, x$L, x$U, x$fixed, digits=digits) else print(unclass(x)) } print.msm.est.cols <- function(x, digits=NULL, diag=TRUE, ...) { inc <- if (diag) (x$estimates>0 | x$estimates<0) else (x$estimates>0) res <- cbind(x$estimates[inc], x$L[inc], x$U[inc]) rn <- rownames(x$estimates)[row(inc)[inc]] cn <- colnames(x$estimates)[col(inc)[inc]] rownames(res) <- paste(rn, cn, sep="-") colnames(res) <- c("Estimate", "LCL", "UCL") res } "[.msm.est" <- function(x, i, j, drop=FALSE){ Narg <- nargs() - (!missing(drop)) # number of args including x, excluding drop if ((missing(i) && missing(j))) res <- x else if (!is.list(x)) res <- unclass(x)[i,j] else { if (missing(j) && (Narg==2)) stop("Two dimensions must be supplied, found only one") if ("SE" %in% names(x)) { x <- array(unlist(x), dim=c(dim(x[[1]]),4)) dimnames(x) <- list(rownames(x[[1]]), colnames(x[[1]]), c("estimate","SE","lower","upper")) } else { x <- array(unlist(x), dim=c(dim(x[[1]]),3)) dimnames(x) <- list(rownames(x[[1]]), colnames(x[[1]]), c("estimate","lower","upper")) } res <- x[i,j,] } res } format.ci <- function(x, l, u, noci=NULL, digits=NULL, ...) { if (is.null(noci)) noci <- rep(FALSE, length(x)) if (is.null(digits)) digits <- 4 ## note format() aligns nicely on point, unlike formatC est <- format(x, digits=digits, ...) res <- est if (!is.null(l)) { low <- format(l[!noci], digits=digits, ...) upp <- format(u[!noci], digits=digits, ...) res[!noci] <- paste(res[!noci], " (", low, ",", upp, ")", sep="") res[x==0] <- 0 } else res <- est dim(res) <- dim(x) dimnames(res) <- dimnames(x) names(res) <- names(x) res } print.ci <- function(x, l, u, fixed=NULL, digits=NULL){ res <- format.ci(x, l, u, fixed, digits) print(res, quote=FALSE) } ### Work out CIs of initial state occupancy probabilities using normal simulation method initp.ci.msm <- function(paramdata, cl=0.95){ p <- paramdata Sig <- p$covmat[p$plabs%in%c("initp"),p$plabs%in%c("initp"),drop=FALSE] mu <- p$params[p$plabs%in%c("initp")] rr <- rmvnorm(10000, mu, Sig) initp.rep <- exp(rr) / (1 + rowSums(exp(rr))) p$ci[p$plabs=="initp",] <- t(apply(initp.rep, 2, quantile, c(0.5*(1-cl), 1 - 0.5*(1-cl)), na.rm=TRUE)) initp.rep <- 1 / (1 + rowSums(exp(rr))) p$ci[p$plabs=="initpbase",] <- quantile(initp.rep, c(0.5*(1-cl), 1 - 0.5*(1-cl))) p$ci[p$plabs=="initp0"] <- 0 p } ## Form a string, exp ( x1 1 + x2 (cov1 - covmean1) + x3 (cov2 - covmean2) + ... ) ## to be made into a formula for deltamethod. ## Also return indices of estimates and covariance matrix output from optim() to use ## to inform deltamethod expsum.formstr <- function(nir, inds, cur.i, ni, nc, coefs) { formstr <- character(nir) parinds <- numeric() for (j in (cur.i : (cur.i + nir - 1))) { indj <- seq(j, (nc * ni + j), ni) parinds <- c(parinds, inds[indj]) # first 1 5 7, then 2 5 7 } ## e.g. parinds = 1 5 7 2 5 7 becomes xinds = 1 3 4 2 3 4 parinds2 <- sort(unique(parinds)) xinds <- rank(parinds2)[match(parinds, parinds2)] for (j in 1:nir) formstr[j] <- expsum(xinds[1:(nc+1) + (j-1)*(nc+1)], coefs) list(formstr=formstr, parinds=parinds, parinds2=parinds2) } ## Form a string, exp ( x1 1 + x2 (cov1 - covmean1) + x3 (cov2 - covmean2) + ... ) ## to be made into a formula for deltamethod expsum <- function(inds, coefs) { xseq <- paste("x", inds, sep="") inprod <- paste(paste(coefs, xseq, sep="*"), collapse=" + ") paste("exp(", inprod, ")", sep="") } lsum <- function(inds, coefs) { xseq <- paste("x", inds, sep="") paste(paste(coefs, xseq, sep="*"), collapse=" + ") } ### Extract a ratio of transition intensities at given covariate values qratio.msm <- function(x, ind1, ind2, covariates = "mean", ci=c("delta","normal","bootstrap","none"), cl=0.95, B=1000, cores=NULL) { q <- qmatrix.msm(x, covariates, ci="none") if (!is.numeric(ind1) || length(ind1) != 2 || !is.numeric(ind2) || length(ind2) != 2) stop("ind1 and ind2 must be numeric vectors of length 2") if (any (! (ind1 %in% 1 : x$qmodel$nstates)) | any (! (ind2 %in% 1 : x$qmodel$nstates) ) ) stop("ind1 and ind2 must be pairs of states in 1, ..., ", x$qmodel$nstates) if ((cl < 0) || (cl > 1)) stop("expected cl in [0,1]") if (q[ind2[1], ind2[2]] == 0) stop (paste("Denominator q[",ind2[1],",",ind2[2],"", "] is zero\n", sep="")) else if (q[ind1[1], ind1[2]] == 0) { warning(paste ("Numerator q[",ind1[1],",",ind1[2],"", "] is zero\n", sep="")) estimate <- se <- 0 } else { estimate <- q[ind1[1], ind1[2]] / q[ind2[1], ind2[2]] ci <- match.arg(ci) if (x$foundse && (ci != "none")) { if (ci == "delta") { se <- qratio.se.msm(x, ind1, ind2, covariates, cl)$se lse <- qratio.se.msm(x, ind1, ind2, covariates, cl)$lse L <- exp ( log(abs(estimate)) - sign(estimate)*qnorm(1 - 0.5*(1 - cl)) * lse ) * sign(estimate) U <- exp ( log(abs(estimate)) + sign(estimate)*qnorm(1 - 0.5*(1 - cl)) * lse ) * sign(estimate) } else if (ci=="normal") { q.ci <- qratio.normci.msm(x, ind1, ind2, covariates, cl, B) L <- q.ci[1]; U <- q.ci[2]; se=q.ci[3] } else if (ci=="bootstrap") { q.ci <- qratio.ci.msm(x, ind1, ind2, covariates, cl, B, cores) L <- q.ci[1]; U <- q.ci[2]; se=q.ci[3] } } else {se <- L <- U <- NULL} } c(estimate=estimate, se=se, L=L, U=U) } ### Extract the transition probability matrix at given covariate values pmatrix.msm <- function(x=NULL, # fitted msm model t = 1, # time interval t1 = 0, # start time for pci models covariates = "mean", # covariate values to calculate transition matrix for ci=c("none","normal","bootstrap"), # calculate a confidence interval # using either simulation from asymptotic normal dist of MLEs, or bootstrap cl = 0.95, # width of symmetric confidence interval B = 1000, # number of bootstrap replicates or normal simulations cores=NULL, qmatrix=NULL, ... ) { if (!is.numeric(t) || (t < 0)) stop("t must be a positive number") if (!is.null(x)) { if (!inherits(x, "msm")) stop("expected x to be a msm model") if (is.null(x$pci)) { q <- qmatrix.msm(x, covariates, ci="none") p <- MatrixExp(q, t, ...) colnames(p) <- rownames(p) <- rownames(q) ci <- match.arg(ci) p.ci <- switch(ci, bootstrap = pmatrix.ci.msm(x=x, t=t, t1=t1, covariates=covariates, cl=cl, B=B, cores=cores), normal = pmatrix.normci.msm(x=x, t=t, t1=t1, covariates=covariates, cl=cl, B=B), none = NULL) res <- if (ci=="none") p else list(estimates = p, L=p.ci[,,1], U=p.ci[,,2]) } else { piecewise.covariates <- msm.fill.pci.covs(x, covariates) res <- pmatrix.piecewise.msm(x, t1, t1 + t, x$pci, piecewise.covariates, ci, cl, B, ...) } } else if (!is.null(qmatrix)){ res <- MatrixExp(qmatrix, t, ...) } else stop("Neither a fitted model nor a qmatrix supplied") class(res) <- "msm.est" res } ### Extract the transition probability matrix at given covariate values - where the Q matrix is piecewise-constant pmatrix.piecewise.msm <- function(x=NULL, # fitted msm model t1, # start time t2, # stop time times, # vector of cut points covariates, # list of lists of covariates, for (, times1], (times1, times2], ... # of length one greater than times ci=c("none","normal","bootstrap"), cl = 0.95, # width of symmetric confidence interval B = 1000, # number of bootstrap replicates or normal simulations cores=NULL, qlist=NULL, ... # arguments to pass to MatrixExp ) { if (!is.null(x)) { if (!inherits(x, "msm")) stop("expected x to be a msm model") } if (is.null(x) && is.null(qlist)) stop("Neither a fitted model nor a list of Q matrices have been supplied") x$pci <- NULL # to avoid infinite recursion when calling pmatrix.msm ## Input checks if (t2 < t1) stop("Stop time t2 should be greater than or equal to start time t1") if (!is.numeric(times) || is.unsorted(times)) stop("times should be a vector of numbers in increasing order") if (length(covariates) != length(times) + 1) stop("Number of covariate lists must be one greater than the number of cut points") if (length(times)==0) return(pmatrix.msm(x=x, t=t2-t1, t1=t1, covariates=covariates[[1]], ci=ci, cl=cl, B=B, qmatrix=qlist[[1]], ...)) ## Locate which intervals t1 and t2 fall in, as indices ind1, ind2 into "times". if (t1 <= times[1]) ind1 <- 1 else if (length(times)==1) ind1 <- 2 else { for (i in 2:length(times)) if ((t1 > times[i-1]) && (t1 <= times[i])) {ind1 <- i; break} if (t1 > times[i]) ind1 <- i+1 } if (t2 <= times[1]) ind2 <- 1 else if (length(times)==1) ind2 <- 2 else { for (i in 2:length(times)) if ((t2 > times[i-1]) && (t2 <= times[i])) {ind2 <- i; break} if (t2 > times[i]) ind2 <- i+1 } ## Calculate accumulated pmatrix ## Three cases: ind1, ind2 in the same interval if (ind1 == ind2) { P <- pmatrix.msm(x=x, t = t2 - t1, covariates=covariates[[ind1]], qmatrix=qlist[[ind1]], ...) } ## ind1, ind2 in successive intervals else if (ind2 == ind1 + 1) { P.start <- pmatrix.msm(x=x, t = times[ind1] - t1 , covariates=covariates[[ind1]], qmatrix=qlist[[ind1]], ...) P.end <- pmatrix.msm(x=x, t = t2 - times[ind2-1], covariates=covariates[[ind2]], qmatrix=qlist[[ind2]], ...) P <- P.start %*% P.end } ## ind1, ind2 separated by one or more whole intervals else { P.start <- pmatrix.msm(x=x, t = times[ind1] - t1, covariates=covariates[[ind1]], qmatrix=qlist[[ind1]], ...) P.end <- pmatrix.msm(x=x, t = t2 - times[ind2-1], covariates=covariates[[ind2]], qmatrix=qlist[[ind2]], ...) P.middle <- diag(x$qmodel$nstates) for (i in (ind1+1):(ind2-1)) { P.middle <- P.middle %*% pmatrix.msm(x=x, t = times[i] - times[i-1], covariates=covariates[[i]], qmatrix=qlist[[i]], ...) } P <- P.start %*% P.middle %*% P.end } ci <- if (!is.null(x)) match.arg(ci) else "none" P.ci <- switch(ci, bootstrap = pmatrix.piecewise.ci.msm(x=x, t1=t1, t2=t2, times=times, covariates=covariates, cl=cl, B=B, cores=cores), normal = pmatrix.piecewise.normci.msm(x=x, t1=t1, t2=t2, times=times, covariates=covariates, cl=cl, B=B), none = NULL) res <- if (ci=="none") P else list(estimates = P, L=P.ci[,,1], U=P.ci[,,2]) res } ### Extract the mean sojourn times for given covariate values sojourn.msm <- function(x, covariates = "mean", ci=c("delta","normal","bootstrap","none"), cl=0.95, B=1000) { qmatrix <- qmatrix.msm(x, covariates, sojourn=TRUE, ci=ci, cl=cl, B=B) sojstates <- (1 : x$qmodel$nstates) [transient.msm(x)] soj <- qmatrix$sojourn[sojstates] names (soj) <- rownames(x$qmodel$qmatrix)[sojstates] if (x$foundse && (ci != "none")){ sojse <- qmatrix$sojournSE[sojstates] sojl <- qmatrix$sojournL[sojstates] soju <- qmatrix$sojournU[sojstates] names(sojse) <- names(sojl) <- names(soju) <- names(soj) res <- data.frame(estimates=soj, SE=sojse, L=sojl, U=soju) } else res <- list(estimates=soj) res } ### Extract the probabilities of occupying each state next pnext.msm <- function(x, covariates="mean", ci=c("normal","bootstrap","delta","none"), cl=0.95, B=1000, cores=NULL) { ci <- match.arg(ci) Q <- qmatrix.msm(x, covariates, ci="none") pnext <- - Q / diag(Q) pnext[x$qmodel$imatrix==0] <- 0 p.ci <- array(0, dim=c(dim(pnext), 2)) if (x$foundse && (ci != "none")){ if (ci == "delta") { for (i in 1:x$qmodel$nstates) { for (j in 1:x$qmodel$nstates) { if (pnext[i,j] > 0) { se <- qratio.se.msm(x, c(i,j), c(i,i), covariates, cl)$se lse <- qratio.se.msm(x, c(i,j), c(i,i), covariates, cl)$lse p.ci[i,j,1] <- exp ( log(pnext[i,j]) - qnorm(1 - 0.5*(1 - cl)) * lse ) p.ci[i,j,2] <- exp ( log(pnext[i,j]) + qnorm(1 - 0.5*(1 - cl)) * lse ) } } } } else if (ci=="normal") p.ci <- pnext.normci.msm(x, covariates, cl, B) else if (ci=="bootstrap") p.ci <- pnext.ci.msm(x, covariates, cl, B, cores) res <- list(estimates=pnext, L=p.ci[,,1], U=p.ci[,,2]) } else res <- list(estimates=pnext) class(res) <- "msm.est" res } ### Extract the coefficients coef.msm <- function(object, ...) { if (!inherits(object, "msm")) stop("expected object to be a msm model") if (object$emodel$misc) object[c("Qmatrices", "Ematrices")] else object$Qmatrices } ### Extract the log-likelihood logLik.msm <- function(object, by.subject=FALSE, ...) { if (!inherits(object, "msm")) stop("expected object to be a msm model") if (by.subject){ p <- object$paramdata val <- -0.5*Ccall.msm(p$opt$par, do.what="lik.subj", expand.data(object), object$qmodel, object$qcmodel, object$cmodel, object$hmodel, p) names(val) <- unique(model.extract(object$data$mf, "subject")) } else { val <- - 0.5*object$minus2loglik attr(val, "df") <- object$paramdata$nopt class(val) <- "logLik" } val } ### Likelihood ratio test between two or more models lrtest.msm <- function(...){ mods <- list(...) if (length(mods) < 2) stop("Expected 2 or more models as arguments") lx <- logLik(mods[[1]]) res <- matrix(nrow=length(mods)-1, ncol=3) colnames(res) <- c("-2 log LR","df","p") rownames(res) <- sapply(as.list(match.call())[-(1:2)], deparse) for (i in 2:length(mods)) { if (!inherits(mods[[i]], "msm")) stop("Expected argument",i,"to be a msm object") ly <- logLik(mods[[i]]) lr <- as.numeric(-2 * (lx - ly)) df <- attr(ly,"df") - attr(lx,"df") res[i-1,] <- c(lr, df, 1 - pchisq(lr, df)) } res } ## Estimate total length of stay in a given state. totlos.msm <- function(x, start=1, end=NULL, fromt=0, tot=Inf, covariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, num.integ=FALSE, discount=0, env=FALSE, ci=c("none","normal","bootstrap"), # calculate a confidence interval cl = 0.95, # width of symmetric confidence interval B = 1000, # number of bootstrap replicates cores=NULL, ...) { if (!inherits(x, "msm")) stop("expected x to be a msm model") nst <- x$qmodel$nstates if (!is.numeric(start) || ((length(start)==1) && (! start %in% 1 : nst))) stop("start should be a state in 1, ..., ", nst, " or a vector of length ",nst) else if (length(start) == 1) {p0 <- rep(0, nst); p0[start] <- 1; start <- p0} else if (length(start) > 1) { if (length(start) != nst) stop("start should be a state in 1, ..., ", nst, " or a vector of length ",nst) } if (is.null(end)) end <- 1 : nst if (! all(end %in% 1 : nst)) stop("end should be a set of states in 1, ..., ", nst) if (!is.numeric(fromt) || !is.numeric(tot) || length(fromt) != 1 || length(tot) != 1 || fromt < 0 || tot < 0) stop("fromt and tot must be single non-negative numbers") if (fromt > tot) stop("tot must be greater than fromt") if (length(absorbing.msm(x)) == 0) if (tot==Inf) stop("Must specify a finite end time for a model with no absorbing state") ncuts <- length(piecewise.times) npieces <- length(piecewise.covariates) if (!is.null(piecewise.times) && (!is.numeric(piecewise.times) || is.unsorted(piecewise.times))) stop("piecewise.times should be a vector of numbers in increasing order") if (!is.null(piecewise.covariates) && (npieces != ncuts + 1)) stop("Number of piecewise.covariate lists must be one greater than the number of cut points") if (is.null(piecewise.covariates)) { ## define homogeneous model as piecewise with one piece npieces <- 1 covs <- list(covariates) ptimes <- c(fromt, tot) } else { ## ignore all cut points outside [fromt,tot] keep <- which((piecewise.times > fromt) & (piecewise.times < tot)) ## cov value between fromt and min(first cut, tot) cov1 <- piecewise.covariates[findInterval(fromt, piecewise.times) + 1] covs <- c(cov1, piecewise.covariates[keep+1]) npieces <- length(covs) ptimes <- c(fromt, piecewise.times[keep], tot) } tmat <- envmat <- matrix(nrow=npieces, ncol=nst) if (tot==Inf) { tmat[,absorbing.msm(x)] <- Inf # set by hand or else integrate() will fail envmat[,absorbing.msm(x)] <- 1 rem <- setdiff(seq_len(nst), absorbing.msm(x)) } else rem <- seq_len(nst) for (i in 1:npieces) { from.t <- ptimes[i] to.t <- ptimes[i+1] Q <- qmatrix.msm(x, covariates=covs[[i]], ci="none") if (num.integ || to.t==Inf){ for (j in rem){ f <- function(time) { y <- numeric(length(time)) for (k in seq(along=y)) y[k] <- (start %*% pmatrix.msm(x, time[k], t1=0, covariates=covs[[i]], ci="none")) [j] y } tmat[i,j] <- integrate(f, from.t, to.t, ...)$value } } else { QQ <- rbind(c(0, start), cbind(rep(0,nst), Q - discount*diag(nst))) tmat[i,] <- as.vector(c(1, rep(0, nst)) %*% (MatrixExp(to.t*QQ) - MatrixExp(from.t*QQ)) %*% rbind(rep(0, nst), diag(nst))) } Q0 <- Q; diag(Q0) <- 0 envmat[i,rem] <- tmat[i,rem] %*% Q0[rem,rem] } res <- if (env) colSums(envmat) else colSums(tmat) names(res) <- rownames(x$qmodel$qmatrix) ci <- match.arg(ci) t.ci <- switch(ci, bootstrap = totlos.ci.msm(x=x, start=start, end=end, fromt=fromt, tot=tot, covariates=covariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, discount=discount, env=env, cl=cl, B=B, cores=cores, ...), normal = totlos.normci.msm(x=x, start=start, end=end, fromt=fromt, tot=tot, covariates=covariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, discount=discount, env=env, cl=cl, B=B, ...), none = NULL) if (ci=="none") res[end] else rbind(res, t.ci)[,end] } ## Expected number of visits envisits.msm <- function(x=NULL, start=1, end=NULL, fromt=0, tot=Inf, covariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, num.integ=FALSE, discount=0, ci=c("none","normal","bootstrap"), # calculate a confidence interval cl = 0.95, # width of symmetric confidence interval B = 1000, # number of bootstrap replicates cores=NULL, ...) { totlos.msm(x=x, start=start, end=end, fromt=fromt, tot=tot, covariates=covariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, num.integ=num.integ, discount=discount, env=TRUE, ci=ci, cl=cl, B=B, cores=cores, ...) } ## Return indices of transient states (can either call for a fitted model or a qmatrix) transient.msm <- function(x=NULL, qmatrix=NULL) { if (!is.null(x)) { if (!inherits(x, "msm")) stop("expected x to be a msm model") qmatrix <- x$Qmatrices[[1]] nst <- x$qmodel$nstates } else if (!is.null(qmatrix)) { nst <- nrow(qmatrix) } else stop("Neither a fitted msm model nor a qmatrix have been supplied") which(diag(msm.fixdiag.qmatrix(qmatrix)) != 0) } ## Return indices of absorbing states (can either call for a fitted model or a qmatrix) absorbing.msm <- function(x=NULL, qmatrix=NULL) { if (!is.null(x)) { if (!inherits(x, "msm")) stop("expected x to be a msm model") qmatrix <- x$Qmatrices[[1]] nst <- x$qmodel$nstates } else if (!is.null(qmatrix)) { nst <- nrow(qmatrix) } else stop("Neither a fitted msm model nor a qmatrix have been supplied") which(diag(msm.fixdiag.qmatrix(qmatrix)) == 0) } ## Return two-column matrix containing pairs of states with allowed ## transitions in an interval. Handles transitions between observed ## states in misclassification models intervaltrans.msm <- function(x=NULL, qmatrix=NULL, ematrix=NULL, exclude.absabs=FALSE, censor=FALSE) { if (!is.null(x)) { if (!inherits(x, "msm")) stop("expected x to be a msm model") qmatrix <- qmatrix.msm(x, ci="none") if (is.null(ematrix) & x$emodel$misc) ematrix <- ematrix.msm(x, ci="none") > 0 abs <- absorbing.msm(x) } else if (!is.null(qmatrix)) { abs <- absorbing.msm(qmatrix=qmatrix) } else if (is.null(qmatrix)) stop("Neither a fitted msm model nor a qmatrix have been supplied") P <- MatrixExp(qmatrix) if (!is.null(ematrix)) P <- t(ematrix) %*% P %*% ematrix # > 0 iff P(obs state=s | prev obs state = r) > 0 ## P(obs state = s | obs prev = r) = Sum_ij P(obsst = s | truest = j) P(truest = j | trueprev = i) P(trueprev = i | obsprev = r) ## Sum_ij Ejs Pij Eir = Eir Pij Ejs gt0 <- abs(P) > .Machine$double.eps ^ 0.5 at <- cbind(row(P)[gt0], col(P)[gt0]) if (exclude.absabs) at <- at[!(at[,1] %in% abs & at[,2] %in% abs),] if (censor && x$cmodel$ncens > 0) { # consider censoring as separate state atcens.all <- numeric() for (i in 1:x$cmodel$ncens) { truestates <- x$cmodel$states[x$cmodel$index[i] : (x$cmodel$index[i+1] - 1)] atcens <- at[at[,2] %in% truestates,] atcens[,2] <- 99 atcens <- unique(atcens) atcens.all <- rbind(atcens.all, atcens) } at <- rbind(at, atcens.all) } at[order(at[,1],at[,2]),] } ## Enumerate the distinct subject covariate histories in the data ## Works for time homogeneous and inhomogeneous models ## Used to calculate expected prevalences for a population with those covariates get.covhist <- function(x, subset=NULL) { ## Keep only times where the covariate changes, or first or last obs mf <- x$data$mf if (x$qcmodel$ncovs > 0) { if (!is.null(subset)) { subs <- mf$"(subject)" %in% subset mf <- mf[subs,,drop=FALSE] } n <- length(mf$"(subject)") apaste <- do.call("paste", mf[,attr(mf,"covnames"),drop=FALSE]) first <- !duplicated(mf$"(subject)"); last <- rev(!duplicated(rev(mf$"(subject)"))) keep <- (c(0, apaste[1:(n-1)]) != apaste) | first | last ## Keep and tabulate unique covariate series covseries <- split(apaste[keep], mf$"(subject)"[keep]) # as a list of char vectors covseries <- sapply(covseries, paste, collapse=" , ") # as one char vector, one series per pt. ## also need p matrices for different times as well as different covs. ## but only interested in cov change times if there's more than one ## transition (at least one times change point) change.times <- mf$"(time)"; change.times[first] <- change.times[last] <- 0 change.times <- split(change.times[keep & (!(first|last))], mf$"(subject)"[keep & (!(first|last))]) change.times <- sapply(change.times, paste, collapse= " , ") covseries.t <- paste(covseries, change.times, sep="; ") ids <- unique(mf$"(subject)")[!duplicated(covseries.t)] # subj ids, one with each distinct series ncombs <- table(covseries.t)[unique(covseries.t)]# how many per series covmat <- cbind(subject=mf$"(subject)", time=mf$"(time)", mf[,attr(mf,"covnames"),drop=FALSE]) covmat <- covmat[(mf$"(subject)" %in% ids) & keep,] list(example=covmat, # rows of the original data sufficient to define the distinct histories hist=covseries.t) # one per subject listing their covariate history as a string } else NULL } ### Estimate observed state occupancies in the data at a series of times ### Assume previous observed state is retained until next observation time ### Assumes times are sorted within patient (they are in data in msm objects) observed.msm <- function(x, times=NULL, interp=c("start","midpoint"), censtime=Inf, subset=NULL) { if (!inherits(x, "msm")) stop("expected x to be a msm model") ## For general HMMs use the Viterbi estimate of the observed state. if (!is.null(x$pci)) { state <- x$data$mf$"(state)"[!x$data$mf$"(pci.imp)"] time <- x$data$mf$"(time)"[!x$data$mf$"(pci.imp)"] subject <- x$data$mf$"(subject)"[!x$data$mf$"(pci.imp)"] } else { state <- if ((x$hmodel$hidden && !x$emodel$misc) || (!x$hmodel$hidden && x$cmodel$ncens>0) ) viterbi.msm(x)$fitted else x$data$mf$"(state)" time <- x$data$mf$"(time)"; subject <- x$data$mf$"(subject)" } if (is.null(subset)) subset <- unique(subject) time <- time[subject %in% subset] state <- state[subject %in% subset] subject <- subject[subject %in% subset] ## fixme subj char/factor? if (is.null(times)) times <- seq(min(time), max(time), (max(time) - min(time))/10) states.expand <- matrix(nrow=length(unique(subject)), ncol=length(times)) pts <- unique(subject) absorb <- absorbing.msm(x) interp <- match.arg(interp) if (!is.numeric(censtime)) stop("censtime should be numeric") if (length(censtime)==1) censtime <- rep(censtime, length(pts)) else if (length(censtime)!=length(pts)) stop("censtime of length ", length(censtime), ", should be 1 or ", length(pts)) for (i in seq(along=pts)){ state.i <- state[(subject==pts[i])] time.i <- time[(subject==pts[i])] j <- 1 while(j <= length(times)) { if (times[j] < time.i[1]) { mtime <- max(which(times-time.i[1] < 0)) states.expand[i, j:mtime] <- NA j <- mtime + 1 next; } else if (times[j] > time.i[length(time.i)]) { if (state.i[length(time.i)] %in% absorb && (times[j] <= censtime[i])) { states.expand[i, j:(length(times))] <- state.i[length(time.i)] } else states.expand[i, j:(length(times))] <- NA break; } else { prevtime.ind <- max(which(time.i <= times[j])) prevtime <- time.i[prevtime.ind] if (interp=="midpoint") { nexttime.ind <- min(which(time.i >= times[j])) nexttime <- time.i[nexttime.ind] midpoint <- (prevtime + nexttime) / 2 states.expand[i,j] <- state.i[if (times[j] <= midpoint) prevtime.ind else nexttime.ind] } else states.expand[i,j] <- state.i[prevtime.ind] } j <- j+1 } } obstab <- t(apply(states.expand, 2, function(y) table(factor(y, levels=seq(length=x$qmodel$nstates))))) obsperc <- 100*obstab / rep(rowSums(obstab), ncol(obstab)) dimnames(obstab) <- dimnames(obsperc) <- list(times, paste("State", 1:x$qmodel$nstates)) obstab <- cbind(obstab, Total=rowSums(obstab)) covhist <- get.covhist(x, subset) covcat <- ## distinct covariate history group each subject falls into (ordinal) if (is.null(covhist)) rep(1, length(unique(subject))) else match(covhist$hist, unique(covhist$hist)) risk <- matrix(nrow=length(times), ncol=length(unique(covcat)), dimnames = list(times, unique(covhist$hist))) for (i in seq(along=unique(covcat))) { obst <- t(apply(states.expand[covcat==unique(covcat)[i],,drop=FALSE], 2, function(y) table(factor(y, levels=seq(length=x$qmodel$nstates))))) risk[,i] <- rowSums(obst) } list(obstab=obstab, obsperc=obsperc, risk=risk) } ### TODO cleaner observed.msm. Works for interp=start. ### TODO debug midpoint. apply censoring times ## times <- seq(0, 2, 0.5) ## dat <- data.frame(time=msm_export_r$fu_year, state=msm_export_r$state3) ## pt <- msm_export_r$ptid ## nstates <- 3 ## trans <- c(1,2) # transient states ## if (interp=="midpoint"){ ## t <- dat$time; n <- length(t) ## t[duplicated(pt)] <- ((t + t[c(1, 1:(n-1))])/2)[duplicated(pt)] ## dat$time <- t ## } ## spl <- split(dat, pt) ## ## findInterval returns 0 if before first time. ## st <- sapply(spl, function(x){y <- findInterval(times, x$time) ## y[y==0] <- NA ## res <- x$state[y] ## res[(y==length(x$time)) & (res %in% trans)] <- NA ## res ## }) ## obstab <- t(apply(st, 1, function(x){table(factor(na.omit(x), levels=1:nstates))})) ## observed.msm(pap.msm.noskip, times=times) ## observed.msm(pap.msm.noskip, times=times, interp="midpoint") expected.msm <- function(x, times=NULL, timezero=NULL, initstates=NULL, covariates="population", misccovariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, risk=NULL, subset=NULL, ci=c("none","normal","bootstrap"), cl = 0.95, B = 1000, cores = NULL ) { if (!inherits(x, "msm")) stop("expected x to be a msm model") time <- model.extract(x$data$mf, "time") if (is.null(times)) times <- seq(min(time), max(time), (max(time) - min(time))/10) if (is.null(timezero)) timezero <- min(time) if (is.null(risk)) risk <- observed.msm(x, times=times, subset=subset)$risk exptab <- matrix(0, nrow=length(times), ncol=x$qmodel$nstates) start <- min(which(times - timezero >= 0)) if (x$emodel$misc) initprobs <- x$emodel$initprobs else { if (is.null(initstates)) initstates <- observed.msm(x, times=timezero)$obstab[1:x$qmodel$nstates] initprobs <- initstates / sum(initstates) } if (length(times) >= start) { for (j in start:length(times)) { if (x$qcmodel$ncovs>0 && covariates=="population") { covmat <- get.covhist(x, subset=subset)$example for (i in 1:length(unique(covmat$subject))) { ## sum expected prevalences for each covariate history observed in the data subji <- unique(covmat$subject)[i] ni <- sum(covmat$subject==subji) ctimes <- covmat$time[covmat$subject==subji][-c(1,ni)] covs <- covmat[covmat$subject==subji, attr(x$data$mf,"covnames"),drop=FALSE][-ni,,drop=FALSE] ccovs <- list() for (k in 1:nrow(covs)) ccovs[[k]] <- as.list(covs[k,,drop=FALSE]) pmat <- pmatrix.piecewise.msm(x, t1=timezero, t2=times[j], times=ctimes, covariates=ccovs) expji <- risk[j,i] * initprobs %*% pmat if (x$emodel$misc) { # return expected prev of obs (not true) states if (x$ecmodel$ncovs==0) emat <- ematrix.msm(x, ci="none") else { ecovs <- if(length(ctimes)==0) ccovs else ccovs[[length(ccovs)]] emat <- ematrix.msm(x, covariates=ecovs, ci="none") } expji <- expji %*% emat } exptab[j,] <- exptab[j,] + expji } } else { pmat <- if (is.null(piecewise.times)) pmatrix.msm(x, t=times[j] - timezero, t1=timezero, covariates=covariates) else pmatrix.piecewise.msm(x, timezero, times[j], piecewise.times, piecewise.covariates) expj <- rowSums(risk)[j] * initprobs %*% pmat if (x$emodel$misc) # return expected prev of obs (not true) states expj <- expj %*% ematrix.msm(x, covariates=misccovariates, ci="none") exptab[j,] <- expj } } } exptab <- cbind(exptab, apply(exptab, 1, sum)) dimnames(exptab) <- list(times, c(rownames(x$qmodel$qmatrix),"Total")) expperc <- 100*exptab[,1:x$qmodel$nstates] / exptab[, x$qmodel$nstates+1] ci <- match.arg(ci) e.ci <- switch(ci, bootstrap = expected.ci.msm(x, times, timezero, initstates, covariates, misccovariates, piecewise.times, piecewise.covariates, risk, cl, B, cores), normal = expected.normci.msm(x, times, timezero, initstates, covariates, misccovariates, piecewise.times, piecewise.covariates, risk, cl, B), none = NULL) res <- if (ci=="none") list(exptab=exptab, expperc=expperc) else list(exptab=list(estimates=exptab, ci=e.ci[[1]]), expperc=list(estimates=expperc, ci=e.ci[[2]])) names(res) <- c("Expected","Expected percentages") res } ### Table of observed and expected prevalences (works for misclassification and non-misclassification models) prevalence.msm <- function(x, times=NULL, timezero=NULL, initstates=NULL, covariates="population", misccovariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, ci=c("none","normal","bootstrap"), cl = 0.95, B = 1000, cores = NULL, interp=c("start","midpoint"), censtime=Inf, subset=NULL, plot = FALSE, ... ) { if (!inherits(x, "msm")) stop("expected x to be a msm model") ## Estimate observed state occupancies in the data at a series of times time <- model.extract(x$data$mf, "time") if (is.null(times)) times <- seq(min(time), max(time), (max(time) - min(time))/10) obs <- observed.msm(x, times, interp, censtime, subset) ## Work out expected state occupancies by forecasting from transition probabilities expec <- expected.msm(x, times, timezero, initstates, covariates, misccovariates, piecewise.times, piecewise.covariates, obs$risk, subset, ci, cl, B, cores) res <- list(observed=obs$obstab, expected=expec[[1]], obsperc=obs$obsperc, expperc=expec[[2]]) names(res) <- c("Observed", "Expected", "Observed percentages", "Expected percentages") if (plot) plot.prevalence.msm(x, mintime=min(times), maxtime=max(times), timezero=timezero, initstates=initstates, interp=interp, censtime=censtime, covariates=covariates, misccovariates=misccovariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, ...) res } plot.prevalence.msm <- function(x, mintime=NULL, maxtime=NULL, timezero=NULL, initstates=NULL, interp=c("start","midpoint"), censtime=Inf, subset=NULL, covariates="population", misccovariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, xlab="Times",ylab="Prevalence (%)", lwd.obs=1, lwd.exp=1, lty.obs=1, lty.exp=2, col.obs="blue", col.exp="red", legend.pos=NULL,...){ if (!inherits(x, "msm")) stop("expected x to be a msm model") time <- model.extract(x$data$mf, "time") if (is.null(mintime)) mintime <- min(time) if (is.null(maxtime)) maxtime <- max(time) t <- seq(mintime, maxtime, length=100) obs <- observed.msm(x, t, interp, censtime, subset) expec <- expected.msm(x, t, timezero=timezero, initstates=initstates, covariates=covariates, misccovariates=misccovariates, piecewise.times=piecewise.times, piecewise.covariates=piecewise.covariates, risk=obs$risk, subset=subset, ci="none")[[2]] states <- seq(length=x$qmodel$nstates) S <- length(states) ncols <- ceiling(sqrt(S)) nrows <- if (floor(sqrt(S))^2 < S && S <= floor(sqrt(S))*ceiling(sqrt(S))) floor(sqrt(S)) else ceiling(sqrt(S)) par(mfrow=c(nrows, ncols)) for (i in states) { plot(t, obs$obsperc[,i], type="l", ylim=c(0, 100), xlab=xlab, ylab=ylab, lwd=lwd.obs, lty=lty.obs, col=col.obs, main=rownames(x$qmodel$qmatrix)[i],...) lines(t, expec[,i], lwd=lwd.exp, lty=lty.exp, col=col.exp) } if (!is.numeric(legend.pos) || length(legend.pos) != 2) legend.pos <- c(0.4*maxtime, 40) legend(x=legend.pos[1], y=legend.pos[2], legend=c("Observed","Expected"), lty=c(lty.obs,lty.exp), lwd=c(lwd.obs,lwd.exp), col=c(col.obs,col.exp)) invisible() } ### Empirical versus fitted survival curve ### For t, plot 1 - P(dead at t given plot.survfit.msm <- function(x, from=1, to=NULL, range=NULL, covariates="mean", interp=c("start","midpoint"), ci=c("none","normal","bootstrap"), B=100, legend.pos=NULL, xlab="Time", ylab="Survival probability", lty=1, lwd=1, col="red", lty.ci=2, lwd.ci=1, col.ci="red", mark.time=TRUE, col.surv="blue", lty.surv=2, lwd.surv=1, ...) { if (!inherits(x, "msm")) stop("expected x to be a msm model") if (is.null(to)) to <- max(absorbing.msm(x)) else { if (!is.numeric(to)) stop("to must be numeric") if (! (to %in% absorbing.msm(x) ) ) stop("to must be an absorbing state") } if (is.null(range)) rg <- range(model.extract(x$data$mf, "time")) else { if (!is.numeric(range) || length(range)!= 2) stop("range must be a numeric vector of two elements") rg <- range } interp <- match.arg(interp) ci <- match.arg(ci) timediff <- (rg[2] - rg[1]) / 50 times <- seq(rg[1], rg[2], timediff) pr <- lower <- upper <- numeric() for (t in times) { P <- pmatrix.msm(x, t, t1=times[1], covariates=covariates, ci=ci, B=B) if (ci != "none") { pr <- c(pr, P$estimates[from, to]) lower <- c(lower, P$L[from, to]) upper <- c(upper, P$U[from, to]) } else pr <- c(pr, P[from, to]) } plot(times, 1 - pr, type="l", xlab=xlab, ylab=ylab, lwd=lwd, ylim=c(0,1), lty = lty, col=col,...) if (ci != "none") { lines(times, 1 - lower, lty=lty.ci, col=col.ci, lwd=lwd.ci) lines(times, 1 - upper, lty=lty.ci, col=col.ci, lwd=lwd.ci) } dat <- x$data$mf[,c("(subject)", "(time)", "(state)")] st <- as.data.frame( do.call("rbind", by(dat, dat$"(subject)", function(x) { dind <- which(x[,"(state)"] == to) if(any(x[,"(state)"]==to)) mintime <- if(interp=="start") min(x[dind, "(time)"]) else 0.5 * (x[dind, "time"] + x[dind-1, "time"]) else mintime <- max(x[,"(time)"]) c(anystate = as.numeric(any(x[,"(state)"]==to)), mintime = mintime) } ))) # slow lines(survfit(Surv(st$mintime,st$anystate) ~ 1), mark.time=mark.time, col=col.surv, lty=lty.surv, lwd=lwd.surv,...) timediff <- (rg[2] - rg[1]) / 50 if (!is.numeric(legend.pos) || length(legend.pos) != 2) legend.pos <- c(max(x$data$mf$"(time)") - 25*timediff, 1) if (ci=="none") legend(legend.pos[1], legend.pos[2], lty=c(lty, lty.surv), lwd=c(lwd, lwd.surv), col=c(col, col.surv), legend=c("Fitted","Empirical")) else legend(legend.pos[1], legend.pos[2], lty=c(lty, lty.ci, lty.surv), lwd=c(lwd,lwd.ci, lwd.surv), col=c(col ,col.ci, col.surv), legend=c("Fitted","Fitted (confidence interval)", "Empirical")) invisible() } ### Obtain hazard ratios from estimated effects of covariates on log-transition rates hazard.msm <- function(x, hazard.scale = 1, cl = 0.95) { if (!inherits(x, "msm")) stop("expected x to be a msm model") if (length(hazard.scale) == 1) hazard.scale <- rep(hazard.scale, x$qcmodel$ncovs) if (length(hazard.scale) != x$qcmodel$ncovs) stop ("hazard.scale of length ", length(hazard.scale), ", expected ", x$qcmodel$ncovs) keep <- (x$qmodel$imatrix != 0) nst <- x$qmodel$nstates keepvec <- as.vector(t(keep)) fromlabs <- rep(rownames(keep), each=nst) [keepvec] tolabs <- rep(colnames(keep), nst) [keepvec] if (x$qcmodel$ncovs > 0) { haz.list <- list() if (x$foundse) { for (i in 1:x$qcmodel$ncovs) { cov <- x$qcmodel$covlabels[i] haz.rat <- t(exp(hazard.scale[i]*x$Qmatrices[[cov]]))[keepvec] LCL <- t(exp(hazard.scale[i]*(x$Qmatrices[[cov]] - qnorm(1 - 0.5*(1 - cl))*x$QmatricesSE[[cov]]) ))[keepvec] UCL <- t(exp(hazard.scale[i]*(x$Qmatrices[[cov]] + qnorm(1 - 0.5*(1 - cl))*x$QmatricesSE[[cov]]) ))[keepvec] haz.tab <- cbind(haz.rat, LCL, UCL) dimnames(haz.tab) <- list(paste(fromlabs, "-", tolabs), c("HR", "L", "U")) haz.list[[cov]] <- haz.tab } } else { for (i in 1:x$qcmodel$ncovs) { cov <- x$qcmodel$covlabels[i] haz.tab <- as.matrix(t(exp(hazard.scale[i]*x$Qmatrices[[cov]]))[keepvec]) dimnames(haz.tab) <- list(paste(fromlabs, "-", tolabs), "HR") haz.list[[cov]] <- haz.tab } } } else haz.list <- "No covariates on transition intensities" haz.list } ### Obtain odds ratios from estimated effects of covariates on logit-misclassification probabilities ### TODO - equivalent for general HMMs which presents cov effects on natural scale. odds.msm <- function(x, odds.scale = 1, cl = 0.95) { if (!inherits(x, "msm")) stop("expected x to be a msm model") if (!x$emodel$misc) stop("Requires a misclassification model specified with ematrix") if (length(odds.scale) == 1) odds.scale <- rep(odds.scale, x$ecmodel$ncovs) if (length(odds.scale) != x$ecmodel$ncovs) stop ("odds.scale of length ", length(odds.scale), ", expected ", x$ecmodel$ncovs) keep <- (x$emodel$imatrix != 0) nst <- x$qmodel$nstates keepvec <- as.vector(t(keep)) truelabs <- rep(rownames(keep), each=nst) [keepvec] obslabs <- rep(colnames(keep), nst) [keepvec] if (x$ecmodel$ncovs > 0) { odds.list <- list() if (x$foundse) { for (i in 1:x$ecmodel$ncovs) { cov <- x$ecmodel$covlabels[i] odds.rat <- t(exp(odds.scale[i]*x$Ematrices[[cov]]))[keepvec] LCL <- t(exp(odds.scale[i]*(x$Ematrices[[cov]] - qnorm(1 - 0.5*(1 - cl))*x$EmatricesSE[[cov]]) ))[keepvec] UCL <- t(exp(odds.scale[i]*(x$Ematrices[[cov]] + qnorm(1 - 0.5*(1 - cl))*x$EmatricesSE[[cov]]) ))[keepvec] odds.tab <- cbind(odds.rat, LCL, UCL) dimnames(odds.tab) <- list(paste("Obs", obslabs, "|", truelabs), c("OR", "L", "U")) odds.list[[cov]] <- odds.tab } } else { for (i in 1:x$ecmodel$ncovs) { cov <- x$ecmodel$covlabels[i] odds.tab <- as.matrix(t(exp(odds.scale[i]*x$Ematrices[[cov]]))[keepvec]) dimnames(odds.tab) <- list(paste("Obs", obslabs, "|", truelabs), "OR") odds.list[[cov]] <- odds.tab } } } else odds.list <- "No covariates on misclassification probabilities" odds.list } viterbi.msm <- function(x) { if (!inherits(x, "msm")) stop("expected x to be a msm model") if (x$cmodel$ncens > 0 && !x$hmodel$hidden) { ## If censoring but not HMM, then define an identity HMM with ## true state known at every time except censoring times hmod <- vector(x$qmodel$nstates, mode="list") for (i in 1:x$qmodel$nstates) hmod[[i]] <- hmmIdent(i) x$hmodel <- msm.form.hmodel(hmod, est.initprobs=FALSE) x$hmodel <- c(x$hmodel, list(ncovs=rep(rep(0,x$hmodel$nstates),x$hmodel$npars), ncoveffs=0, nicovs=rep(0,x$hmodel$nstates-1), nicoveffs=0)) x$data$mf$"(obstrue)" <- ifelse(x$data$mf$"(state)" %in% x$cmodel$censor, 0, (x$data$mf$"(state)")) x$data$mm.hcov <- vector(mode="list", length=x$hmodel$nstates) # reqd by msm.add.hmmcovs for (i in seq_len(x$hmodel$nstates)) x$data$mm.hcov[[i]] <- model.matrix(~1, x$data$mf) x$paramdata$allinits <- c(x$paramdata$allinits,x$hmodel$pars) x$paramdata$constr <- c(x$paramdata$constr,max(x$paramdata$constr)+seq(along=x$hmodel$pars)) } if (x$hmodel$hidden) { ret <- Ccall.msm(x$paramdata$opt$par, do.what="viterbi", expand.data(x), x$qmodel, x$qcmodel, x$cmodel, x$hmodel, x$paramdata) fitted <- ret[[1]]; pstate <- ret[[2]] fitted <- fitted + 1 } else { fitted <- x$data$mf$"(state)" pstate <- NULL } if (!is.null(x$qmodel$phase.states)){ fitted <- x$qmodel$phase.labs[fitted] } ret <- data.frame(subject = x$data$mf$"(subject)", time = x$data$mf$"(time)", observed = x$data$mf$"(state)", fitted = fitted) if (!is.null(pstate)) ret$pstate <- pstate ret } scoreresid.msm <- function(x, plot=FALSE){ if (!inherits(x, "msm")) stop("expected x to be a msm model") if (!deriv.supported(x$data, x$hmodel, x$cmodel)) stop("Score residuals not available, since analytic derivatives not implemented for this model") derivs <- Ccall.msm(x$paramdata$opt$par, do.what="deriv.subj", expand.data(x), x$qmodel, x$qcmodel, x$cmodel, x$hmodel, x$paramdata) cov <- x$paramdata$covmat[x$paramdata$optpars,x$paramdata$optpars] sres <- colSums(t(derivs) * cov %*% t(derivs)) names(sres) <- unique(x$data$mf$"(subject)") if (plot) { plot(sres, type="n") text(seq(along=sres), sres, names(sres)) } sres } # Function to calculate expected first passage times for continuous-time Markov chain with arbitrary Q matrix # Returns vector with EFPT for each "from" state in the state space. # Could also get CDF simply by making tostate absorbing and calculating pmatrix. # TODO time-dependent covariates. Unclear if the expectation has a solution for piecewise-constant rate. efpt.msm <- function(x=NULL, qmatrix=NULL, tostate, start="all", covariates="mean", ci=c("none","normal","bootstrap"), cl = 0.95, B = 1000, cores=NULL, ...) { ci <- match.arg(ci) if (!is.null(x)) { if (!inherits(x, "msm")) stop("expected x to be a msm model") qmatrix <- qmatrix.msm(x, covariates=covariates, ci="none") } else if (!is.null(qmatrix)) { if (!is.matrix(qmatrix) || (nrow(qmatrix) != ncol(qmatrix))) stop("expected qmatrix to be a square matrix") if (ci != "none") {warning("No fitted model supplied: not calculating confidence intervals."); ci <- "none"} } if (is.character(tostate)) { if (!tostate %in% rownames(qmatrix)) stop(sprintf("state \"%s\" unknown", tostate)) tostate <- match(tostate, rownames(qmatrix)) } est <- rep(NA, nrow(qmatrix)) ## EFPT is zero if we're already in tostate est[tostate] <- 0 abstate <- absorbing.msm(qmatrix=qmatrix) ## EFPT is infinite for other absorbing states est[setdiff(abstate,tostate)] <- Inf fromstate <- setdiff(1:nrow(qmatrix), union(abstate,tostate)) ## EFPT is infinite if any chance of absorbing elsewhere before ## hitting tostate. To calculate this, form Q matrix with tostate ## made absorbing, and look at P matrix in unit time. Qred <- qmatrix; Qred[tostate,] <- 0 Pmat <- MatrixExp(Qred, ...) Pmat[Pmat < 1e-16] <- 0 p.abs <- rowSums(Pmat[fromstate,setdiff(abstate,tostate),drop=FALSE]) est[fromstate][p.abs>0] <- Inf ## Any states left from which EFPT to tostate is nonzero and finite. ## Use standard linear equation solution ## see, e.g. equation (3) of Harrison and Knottenbelt (2001) if (any(is.na(est))){ fromstate <- which(is.na(est)) Q <- as.matrix(qmatrix[fromstate, fromstate]) est[fromstate] <- solve(-Q, rep(1,nrow(Q))) } if (!is.character(start)) { if (!is.numeric(start) || (length(start)!=nrow(qmatrix))) stop("Expected \"start\" to be \"all\" or a numeric vector of length ", nrow(qmatrix)) start <- start / sum(start) est <- est %*% start } else if (any(start!="all")) stop("Expected \"start\" to be \"all\" or a numeric vector of length ", nrow(qmatrix)) e.ci <- switch(ci, bootstrap = efpt.ci.msm(x=x, qmatrix=qmatrix, tostate=tostate, start=start, covariates=covariates, cl=cl, B=B, cores=cores), normal = efpt.normci.msm(x=x, qmatrix=qmatrix, tostate=tostate, start=start, covariates=covariates, cl=cl, B=B), none = NULL) if (ci=="none") est else rbind(est, e.ci) } ## TODO time-inhomogeneous models. ## Do msm.fill.pci.covs to get covariate list ## Get list of Qs by calling qmatrix.msm for each member of this list ## Zero out the appropriate rows ## Supply this to pmatrix.piecewise.msm, which will call pmatrix.msm ppass.msm <- function(x=NULL, qmatrix=NULL, tot, start="all", covariates="mean", piecewise.times=NULL, piecewise.covariates=NULL, ci=c("none","normal","bootstrap"), cl = 0.95, B = 1000, cores=NULL, ...) { ci <- match.arg(ci) if (!is.null(x)) { if (!inherits(x, "msm")) stop("expected x to be a msm model") qmatrix <- qmatrix.msm(x, covariates=covariates, ci="none") } else if (!is.null(qmatrix)) { if (!is.matrix(qmatrix) || (nrow(qmatrix) != ncol(qmatrix))) stop("expected qmatrix to be a square matrix") if (ci != "none") {warning("No fitted model supplied: not calculating confidence intervals."); ci <- "none"} } res <- array(dim=dim(qmatrix)) if (!is.null(dimnames(qmatrix))) { dimnames(res) <- dimnames(qmatrix) names(dimnames(res)) <- c("from","to") } states <- 1:nrow(qmatrix) for (i in states) { Qred <- qmatrix; Qred[states[i],] <- 0 res[,i] <- MatrixExp(Qred*tot, ...)[,i] } if (!is.character(start)) { if (!is.numeric(start) || (length(start)!=nrow(qmatrix))) stop("Expected \"start\" to be \"all\" or a numeric vector of length ", nrow(qmatrix)) start <- start / sum(start) res <- matrix(start %*% res, nrow=1, dimnames=list(from="start",to=colnames(res))) } else if (any(start!="all")) stop("Expected \"start\" to be \"all\" or a numeric vector of length ", nrow(qmatrix)) p.ci <- switch(ci, bootstrap = ppass.ci.msm(x=x, qmatrix=qmatrix, tot=tot, start=start, covariates=covariates, cl=cl, B=B, cores=cores), normal = ppass.normci.msm(x=x, qmatrix=qmatrix, tot=tot, start=start, covariates=covariates, cl=cl, B=B), none = NULL) if (ci != "none") { res <- list(estimates=res, L=p.ci$L, U=p.ci$U) class(res) <- "msm.est" } res } msm/R/draic.R0000755000176200001440000003547712661621201012474 0ustar liggesusersdraic.msm <- function(msm.full,msm.coarse, likelihood.only=FALSE, information=c("expected", "observed"), tl=0.95 ) { if (!inherits(msm.full, "msm")) stop("Expected \"msm.full\" to be a msm model") if (!inherits(msm.coarse, "msm")) stop("Expected \"msm.coarse\" to be a msm model") if (msm.full$hmodel$hidden || msm.coarse$hmodel$hidden) stop("Hidden Markov models not supported") if (msm.full$cmodel$ncens > 0 || msm.coarse$cmodel$ncens >0) stop("Models with censoring not supported") ## Reconstruct datasets used to fit each model as dataframes. standard names will be bracketed. msm.full.data <- reconstruct.data(model.frame(msm.full)) msm.coarse.data <- reconstruct.data(model.frame(msm.coarse)) un <- attr(msm.full.data, "usernames") subj <- un["subject"]; st <- un["state"] unc <- attr(msm.coarse.data, "usernames") subjc <- unc["subject"]; stc <- unc["state"] if (nrow(msm.full.data) != nrow(msm.coarse.data)) stop("Full dataset has ",nrow(msm.full.data)," rows, but coarse dataset has ",nrow(msm.coarse.data)," rows, these should be equal.") ## Determine map from full to coarsened data coarsening.ematrix <- matrix(0,nrow=msm.full$qmodel$nstates, ncol=msm.full$qmodel$nstates) map <- unique(cbind(full=msm.full.data[,st], coarse=msm.coarse.data[,stc])) if (!all(tapply(map[,"coarse"], map[,"full"], function(x)length(unique(x)))==1)){ message("Observed the following state mappings in the data:") print(map); stop("Coarse state space not an aggregation of the the full state space") } coarsening.ematrix[map] <- 1 ## Could also check for compatible Q matrices, but would be fiddly, so don't bother ## Initial state occupancy probabilities, assumed equal across possible states initstate <- msm.full.data[,st][!duplicated(msm.full.data[,subj])] init.probs <- prop.table(table(factor(initstate, levels=1:msm.full$qmodel$nstates))) initp <- matrix(0, nrow=attr(msm.full.data,"npts"), ncol=msm.full$qmodel$nstates) for(i in 1:length(initstate)) { j<-coarsening.ematrix[initstate[i],]==1 initp[i,] <- init.probs * coarsening.ematrix[,j] initp[i,] <- initp[i,] / sum(initp[i,]) } ## Log-likelihood of complex model on restricted dataset lh.restricted.obj<-function(pars, by.subject=FALSE, return.model=FALSE) { p <- msm.full$estimates p[msm.full$paramdata$optpars] <- pars p[names(p)=="qbase"] <- exp(p[names(p)=="qbase"]) call <- msm.full$call ## name of state might be different in coarse data, assumes all other names same call$formula <- as.formula(paste(stc, "~", unc["time"])) call$data <- substitute(msm.coarse.data) call$ematrix <- coarsening.ematrix qmat <- t(msm.full$qmodel$imatrix) # Supply parameters as a vector for use in optimHess() qmat[qmat==1] <- p[names(p)=="qbase"] call$qmatrix <- t(qmat) call$covinits <- split(p[names(p)=="qcov"], rep(msm.full$qcmodel$covlabels, each=msm.full$qmodel$npars)) call$fixedpars <- TRUE call$initprobs <- initp res <- eval(call) if (return.model) res else as.numeric(logLik.msm(res, by.subject=by.subject)) } n <- attr(msm.full.data,"npts") mle <- msm.full$estimates[msm.full$paramdata$optpars] # handle models with some parameters fixed lsm <- lh.restricted.obj(mle) # Loglik of complex model on restricted data lmm <- logLik.msm(msm.full) # Complex model on full data lss <- logLik.msm(msm.coarse) # Simple model on restricted data dfit <- (1/n)*(lss - lsm) res.lik <- c("complex"=-lsm, "simple"=-lss, "complex-simple"=-(lsm-lss),"(complex-simple)/n"=dfit) if (!likelihood.only) { information <- match.arg(information) if (!all(msm.full$data$mf$"(obstype)" == 1)) information <- "observed" if (information=="observed") { ## Information matrix of complex model on complex data I.complex <- -0.5*(1/n)*msm.full$opt$hessian ## Information matrix of complex model on restricted data I.restricted <- (1/n)*optimHess(mle, lh.restricted.obj) } else { I.complex <- -0.5*(1/n)*msm.full$paramdata$information res <- lh.restricted.obj(mle, return.model=TRUE) ## simply using I <- res$paramdata$information doesn't work for models with some parameters fixed ## since call producing res unfixes these to produce derivs/info. ## so calculate information separately after keeping these fixed res$paramdata$optpars <- msm.full$paramdata$optpars res$paramdata$fixedpars <- c(msm.full$paramdata$fixedpars, res$paramdata$auxpars) I <- information.msm(res$paramdata$allinits[res$paramdata$optpars], expand.data(res), res$qmodel, res$qcmodel, res$cmodel, res$hmodel, res$paramdata) I.restricted <- -0.5*(1/n)*I } npars.restricted <- sum(diag(I.restricted %*% solve(I.complex))) dcompl <- (1/n)*(npars.restricted - msm.coarse$paramdata$npars) DRAIC <- dfit + dcompl ## Tracking interval. ## Difference in log-likelihoods on restricted data dlh <- lh.restricted.obj(mle, by.subject=TRUE) - logLik.msm(msm.coarse, by.subject=TRUE) omega.sq <- mean(dlh*dlh) - mean(dlh)^2 half.width <- qnorm(1 - 0.5*(1 - tl)) * sqrt(omega.sq / n) prob.DRAIC <- pnorm(-DRAIC / sqrt(omega.sq / n)) res.int <- c("2.5%"=DRAIC-half.width,"97.5%"=DRAIC+half.width,"Prob<0"=prob.DRAIC) if (!isTRUE(all.equal(tl,0.95))) names(res.int)[1:2] <- c("Lower","Upper") liks <- cbind("-LL" = res.lik, npars=c(npars.restricted, msm.coarse$paramdata$npars, npars.restricted - msm.coarse$paramdata$npars, dcompl)) res <- list(lik.restricted = liks, draic = as.numeric(DRAIC), ti=res.int) } else res <- res.lik res } drlcv.msm <- function(msm.full,msm.coarse,tl=0.95,cores=NULL,verbose=TRUE,outfile=NULL) { if (!inherits(msm.full, "msm")) stop("Expected \"msm.full\" to be a msm model") if (!inherits(msm.coarse, "msm")) stop("Expected \"msm.coarse\" to be a msm model") if (msm.full$hmodel$hidden || msm.coarse$hmodel$hidden) stop("Hidden Markov models not supported") if (msm.full$cmodel$ncens > 0 || msm.coarse$cmodel$ncens >0) stop("Models with censoring not supported") ## Reconstruct datasets used to fit each model as dataframes msm.full.data <- reconstruct.data(model.frame(msm.full)) msm.coarse.data <- reconstruct.data(model.frame(msm.coarse)) un <- attr(msm.full.data, "usernames") subj <- un["subject"]; st <- un["state"] unc <- attr(msm.coarse.data, "usernames") subjc <- unc["subject"]; stc <- unc["state"] if (nrow(msm.full.data) != nrow(msm.coarse.data)) stop("Full dataset has ",nrow(msm.full.data)," rows, but coarse dataset has ",nrow(msm.coarse.data)," rows, these should be equal.") ## Determine map from full to coarsened data coarsening.ematrix <- matrix(0,nrow=msm.full$qmodel$nstates, ncol=msm.full$qmodel$nstates) map <- unique(cbind(full=msm.full.data[,st], coarse=msm.coarse.data[,stc])) if (!all(tapply(map[,"coarse"], map[,"full"], function(x)length(unique(x)))==1)){ message("Observed the following state mappings in the data:") print(map); stop("Coarse state space not an aggregation of the the full state space") } coarsening.ematrix[map] <- 1 ## Initial state occupancy probabilities assumed equal across possible states initstate <- msm.full.data[,st][!duplicated(msm.full.data[,subj])] init.probs <- prop.table(table(factor(initstate, levels=1:msm.full$qmodel$nstates))) initp <- matrix(0, nrow=attr(msm.full.data,"npts"), ncol=msm.full$qmodel$nstates) for(i in 1:length(initstate)) { j<-coarsening.ematrix[initstate[i],]==1 initp[i,] <- init.probs * coarsening.ematrix[,j] initp[i,] <- initp[i,] / sum(initp[i,]) } ## Log-likelihood of complex model on restricted dataset call <- msm.full$call ## name of state might be different in coarse data, assumes all other names same call$formula <- as.formula(paste(stc, "~", unc["time"])) call$data <- substitute(msm.coarse.data) call$ematrix <- coarsening.ematrix call$qmatrix <- qmatrix.msm(msm.full, ci="none") # start it at the full MLE to help convergence call$covinits <- lapply(msm.full$Qmatrices[msm.full$qcmodel$covlabels], function(x){t(x)[msm.full$qmodel$imatrix==1]}) call$fixedpars <- TRUE call$initprobs <- initp msm.full.on.restricted <- eval(call) n <- attr(msm.full.data,"npts") lsm <- logLik.msm(msm.full.on.restricted) # Loglik of complex model on restricted data lmm <- logLik.msm(msm.full) # Complex model on full data lss <- logLik.msm(msm.coarse) # Simple model on restricted data ## Cross validation iteration for leaving out ith subject cv.fn <- function(i) { ## Refit small model after leaving one subject out call <- msm.coarse$call call$data <- msm.coarse.data[msm.coarse.data[,subjc] != unique(msm.coarse.data[,subjc])[i],] call$qmatrix <- qmatrix.msm(msm.coarse, ci="none") # start it at the full MLE to help convergence call$covinits <- lapply(msm.coarse$Qmatrices[msm.coarse$qcmodel$covlabels], function(x){t(x)[msm.coarse$qmodel$imatrix==1]}) res.coarse <- try(eval(call)) lssf <- as.numeric(logLik.msm(res.coarse)) ## Loglik of refitted model on left-out subject call$data <- msm.coarse.data[msm.coarse.data[,subjc] == unique(msm.coarse.data[,subjc])[i],] call$qmatrix <- qmatrix.msm(res.coarse, ci="none", covariates=0) call$center <- FALSE call$covinits <- lapply(res.coarse$Qmatrices[res.coarse$qcmodel$covlabels], function(x){t(x)[res.coarse$qmodel$imatrix==1]}) ## Workaround to avoid dropping unused levels and breaking model.matrix when factor() used around an existing factor in the data if (!is.null(call$covariates)){ call$covariates <- as.formula(gsub("factor\\((.+)\\)", "factor(\\1,levels=levels(\\1))", call$covariates)) names(call$covinits) <- gsub("factor\\((.+)\\)", "factor(\\1, levels = levels(\\1))", names(call$covinits)) } if (!is.null(call$constraint)) names(call$constraint) <- gsub("factor\\((.+)\\)", "factor(\\1, levels = levels(\\1))", names(call$constraint)) call$fixedpars <- TRUE res <- suppressWarnings(eval(call)) ## suppress warnings about state vector not containing observations of all states lss <- as.numeric(logLik.msm(res)) ## Refit big model after leaving one subject out. call <- msm.full$call call$data <- msm.full.data[msm.full.data[,subj] != unique(msm.full.data[,subj])[i],] call$qmatrix <- qmatrix.msm(msm.full, ci="none") # start it at the full MLE to help convergence call$covinits <- lapply(msm.full$Qmatrices[msm.full$qcmodel$covlabels], function(x){t(x)[msm.full$qmodel$imatrix==1]}) res.full <- try(eval(call)) lsmf <- as.numeric(logLik.msm(res.full)) ## Loglik of refitted model on left-out subject, using coarsened data call$formula <- as.formula(paste(stc, "~", unc["time"])) call$data <- msm.coarse.data[msm.coarse.data[,subjc] == unique(msm.coarse.data[,subjc])[i],] call$ematrix <- coarsening.ematrix call$qmatrix <- qmatrix.msm(res.full, ci="none", covariates=0) call$center <- FALSE call$covinits <- lapply(res.full$Qmatrices[res.full$qcmodel$covlabels], function(x){t(x)[res.full$qmodel$imatrix==1]}) if (!is.null(call$covariates)){ call$covariates <- as.formula(gsub("factor\\((.+)\\)", "factor(\\1,levels=levels(\\1))", call$covariates)) names(call$covinits) <- gsub("factor\\((.+)\\)", "factor(\\1, levels = levels(\\1))", names(call$covinits)) } if (!is.null(call$constraint)) names(call$constraint) <- gsub("factor\\((.+)\\)", "factor(\\1, levels = levels(\\1))", names(call$constraint)) call$initprobs <- initp[i,,drop=FALSE] call$fixedpars <- TRUE res <- eval(call) lsm <- as.numeric(logLik.msm(res)) conv <- ifelse(res.full$opt$convergence==0, "converged", "NOT CONVERGED") resc <- sprintf("i=%d, smallrest = %.12f, smalli = %.12f, bigrest = %.12f, bigi = %.12f, diff = %.12f, %s\n", i, lssf, lss, lsmf, lsm, lss - lsm, conv) if (verbose) cat(resc) if (!is.null(outfile)) cat(resc, file=outfile, append=TRUE) c(lsm=lsm, lss=lss, lssf=lssf, lsmf=lsmf) } if (is.null(cores) || cores==1) parallel <- FALSE else parallel <- TRUE; if (parallel){ if (!is.null(cores) && cores=="default") cores <- NULL if (requireNamespace("doParallel", quietly = TRUE)){ ### can't get this working separated out into a function like portable.parallel(). Variable exporting / scoping doesnt' work. ### no need to export these? "msm.coarse", "msm.coarse.data", "msm.full", "msm.full.data","coarsening.ematrix", "initp" if (.Platform$OS.type == "windows") { cl <- parallel::makeCluster(cores) doParallel::registerDoParallel(cl) } else doParallel::registerDoParallel(cores=cores) cv <- foreach::"%dopar%"(foreach::foreach(i=1:n, .packages="msm", .export=c(ls(.GlobalEnv))), { cv.fn(i) }) } else stop("\"parallel\" package not available") } else { cv <- vector(mode="list", n) for (i in 1:n){ cv[[i]] <- cv.fn(i) } } LCVi <- sapply(cv, function(x){x["lss"] - x["lsm"]}) DRLCV <- mean(LCVi) dlh <- logLik.msm(msm.full.on.restricted, by.subject=TRUE) - logLik.msm(msm.coarse, by.subject=TRUE) omega.sq <- mean(dlh*dlh) - mean(dlh)^2 half.width <- qnorm(1 - 0.5*(1 - tl)) * sqrt(omega.sq / n) prob.DRLCV <- pnorm(-DRLCV / sqrt(omega.sq / n)) res.int <- c("2.5%"=DRLCV-half.width,"97.5%"=DRLCV+half.width,"Prob<0"=prob.DRLCV) if (!isTRUE(all.equal(tl,0.95))) names(res.int)[1:2] <- c("Lower","Upper") liks <- cbind("-LL" = c(-lsm, -lss, -(lsm-lss), -(lsm-lss)/n)) rownames(liks) <- c("complex","simple","complex-simple","(complex-simple)/n") res <- list(lik.restricted = liks, drlcv = as.numeric(DRLCV), ti=res.int) res } msm/R/simul.R0000755000176200001440000004236612456226241012545 0ustar liggesusers### FUNCTIONS FOR SIMULATING FROM MULTI-STATE MODELS ### from help(sample) in base R resample <- function(x, size, ...) if(length(x) <= 1) { if(!missing(size) && size == 0) x[FALSE] else x } else sample(x, size, ...) ### General function to simulate one individual's realisation from a continuous-time Markov model ### Produces the exact times of transition sim.msm <- function(qmatrix, # intensity matrix maxtime, # maximum time for realisations covs=NULL, # covariate matrix, nobs rows, ncovs cols beta=NULL, # matrix of cov effects on qmatrix. ncovs rows, nintens cols. obstimes=0, # times at which time-dependent covariates change start = 1, # starting state mintime = 0 # time to start from ) { ## Keep only times where time-dependent covariates change if (!is.null(covs)) { covs2 <- collapse.covs(covs) covs <- covs2$covs obstimes <- obstimes[covs2$ind] } else {obstimes <- mintime; covs <- beta <- 0} if (is.vector(beta)) beta <- matrix(beta, ncol=length(beta)) nct <- length(obstimes) nstates <- nrow(qmatrix) ## Form an array of qmatrices, one for each covariate change-time qmatrices <- array(rep(t(qmatrix), nct), dim=c(dim(qmatrix), nct)) qmatrices[rep(t(qmatrix)>0, nct)] <- qmatrices[rep(t(qmatrix)>0, nct)]*exp(t(beta)%*%t(covs)) # nintens*nobs for (i in 1:nct) qmatrices[,,i] <- msm.fixdiag.qmatrix(t(qmatrices[,,i])) cur.t <- mintime; cur.st <- next.st <- start; rem.times <- obstimes; t.ind <- 1 nsim <- 0; max.nsim <- 10 simstates <- simtimes <- numeric(max.nsim) ## allocate memory up-front for simulated outcome absorb <- absorbing.msm(qmatrix=qmatrix) ## Simulate up to maxtime or absorption while (cur.t < maxtime) { nsim <- nsim + 1 cur.st <- next.st simstates[nsim] <- cur.st; simtimes[nsim] <- cur.t if (cur.st %in% absorb) break; rate <- -qmatrices[cur.st,cur.st, t.ind:length(obstimes)] nextlag <- rpexp(1, rate, rem.times-rem.times[1]) cur.t <- cur.t + nextlag t.ind <- which.min((cur.t - obstimes)[cur.t - obstimes > 0]) rem.times <- cur.t if (any(obstimes > cur.t)) rem.times <- c(rem.times, obstimes[(t.ind+1): length(obstimes)]) cur.q <- qmatrices[,, t.ind] next.st <- resample((1:nstates)[-cur.st], size=1, prob = cur.q[cur.st, -cur.st]) if (nsim > max.nsim) { ## need more memory for simulated outcome, allocate twice as much simstates <- c(simstates, numeric(max.nsim)) simtimes <- c(simtimes, numeric(max.nsim)) max.nsim <- max.nsim*2 } } ## If process hasn't absorbed by the end, then include a censoring time if (cur.t >= maxtime) { nsim <- nsim+1 simstates[nsim] <- cur.st simtimes[nsim] <- maxtime } list(states = simstates[1:nsim], times = simtimes[1:nsim], qmatrix = qmatrix) } ## Drop rows of a covariate matrix which are identical to previous row ## Similar method to R's unique.data.frame collapse.covs <- function(covs) { if (nrow(covs)==1) list(covs=covs, ind=1) else { pcovs <- apply(covs, 1, function(x) paste(x, collapse="\r")) lpcovs <- c("\r", pcovs[1:(length(pcovs)-1)]) ind <- pcovs!=lpcovs list(covs=covs[ind,,drop=FALSE], ind=which(ind)) } } ### Given a simulated Markov model, get the current state at various observation times ### By default, only keep one observation in the absorbing state getobs.msm <- function(sim, obstimes, death=FALSE, drop.absorb=TRUE) { absorb <- absorbing.msm(qmatrix=sim$qmatrix) # Only keep one observation in the absorbing state if (drop.absorb && any(sim$states %in% absorb)) { if (any(sim$states %in% death)) keep <- which(obstimes < max(sim$times)) else { lo <- c(-Inf, obstimes[1:(length(obstimes)-1)]) keep <- which(lo <= max(sim$times)) } } else keep <- 1 : length(obstimes) obstimes <- obstimes[keep] state <- sim$states[rowSums(outer(obstimes, sim$times, ">="))] time <- obstimes if (any(sim$states %in% death)) { # Keep the exact death time if required state <- c(state, sim$states[sim$states %in% death]) time <- c(time, sim$times[sim$states %in% death]) state <- state[order(time)] time <- time[order(time)] keep <- c(keep, max(keep)+1) } list(state = state, time = time, keep=keep) } ### Simulate a multi-state Markov or hidden Markov model dataset using fixed observation times ### Would it be better to make specification of covariate model consistent with model fitting function? ### e.g. separate hcovariates and covariates formulae, ### plus covinits and hcovinits? simmulti.msm <- function(data, # data frame with subject, times, covariates... qmatrix, # intensity matrix covariates=NULL, # initial values death = FALSE, # vector of indicators for "death" states, ie absorbing states whose entry time is known exactly, # but with unknown transient state at previous instant start, # starting states of the process, defaults to all 1. ematrix = NULL,# misclassification matrix misccovariates = NULL, # covariates on misclassification probabilities hmodel = NULL, # hidden Markov model formula hcovariates = NULL, # covariate effects on hidden Markov model response distribution censor.states = NULL, drop.absorb = TRUE ) { ### Check consistency of qmatrix and covariate inits nstates <- nrow(qmatrix) msm.check.qmatrix(qmatrix) qmatrix <- msm.fixdiag.qmatrix(qmatrix) ### Subject, time and state if (!("subject" %in% names(data))) data$subject <- rep(1, nrow(data)) if (!("time" %in% names(data))) stop("\"time\" column missing from data") data <- as.data.frame(data) subject <- data[,"subject"] time <- data[,"time"] if (is.unsorted(subject)){ warning("Data are not ordered by subject ID and time - output will be ordered.") data <- data[order(subject, time),] } if (any(duplicated(data[,c("subject", "time")]))){ warning("Data contain duplicated observation times for a subject - removing duplicates.") data <- data[!duplicated(data[,c("subject", "time")]), ] } subject <- data[,"subject"]; time <- data[,"time"]; cens <- if (any(colnames(data)=="cens")) data[,"cens"] else rep(0, length(subject)) msm.check.times(time, subject) times <- split(time, subject) cens <- split(cens, subject) n <- length(unique(subject)) ### Covariates on intensities covnames <- names(covariates) ncovs <- length(covnames) misscovs <- setdiff(covnames, names(data)) if (length(misscovs) > 0) stop("Covariates ", paste(misscovs, collapse=", "), " not found in data") covs <- if (ncovs > 0) lapply(split(data[,covnames], subject), as.matrix) else NULL allcovs <- covnames ### Covariates on misclassification misccovnames <- names(misccovariates) nmisccovs <- length(misccovnames) misscovs <- setdiff(misccovnames, names(data)) if (length(misscovs) > 0) stop("Misclassification covariates ", paste(misscovs, collapse=", "), " not found in data") misccovs <- if (nmisccovs > 0) lapply(split(data[,setdiff(misccovnames,covnames)], subject), as.matrix) else NULL allmisccovs <- misccovnames ### Covariates on HMM if (!is.null(hcovariates)) { if (is.null(hmodel)) stop("hcovariates specified, but no hmodel") hcovnames <- unique(names(unlist(hcovariates))) if (length(hcovariates) != nstates) stop("hcovariates of length ", length(hcovariates), ", expected ", nstates) msm.check.hmodel(hmodel, nstates) misscovs <- setdiff(hcovnames, names(data)) if (length(misscovs) > 0) stop("Covariates ", paste(misscovs, collapse=", "), " not found in data") hcovs <- lapply(split(data[,setdiff(hcovnames, setdiff(misccovnames,covnames))], subject), as.matrix) } else hcovs <- hcovnames <- NULL ### Extra variables to return extravars <- setdiff(names(data), unique(c("subject","time", "cens", covnames, misccovnames, hcovnames))) extradat <- if(length(extravars)>0) split(data[,extravars,drop=FALSE], subject) else NULL ### Starting states if (missing(start)) start <- rep(1, n) else if (length(start) == 1) start <- rep(start, n) else if (length(start) != n) stop("Supplied ", length(start), " starting states, expected 1 or ", n) nq <- length(qmatrix[qmatrix > 0]) misspeccovs <- covnames[sapply(covariates, length) != nq] if (length(misspeccovs) > 0) stop("Initial values for covariates ", paste(misspeccovs, collapse=", "), " should be of length ", nq) beta <- do.call("rbind", as.list(covariates)) ne <- length(ematrix[ematrix > 0]) misspeccovs <- covnames[sapply(misccovariates, length) != ne] if (length(misspeccovs) > 0) stop("Initial values for misclassification covariates ", paste(misspeccovs, collapse=", "), " should be of length ", ne) beta.misc <- do.call("rbind", as.list(misccovariates)) ### Check death argument. Logical values allowed for backwards compatibility ### (TRUE means final state is death, FALSE means no death state) statelist <- if (nstates==2) "1, 2" else if (nstates==3) "1, 2, 3" else paste("1, 2, ... ,",nstates) if (is.logical(death) && death==TRUE) {death <- nstates} else if (is.logical(death) && death==FALSE) {death <- 0} else if (length(setdiff(unique(death), 1:nstates)) > 0) stop(paste("Death states indicator contains states not in",statelist)) ### Simulate a realisation for each person state <- numeric() keep.data <- numeric() subj <- split(subject, subject) subj.num <- match(subject, unique(subject)) for (pt in 1:n) { sim.mod <- sim.msm(qmatrix, max(times[[pt]]), covs[[pt]], beta, times[[pt]], start[pt], min(times[[pt]])) obsd <- getobs.msm(sim.mod, times[[pt]], death, drop.absorb) pt.data <- cbind(subj[[pt]][obsd$keep], obsd$time, obsd$state, cens[[pt]][obsd$keep]) if (!is.null(covnames)) pt.data <- cbind(pt.data, covs[[pt]][obsd$keep,,drop=FALSE]) if (!is.null(misccovnames)) pt.data <- cbind(pt.data, misccovs[[pt]][obsd$keep,,drop=FALSE]) if (!is.null(hcovnames)) pt.data <- cbind(pt.data, hcovs[[pt]][obsd$keep,,drop=FALSE]) if (!is.null(extravars)) pt.data <- cbind(pt.data, extradat[[pt]][obsd$keep,,drop=FALSE]) inds <- which(subj.num==pt) pt.data <- cbind(pt.data, keep=inds[obsd$keep]) keep.data <- rbind(keep.data, pt.data) } colnames(keep.data) <- c("subject","time","state","cens",union(union(covnames,misccovnames),hcovnames),extravars,"keep") keep.data <- as.data.frame(keep.data) ### Simulate some misclassification or a HMM conditionally on the underlying state if (!is.null(ematrix)) { if (!all(dim(ematrix) == dim(qmatrix))) stop("Dimensions of qmatrix and ematrix should be equal") keep.data <- cbind(keep.data, obs=simmisc.msm(keep.data$state, ematrix, beta.misc, keep.data[,misccovnames,drop=FALSE])) } else if (!is.null(hmodel)) keep.data <- cbind(keep.data, obs=simhidden.msm(keep.data$state, hmodel, nstates, hcovariates, keep.data[,hcovnames,drop=FALSE])) ### Replace state at censor times by censoring indicators censor <- unique(keep.data$cens[keep.data$cens != 0]) if (is.null(censor.states)) censor.states <- 1:(nstates-1) if (!is.null(keep.data$obs)) keep.data$obs <- ifelse(keep.data$cens > 0 & keep.data$state %in% censor.states, keep.data$cens, keep.data$obs) else keep.data$state <- ifelse(keep.data$cens > 0 & keep.data$state %in% censor.states, keep.data$cens, keep.data$state) keep.data$cens <- NULL # attr(keep.data, "keep") <- obsd$keep keep.data } ## Simulate misclassification conditionally on an underlying state simmisc.msm <- function(state, ematrix, beta, misccovs) { ostate <- state if (is.null(ematrix)) warning("No misclassification matrix given, assuming no misclassification") else { if (any(ematrix < 0)) stop("Not all elements of ematrix are > 0") if (any(ematrix > 1)) stop("Not all elements of ematrix are < 1") if (nrow(ematrix) != ncol(ematrix)) stop("Number of rows and columns of ematrix are not equal") nstates <- nrow(ematrix) ematrix <- msm.fixdiag.ematrix(ematrix) ostate <- state beta.states <- t(row(ematrix))[t(ematrix) > 0 & !(row(ematrix)==col(ematrix))] for (i in 1:nstates) if (any(state==i)) { n <- length(state[state==i]) if (!is.null(beta)) { # covariates on misclassification probabilities X <- as.matrix(misccovs[state==i,]) b <- beta[,beta.states == i,drop=FALSE] p <- matrix(rep(ematrix[i,], n), nrow=n, byrow=TRUE) mu <- log(p / p[,i]) emu <- array(0, dim=dim(p)) miscstates <- setdiff(which(ematrix[i,] > 0), i) for (j in seq(along=miscstates)) emu[,miscstates[j]] <- exp(mu[,miscstates[j]] + X %*% b[,j]) emu[,i] <- 1 emu[,ematrix[i,]==0] <- 0 p <- emu / rowSums(emu) for (j in 1:n) ostate[state==i][j] <- resample(1:nstates, size=1, prob=p[j,], replace=TRUE) } else ostate[state==i] <- resample(1:nstates, size=n, prob=ematrix[i,], replace=TRUE) } } ostate } ## Simulate HMM outcome conditionally on an underlying state simhidden.msm <- function(state, hmodel, nstates, beta=NULL, x=NULL) { y <- state msm.check.hmodel(hmodel, nstates) for (i in 1:nstates) if (any(state==i)) { ## don't change the underlying state if the HMM is the null (identity) model if (!(hmodel[[i]]$label=="identity" && (length(hmodel[[i]]$pars) == 0))) { ## simulate from the sampling function "r" in the HMM object ## transform the location parameter by covariates if necessary rcall <- list(n=length(state[state==i])) if (!is.null(beta[[i]])) { link <- get(hmodel[[i]]$link) invlink <- get(.msm.INVLINK[hmodel[[i]]$link]) locpar <- .msm.LOCPARS[hmodel[[i]]$label] loc <- hmodel[[i]]$pars[locpar] loc <- invlink(link(loc) + as.matrix(x[state==i,names(beta[[i]])]) %*% beta[[i]]) rcall[[paste("r",locpar,sep="")]] <- loc } rfn <- hmodel[[i]]$r y[state==i] <- do.call("rfn", rcall) } } y } ### Simulate data from fitted model with same observation scheme ### Used for parametric bootstrap in pearson.msm simfitted.msm <- function(x, drop.absorb=TRUE, drop.pci.imp=TRUE){ sim.df <- x$data$mf x$data <- expand.data(x) sim.df$"(cens)" <- ifelse(sim.df$"(state)" %in% 1:x$qmodel$nstates, 0, sim.df$"(state)") # 0 if not censored, cens indicator if censored, so that censoring is retained in simulated data. TODO used in pearson? if (x$qcmodel$ncovs > 0) { sim.df <- cbind(sim.df, x$data$mm.cov) cov.effs <- lapply(x$Qmatrices, function(y)t(y)[t(x$qmodel$imatrix)==1])[x$qcmodel$covlabels] } else cov.effs <- NULL if (x$ecmodel$ncovs > 0) { sim.df <- cbind(sim.df, x$data$mm.mcov) misccov.effs <- lapply(x$Ematrices, function(y)t(y)[t(x$emodel$imatrix)==1])[x$ecmodel$covlabels] } else misccov.effs <- NULL names(sim.df) <- replace(names(sim.df), match(c("(state)","(time)","(subject)"), names(sim.df)), c("state","time","subject")) if (any(union(names(cov.effs), names(misccov.effs)) %in% c("state","time","subject"))) stop("Not supported with covariates named \"state\", \"time\" or \"subject\"") # TODO? boot.df <- simmulti.msm(data=sim.df, qmatrix=qmatrix.msm(x, covariates=0, ci="none"), covariates=cov.effs, death=FALSE, ematrix=ematrix.msm(x, covariates=0, ci="none"), misccovariates=misccov.effs, drop.absorb=drop.absorb ) if (drop.pci.imp & !is.null(boot.df$"(pci.imp)")) { boot.df <- boot.df[!boot.df$"(pci.imp)",] boot.df$"(pci.imp)" <- NULL } boot.df } msm/R/hmm-dists.R0000755000176200001440000001330412466120401013277 0ustar liggesusers ### CONSTRUCTORS FOR VARIOUS DISTRIBUTIONS FOR RESPONSE CONDITIONALLY ON HIDDEN STATE ### Categorical distribution on the set 1,...,n hmmCat <- function(prob, basecat) { label <- "categorical" prob <- lapply(prob, eval) p <- unlist(prob) if (any(p < 0)) stop("non-positive probability") if (all(p == 0)) stop("insufficient positive probabilities") p <- p / sum(p) ncats <- length(p) link <- "log" # covariates are added to log odds relative to baseline in lik.c(AddCovs) cats <- seq(ncats) basei <- if (missing(basecat)) which.max(p) else which(cats==basecat) r <- function(n, rp=p) sample(cats, size=n, prob=rp, replace=TRUE) pars <- c(ncats, basei, p) plab <- rep("p", ncats) plab[p==0] <- "p0" plab[basei] <- "pbase" names(pars) <- c("ncats", "basecat", plab) hdist <- list(label=label, pars=pars, link=link, r=r) ## probabilities are always pars[c(3,3+pars[0])] class(hdist) <- "hmmdist" hdist } ### Constructor for a standard univariate distribution (i.e. not hmmCat) hmmDIST <- function(label, link, r, call, ...) { call <- c(as.list(call), list(...)) miss.pars <- which ( ! (.msm.HMODELPARS[[label]] %in% names(call)[-1]) ) if (length(miss.pars) > 0) { stop("Parameter ", .msm.HMODELPARS[[label]][min(miss.pars)], " for ", call[[1]], " not supplied") } pars <- unlist(lapply(call[.msm.HMODELPARS[[label]]], eval)) names(pars) <- .msm.HMODELPARS[[label]] hmmCheckInits(pars) hdist <- list(label = label, pars = pars, link = link, r = r) class(hdist) <- "hmmdist" hdist } ### Multivariate distribution composed of independent univariates hmmMV <- function(...){ args <- list(...) if (any(sapply(args, class) != "hmmdist")) stop("All arguments of \"hmmMV\" should be HMM distribution objects") class(args) <- c("hmmMVdist","hmmdist") args } hmmCheckInits <- function(pars) { for (i in names(pars)) { if (!is.numeric(pars[i])) stop("Expected numeric values for all parameters") else if (i %in% .msm.INTEGERPARS) { if (!identical(all.equal(pars[i], round(pars[i])), TRUE)) stop("Value of ", i, " should be integer") } ## Range check now done in msm.form.hranges } } hmmIdent <- function(x) { hmm <- hmmDIST(label = "identity", link = "identity", r = function(n)rep(x, n), match.call()) hmm$pars <- if (missing(x)) numeric() else x names(hmm$pars) <- if(length(hmm$pars)>0) "which" else NULL hmm } hmmUnif <- function(lower, upper) { hmmDIST (label = "uniform", link = "identity", r = function(n) runif(n, lower, upper), match.call()) } hmmNorm <- function(mean, sd) { hmmDIST (label = "normal", link = "identity", r = function(n, rmean=mean) rnorm(n, rmean, sd), match.call()) } hmmLNorm <- function(meanlog, sdlog) { hmmDIST (label = "lognormal", link = "identity", r = function(n, rmeanlog=meanlog) rlnorm(n, rmeanlog, sdlog), match.call()) } hmmExp <- function(rate) { hmmDIST (label = "exponential", link = "log", r = function(n, rrate=rate) rexp(n, rrate), match.call()) } hmmGamma <- function(shape, rate) { hmmDIST (label = "gamma", link = "log", r = function(n, rrate=rate) rgamma(n, shape, rrate), match.call()) } hmmWeibull <- function(shape, scale) { hmmDIST (label = "weibull", link = "log", r = function(n, rscale=scale) rweibull(n, shape, rscale), match.call()) } hmmPois <- function(rate) { hmmDIST (label = "poisson", link = "log", r = function(n, rrate=rate) rpois(n, rrate), match.call()) } hmmBinom <- function(size, prob) { hmmDIST (label = "binomial", link = "qlogis", r = function(n, rprob=prob) rbinom(n, size, rprob), match.call()) } hmmNBinom <- function(disp, prob) { hmmDIST (label = "nbinom", link = "qlogis", r = function(n, rprob=prob) rnbinom(n, disp, rprob), match.call()) } hmmBeta <- function(shape1, shape2) { hmmDIST (label = "beta", link = "log", r = function(n) rbeta(n, shape1, shape2), match.call()) } hmmTNorm <- function(mean, sd, lower=-Inf, upper=Inf) { hmmDIST (label = "truncnorm", link = "identity", r = function(n, rmean=mean) rtnorm(n, rmean, sd, lower, upper), match.call(), lower=lower, upper=upper) } hmmMETNorm <- function(mean, sd, lower, upper, sderr, meanerr=0) { hmmDIST (label = "metruncnorm", link = "identity", r = function(n, rmeanerr=meanerr) rnorm(n, rmeanerr + rtnorm(n, mean, sd, lower, upper), sderr), match.call(), meanerr=meanerr) } hmmMEUnif <- function(lower, upper, sderr, meanerr=0) { hmmDIST (label = "meuniform", link = "identity", r = function(n, rmeanerr=meanerr) rnorm(n, rmeanerr + runif(n, lower, upper), sderr), match.call(), meanerr=meanerr) } hmmT <- function(mean, scale, df) { hmmDIST(label="t", link="identity", r = function(n, rmean=mean) { rmean + scale*rt(n,df) }, match.call()) } msm/R/constants.R0000755000176200001440000001456612341613727013433 0ustar liggesusers### PACKAGE GLOBAL CONSTANTS ### ### List of allowed hidden Markov model distributions ### and names of parameters for each distribution ### MUST BE KEPT IN THE SAME ORDER as the C variable HMODELS in src/lik.c .msm.HMODELPARS <- list( categorical=c("ncats","basecat","p"), identity = NULL, uniform = c("lower", "upper"), normal = c("mean", "sd"), lognormal = c("meanlog", "sdlog"), exponential = c("rate"), gamma = c("shape","rate"), weibull = c("shape","scale"), poisson = c("rate"), binomial = c("size","prob"), truncnorm = c("mean", "sd", "lower", "upper"), metruncnorm = c("mean", "sd", "lower", "upper", "sderr", "meanerr"), meuniform = c("lower", "upper", "sderr", "meanerr"), nbinom = c("disp","prob"), beta = c("shape1","shape2"), t = c("mean","scale","df") ) ## TODO - e.g. non-central beta, cauchy, chisq, noncentral chisq, F, ## non-central F, geometric, hypergeometric, logistic, noncentral t. .msm.HMODELS <- names(.msm.HMODELPARS) ### Models with analytic derivatives available .msm.HMODELS.DERIV <- c("categorical","identity","uniform","normal","lognormal","exponential", "gamma","weibull","poisson","binomial","nbinom","beta","t") ### Models with expected information matrix available .msm.HMODELS.INFO <- c("categorical","identity") ### Parameter in each distribution that can have covariates on it .msm.LOCPARS <- c(categorical="p", identity=NA, uniform=NA, normal="mean", lognormal="meanlog", exponential="rate", gamma="rate", weibull="scale", poisson="rate", binomial="prob", truncnorm="mean", metruncnorm="meanerr", meuniform="meanerr", nbinom="prob", beta=NA, t="mean") ### Link functions for generalised regressions. ### MUST BE KEPT IN SAME ORDER as LINKFNS in lik.c .msm.LINKFNS <- c("identity", "log", "qlogis") .msm.INVLINK <- c(identity="identity", log="exp", qlogis="plogis") ### Parameters which are always fixed, never estimated .msm.AUXPARS <- c("lower", "upper", "which", "size", "meanerr", "ncats", "basecat", "p0", "pbase", "initpbase", "initp0") ### Parameters which should be defined as integer .msm.INTEGERPARS <- c("size") ### Defined ranges for parameters .msm.PARRANGES <- list(qbase=c(0, Inf), lower=c(-Inf,Inf), upper=c(-Inf, Inf), mean=c(-Inf, Inf), sd=c(0, Inf), meanlog=c(-Inf,Inf), sdlog=c(0, Inf), rate=c(0, Inf), shape=c(0, Inf), scale=c(0, Inf), shape1=c(0,Inf), shape2=c(0,Inf), prob=c(0, 1), meanerr=c(-Inf, Inf), sderr=c(0, Inf), disp=c(0, Inf), p=c(-Inf,Inf), # handled separately using multinomial logit initp=c(-Inf,Inf), # handled separately using multinomial logit df=c(0, Inf), qcov=c(-Inf,Inf),hcov=c(-Inf,Inf),initpcov=c(-Inf,Inf) ) for (i in .msm.AUXPARS) .msm.PARRANGES[[i]] <- c(-Inf, Inf) .msm.PARRANGES <- do.call("rbind",.msm.PARRANGES) colnames(.msm.PARRANGES) <- c("lower","upper") ### Transforms to optimise some parameters on a different scale ### Univariate transforms only: doesn't include multinomial logit transform used for misclassification p and initial state probs .msm.TRANSFORMS <- do.call("rbind", apply(.msm.PARRANGES, 1, function(x) { if (identical(x, c(lower=0, upper=Inf))) c(fn="log",inv="exp") else if (identical(x, c(lower=0, upper=1))) c(fn="qlogis",inv="plogis") else NULL } ) ) ### Distinct labelled (1 and) 2 and 3 state directed graphs. ### graphs with common "iso" are isomorphic (i.e. identical when states are unlabelled) ### "perm" is permutation of states needed to transform graph into the first in the list of isomorphisms ### This database is used to determine the appropriate method for calculating the analytic P matrix. ### The numbered label gives the indices into the matrix of rates (vectorised by reading across rows) ### e.g. the model with qmatrix of the form ### *,1,1 ### 0,*,1 ### 0,0,* is "1-2-4" ### well-disease, well-death, disease-death transitions allowed. .msm.graphs <- list( "1" = list(), "2" = list( "1" = list(iso=1, perm=c(1,2)), "2" = list(iso=1, perm=c(2,1)), "1-2" = list(iso=2, perm=c(1,2)) ), "3" = list( "1-2" = list(iso=1, perm=c(1,2,3)), "3-4" = list(iso=1, perm=c(3,1,2)), "5-6" = list(iso=1, perm=c(2,3,1)), "1-4" = list(iso=2, perm=c(1,2,3)), "1-5" = list(iso=2, perm=c(2,3,1)), "2-3" = list(iso=2, perm=c(2,1,3)), "2-6" = list(iso=2, perm=c(1,3,2)), "3-6" = list(iso=2, perm=c(3,2,1)), "4-5" = list(iso=2, perm=c(3,1,2)), "1-6" = list(iso=3, perm=c(1,2,3)), "2-4" = list(iso=3, perm=c(3,1,2)), "3-5" = list(iso=3, perm=c(2,3,1)), "1-2-4" = list(iso=4,perm=c(1,2,3)), "1-2-6" = list(iso=4,perm=c(1,3,2)), "1-5-6" = list(iso=4,perm=c(2,3,1)), "2-3-4" = list(iso=4,perm=c(2,1,3)), "3-4-5" = list(iso=4,perm=c(3,1,2)), "3-5-6" = list(iso=4,perm=c(3,2,1)), "1-3-5" = list(iso=5,perm=c(1,2,3)), "1-3-6" = list(iso=5,perm=c(2,1,3)), "1-4-6" = list(iso=5,perm=c(3,1,2)), "2-3-5" = list(iso=5,perm=c(1,3,2)), "2-4-5" = list(iso=5,perm=c(2,3,1)), "2-4-6" = list(iso=5,perm=c(3,2,1)), "1-2-4-6" = list(iso=6,perm=c(1,2,3)), "1-3-5-6" = list(iso=6,perm=c(2,3,1)), "2-3-4-5" = list(iso=6,perm=c(3,1,2)) ), "4" = list( "1-5-9" = list(iso=1,perm=c(1,2,3,4)), "1-3-5-6-9" = list(iso=2,perm=c(1,2,3,4)) ), "5" = list( "1-6-11-16" = list(iso=1,perm=c(1,2,3,4,5)), "1-4-6-8-11-12-16" = list(iso=2,perm=c(1,2,3,4,5)), "1-6-7-11-12" = list(iso=3,perm=c(1,2,3,4,5)) ) ) ## Tasks to be performed in C .msm.CTASKS <- c("lik","deriv","info","viterbi","lik.subj","deriv.subj","dpmat") msm/R/pearson.R0000755000176200001440000010745312672521361013063 0ustar liggesusers### Pearson-type goodness-of fit test (Aguirre-Hernandez and Farewell, 2002; Titman and Sharples, 2007) pearson.msm <- function(x, transitions=NULL, timegroups=3, intervalgroups=3, covgroups=3, groups=NULL, boot=FALSE, B=500, next.obstime=NULL, # user-supplied next observation times, if known. N=100, indep.cens=TRUE, # use censoring times when calculating the empirical distribution of sampling times maxtimes=NULL,# upper limit for imputed next observation times pval=TRUE # calculate p-values for test. false if calling from bootstrap ){ dat <- x$data$mf ## Error handling if (!inherits(x, "msm")) stop("expected \"x\" t to be a msm model") if (x$hmodel$hidden && !x$emodel$misc) stop("only HMMs handled are misclassification models specified using \"ematrix\"") if (any(dat$"(obstype)"==2)) stop("exact transition times are not supported, only panel-observed data") if (!is.null(transitions) && !is.numeric(transitions)) stop("expected \"transitions\" to be numeric") if (!is.numeric(timegroups) || length(timegroups) != 1) stop ("expected \"timegroups\" to be a single number") if (!is.numeric(intervalgroups) || length(intervalgroups) != 1) stop ("expected \"intervalgroups\" to be a single number") if (!is.numeric(covgroups) || length(covgroups) != 1) stop ("expected \"covgroups\" to be a single number") if (!is.numeric(B) || length(B) != 1) stop ("expected \"B\" to be a single number") if (!is.numeric(N) || length(N) != 1) stop ("expected \"N\" to be a single number") ## Use only one covariate group for pci models with no other covariates if (!is.null(x$pci) && length(grep("timeperiod\\[([0-9]+|Inf),([0-9]+|Inf)\\)", x$qcmodel$covlabels)) == x$qcmodel$ncovs) covgroups <- 1 ## Label various constants nst <- x$qmodel$nstates exact.death <- any(dat$"(obstype)" == 3) dstates <- if (exact.death) absorbing.msm(x) else NULL ndstates <- if (exact.death) transient.msm(x) else 1:nst nndstates <- length(ndstates) ## Do minimum needed to port this to msm version 1.4 od <- dat[,c("(subject)","(time)","(state)","(obstype)")] names(od) <- c("subject","time","state","obstype") od$cov <- dat[,attr(dat,"covnames.q")] if (x$emodel$misc) od$misccov <- dat[,attr(dat,"covnames.e")] ncovs <- x$qcmodel$ncovs od$state <- factor(od$state, levels=sort(unique(od$state))) n <- nrow(od) ## Method is restricted to "terminal" censoring (means not dead, occurs at end) ## Drop censored states not at the end of individual series lastobs <- c(od$subject[1:(n-1)] != od$subject[2:n], TRUE) cens.notend <- (od$state %in% x$cmodel$censor) & (!lastobs) if (any(cens.notend)) { od <- od[!cens.notend,] warning("Omitting censored states not at the end of individual series") } ## Drop individuals with only one observation od <- od[!od$subject %in% unique(od$subject)[table(od$subject)==1],] ## Drop observations of censoring types other than "not dead" if (length(x$cmodel$censor) >= 2) { ind <- NULL for (i in 1:length(x$cmodel$censor)) { if (identical(x$cmodel$states[x$cmodel$index[i] : (x$cmodel$index[i+1]-1)], as.numeric(transient.msm(x)))) {ind <- i; break} } if (is.null(ind)){ warning("Omitting all censored states") cens.drop <- od$state %in% x$cmodel$censor } else { cens.drop <- od$state %in% x$cmodel$censor[-ind] warning("Omitting censored states of types other than ",x$cmodel$censor[ind]) } od <- od[!cens.drop,] } n <- nrow(od) nstcens <- length(unique(od$state)) # no. unique states in data, should be same as number of markov states plus number of censor types (max 1) cens <- nstcens > nst # is there any remaining censoring od$prevstate <- factor(c(NA,od$state[1:(n-1)]), levels=1:nndstates) od$prevtime <- c(NA, od$time[1:(n-1)]) od$ind <- 1:n # index into original data (useful if any rows of od are dropped) od$firstobs <- rep(tapply(1:n,od$subject,min)[as.character(unique(od$subject))], table(od$subject)[as.character(unique(od$subject))]) od$obsno <- 1:n - od$firstobs + 1 od$subj.num <- match(od$subject, unique(od$subject)) if (!is.null(next.obstime) && (!is.numeric(next.obstime) || length(next.obstime) != n)) stop (paste("expected \"next.obstime\" to be a numeric vector length", n)) od$timeinterval <- if (is.null(next.obstime)) (od$obsno>1)*(od$time - od$time[c(1,1:(n-1))]) else next.obstime if (!is.null(maxtimes) && (!is.numeric(maxtimes) || !(length(maxtimes) %in% c(1,n)))) stop (paste("expected \"maxtimes\" to be a numeric vector length 1 or", n)) if (!is.null(groups) && (!(length(groups) == n))) stop (paste("expected \"groups\" to be a vector length", n)) od$maxtimes <- if (is.null(maxtimes)) ifelse(od$state %in% dstates, max(od$timeinterval) + 1, od$timeinterval) ## Set max possible obs time for deaths to be max observed plus arbitrary one unit else rep(maxtimes, length=n) # if supplied as a scalar, use it for all obs od$usergroup <- factor(if (!is.null(groups)) groups else rep(1, n)) ## User-supplied groups ## Check and label transition groupings. Store data in a list ## Includes transitions to terminal censoring as separate states trans <- list() trans$allowed <- intervaltrans.msm(x, exclude.absabs=TRUE, censor=cens) trans$labsall <- paste(trans$allowed[,1], trans$allowed[,2], sep="-") trans$allowed[trans$allowed[,2] > nst, 2] <- nst+1 # these are to be used as indices, so label censoring as nst+1 not e.g. 99 trans$na <- nrow(trans$allowed) trans$use <- if (is.null(transitions)) 1:trans$na else transitions # why was this a matrix before? if (length(trans$use) != trans$na) stop("Supplied ", length(trans$use), " transition indices, expected ", trans$na) else if (!x$emodel$misc && ! all(tapply(trans$allowed[,1], trans$use, function(u)length(unique(u))) == 1) ) stop("Only transitions from the same origin can be grouped") ## convert ordinal transition indices to informative labels trans$labsagg <- tapply(trans$labsall, trans$use, function(u)paste(u,collapse=",")) trans$from <- trans$allowed[,1][!duplicated(trans$use)] # from-state corresp to each element of trans$labsagg trans$to <- trans$allowed[,2][!duplicated(trans$use)] # to-state corresp to each element of trans$labsagg trans$ngroups <- length(unique(trans$use)) ## Determine unique Q matrices determined by covariate combinations if (ncovs>0) { uniq <- unique(od$cov) nouniq <- dim(uniq)[1] pastedu <- do.call("paste",uniq) pastedc <- do.call("paste",od$cov) qmatindex <- match(pastedc,pastedu) qmat <- array(0,dim=c(nst,nst,nouniq)) for (i in 1:nouniq) qmat[,,i] <- qmatrix.msm(x, covariates=as.list(uniq[i,]), ci="none") }else{ qmatindex <- rep(1,n) nouniq <- 1 qmat <- array(qmatrix.msm(x,ci="none"),dim=c(nst,nst,1)) } qmatmaster <- qmat qmat <- qmat[,,qmatindex] od$rates <- apply(qmat,3,function(u) sum(diag(u))) ## Now work with a dataset with one row per transition md <- od[od$obsno>1,] qmat <- qmat[,,od$obsno>1] qmatindex <- qmatindex[od$obsno>1] ntrans <- nrow(md) nfromstates <- length(unique(md$prevstate)) ## Groups based on time since initiation (not observation number) timegroups.use <- min(length(unique(md$time)), timegroups) md$timegroup <- qcut(md$time, timegroups.use) ## Group time differences by quantiles within time since initiation intervalq <- tapply(md$timeinterval[md$state %in% ndstates], md$timegroup[md$state %in% ndstates], ## Categorise quantiles based only on full observations, not deaths or censoring. function(x) quantile(x,probs=seq(0,1,1/intervalgroups))) md$intervalgroup <- rep(1, ntrans) for (i in levels(md$timegroup)) md$intervalgroup[md$timegroup==i] <- unclass(qcut(md$timeinterval[md$timegroup==i], qu = intervalq[[i]])) md$intervalgroup <- factor(md$intervalgroup) ## Groups based on covariates covgroups.use <- min(length(unique(md$rates)), covgroups) md$covgroup <- if (ncovs > 0) qcut(md$rates, covgroups.use) else factor(rep(1,ntrans)) groupdims <- c(length(levels(md$timegroup)),length(levels(md$intervalgroup)),length(levels(md$covgroup)),length(levels(md$usergroup))) groupdimnames <- list(levels(md$timegroup),levels(md$intervalgroup),levels(md$covgroup),levels(md$usergroup)) ## Determine empirical distribution of time interval lengths. ## Then impute next scheduled observation for transitions which end in exact death times md$obtype <- rep(0, ntrans) if (exact.death) md$obtype[md$state %in% dstates] <- 1 md$obtype[md$state %in% x$cmodel$censor] <- 2 md$cens <- factor(as.numeric(md$obtype==2), levels=c(0,1)) ndeath <- sum(md$obtype==1) if (exact.death && is.null(next.obstime)) { cat("Imputing sampling times after deaths...\n") incl <- if (indep.cens) (0:2) else (0:1) empiricaldist <- empiricaldists(md$timeinterval[md$obtype %in% incl], md$state[md$obtype %in% incl], as.numeric(md$timegroup[md$obtype %in% incl]), timegroups, ndstates) imputation <- array(0,c(ndeath,N,4)) dimnames(imputation) <- list(NULL, NULL, c("times","cens","intervalgroup","timeqmatindex")) deathindex <- which(md$obtype==1) for (i in 1:ndeath) { mintime <- md$timeinterval[deathindex[i]] centime <- md$maxtimes[deathindex[i]] # - md$time[deathindex[i]] + mintime tg <- md$timegroup[deathindex[i]] ## returns list of times, whether would have ended in censoring, and time category. st <- sampletimes(mintime, centime, empiricaldist[,tg,empiricaldist["time",tg,]>0], N, tg, intervalq) for (j in c("times","cens","intervalgroup")) imputation[i,,j] <- st[,j] } } else imputation <- deathindex <- NULL ndeathindex <- setdiff(1:ntrans, deathindex) ## Transition probability matrices are indexed by unique combinations of time intervals and Q matrices. timeint <- c(md$timeinterval[md$obtype != 1],c(imputation[,,"times"])) # time intervals, excluding deaths, concatenated with imputations of next interval after death qmatint <- c(qmatindex[md$obtype != 1],rep(qmatindex[deathindex],N)) # index into unique Q matrices timeqmata <- unique(data.frame(timeint,qmatint)) timeqmat <- paste(timeint,qmatint,sep="-") pastedu <- unique(timeqmat) timeqmatindex <- match(timeqmat,pastedu) ## Work out the transition probability matrix for each unique time interval and Q matrix npmats<-length(pastedu) pmi <- array(0,dim=c(nst,nst,npmats)) for (i in unique(timeqmata[,2])) pmi[,,timeqmata[,2]==i] <- MatrixExp(qmatmaster[,,i], timeqmata[timeqmata[,2]==i,1]) md$timeqmatindex<-rep(0,ntrans) md$timeqmatindex[md$obtype != 1] <- timeqmatindex[1:(ntrans-ndeath)] if (exact.death && is.null(next.obstime)) imputation[,,"timeqmatindex"] <- timeqmatindex[(ntrans-ndeath+1):length(timeqmatindex)] ### Calculate transition probabilities for non-death intervals prob <- array(0,dim=c(nst,ntrans)) ## array of obs state probs, conditional on previous obs state if (x$emodel$misc) { misccov <- if (x$ecmodel$ncovs > 0) od$misccov[od$obsno>1,,drop=FALSE] else NULL p.true <- array(dim=c(nst, ntrans)) # prob of each true state conditional on complete history including current obs initp <- x$hmodel$initpmat if (x$ecmodel$ncovs > 0) { uniqmisc <- unique(misccov) ematindex <- match(do.call("paste",misccov), do.call("paste", uniqmisc)) emat <- array(0,dim=c(nst,nst,nrow(uniqmisc))) for (i in 1:nrow(uniqmisc)) emat[,,i] <- ematrix.msm(x, covariates=as.list(uniqmisc[i,]),ci="none") } else emat <- ematrix.msm(x, ci="none") for (i in 1:ntrans) { ematrix <- if (x$ecmodel$ncovs>0) emat[,,ematindex[i]] else emat if (md$state[i] %in% ndstates) { T <- pmi[,,md$timeqmatindex[i]] * matrix(ematrix[,md$state[i]], nrow=nst, ncol=nst, byrow=TRUE) p.true[,i] <- if (md$obsno[i] == 2) t(initp[md$subj.num[i],]) %*% T else t(p.true[,i-1]) %*% T p.true[,i] <- p.true[,i] / sum(p.true[,i]) # prob of each true state } if (!(md$state[i] %in% dstates)) { prob[,i] <- if (md$obsno[i] == 2) initp[md$subj.num[i],] %*% pmi[,,md$timeqmatindex[i]] %*% ematrix else p.true[,i-1] %*% pmi[,,md$timeqmatindex[i]] %*% ematrix } } } else prob[cbind(rep(1:nst,ntrans-ndeath),rep((1:ntrans)[ndeathindex],each=nst))] <- pmi[cbind(rep(md$prevstate[(1:ntrans)[ndeathindex]],each=nst), rep(1:nst,ntrans - ndeath),rep(md$timeqmatindex[(1:ntrans)[ndeathindex]],each=nst))] if (exact.death && is.null(next.obstime)) { stat.sim <- rep(0,N) obs.rep <- exp.rep <- dev.rep <- array(0, dim=c(groupdims, trans$ngroups, N)) dimnames(obs.rep) <- dimnames(exp.rep) <- dimnames(dev.rep) <- c(groupdimnames, list(trans$labsagg), list(1:N)) cat("Calculating replicates of test statistics for imputations...\n") for (i in 1:N) { ## Calculate transition probabilities for death intervals if (x$emodel$misc) { for (j in 1:ndeath) { k <- deathindex[j] ematrix <- if (x$ecmodel$ncovs>0) emat[,,ematindex[k]] else emat prob[,k] <- if (md$obsno[k] == 2) initp[md$subj.num[k],] %*% pmi[,,imputation[j,i,"timeqmatindex"]] %*% ematrix else p.true[,k-1] %*% pmi[,,imputation[j,i,"timeqmatindex"]] %*% ematrix } } else prob[cbind(rep(1:nst,ndeath),rep(deathindex,each=nst))] <- pmi[cbind(rep(md$prevstate[deathindex],each=nst),rep(1:nst,ndeath),rep(imputation[,i,"timeqmatindex"],each=nst))] md$intervalgroup[deathindex] <- factor(imputation[,i,"intervalgroup"], labels=levels(md$intervalgroup[deathindex])[sort(unique(imputation[,i,"intervalgroup"]))]) md$cens[deathindex] <- as.numeric(imputation[,i,"cens"]) # factor levels 0/1 ## Observed transition table, including to censoring indicators obs.rep.i <- table(md$state, md$prevstate, md$timegroup, md$intervalgroup, md$covgroup, md$usergroup) ## Expected transition table exp.cens <- array(0, dim = c(nst, nndstates, groupdims, 2)) for (j in 1:nst) exp.cens[j,,,,,,] <- tapply(prob[j,], list(md$prevstate,md$timegroup,md$intervalgroup,md$covgroup,md$usergroup,md$cens), sum) exp.cens <- replace(exp.cens,is.na(exp.cens),0) exp.unadj <- array(0, dim=c(nstcens, nndstates, groupdims)) exp.unadj[1:nst,,,,,] <- exp.cens[,,,,,,1] for (j in dstates) exp.unadj[j,,,,,] <- exp.cens[j,,,,,,1] + exp.cens[j,,,,,,2] if (cens) exp.unadj[nst+1,,,,,] <- apply(exp.cens[1:nndstates,,,,,,2,drop=FALSE], 2:6, sum) # total censored from any non-death state ## Remove very small values, caused by inaccuracy in numerical matrix exponential. exp.unadj <- replace(exp.unadj,(exp.unadj0)as.list(md$cov[i,])else 0)[md$prevstate[i],] Sigma <- matrix(0, nrow=C*nst,ncol=C*nst) for (c in 1:C) { block <- matrix(0,nrow=nst,ncol=nst) prc <- pr[md$group==c,,drop=FALSE] for (r in 1:nst) block[r,-r] <- - colSums(prc[,r]*prc[,-r,drop=FALSE]) diag(block) <- colSums(prc * (1 - prc)) rows <- cols <- (c-1)*nst + 1:nst Sigma[rows,cols] <- block } PSigmaPT <- P %*% Sigma %*% t(P) ## compute Psi = Cov(score(theta), Orc), where Orc is observed counts in pearson table ## arranged as npars x RC ## bottom left and top right blocks wrong way round in paper dp <- Ccall.msm(x$paramdata$opt$par, do.what="dpmat", expand.data(x), x$qmodel, x$qcmodel, x$cmodel, x$hmodel, x$paramdata) # ntrans x R x npars: trans in data order Psiarr <- apply(dp, c(2,3), function(x)tapply(x, md$group, sum)) npars <- x$paramdata$nopt # only includes qbase,qcov, since no hmms here ## permute C x R x npars Psiarr to R x C x npars Psi and then collapse first two dims Psi <- t(array(aperm(Psiarr,c(2,1,3)), dim=c(R*C,npars))) ## rows ordered with tostate changing fastest, then category (match P) EI <- 0.5*x$paramdata$info Omega <- rbind(cbind(EI, Psi %*% P), cbind(t(P) %*% t(Psi),PSigmaPT)) ## compute B: RC x npars matrix with entries derc/dtheta_m / sqrt(erc) ## erc(theta) is just sum over (i in that cat) of prc(theta) Barr <- Psiarr fromgroups <- md$prevstate[!duplicated(md$group)][order(unique(md$group))] # ugh for (i in 1:nfrom) { fi <- unique(from)[i] rows <- fromgroups==fi et <- exptable[,,,,from==fi] Barr[rows,to[from==fi],] <- - Barr[rows,to[from==fi],] / as.numeric(sqrt(et[et>0])) } Bmat <- array(aperm(Barr,c(2,1,3)), dim=c(R*C,npars)) A <- cbind(Bmat %*% solve(EI), diag(R*C)) V <- A %*% Omega %*% t(A) lambda <- eigen(V,only.values=TRUE)$values psi <- function(u)prod((1 - 2i*lambda*u)^(-0.5)) fn <- function(u){ res <- numeric(length(u)) for (i in seq(along=u)) res[i] <- Im(psi(u[i])*exp(-1i*u[i]*stat) / (2*pi*u[i])) res } int <- try(integrate(fn, -Inf, Inf)) if (inherits(int, "try-error")) { message("Unable to calculate more accurate p-value"); p.acc <- p.err <- NULL} else { p.acc <- 0.5 + int$value p.err <- int$abs.error if (p.acc - 2*p.err < 0) p.acc <- 0 if (p.acc + 2*p.err > 1) p.acc <- 1 } } test <- data.frame(stat=stat) if (acc.p) test$p <- p.acc test$df.lower <- if (exact.death && is.null(next.obstime)) NA else df.lower test$p.lower <- if (exact.death && is.null(next.obstime)) NA else 1 - pchisq(stat, df.lower) test$df.upper <- df.upper test$p.upper <- 1-pchisq(stat, df.upper) rownames(test) <- "" ## Simulated observation times to use as sampling frame for bootstrapped data if (!is.null(imputation)) { imp.times <- matrix(rep(x$data$mf$"(time)", N), nrow=length(x$data$mf$"(time)"), ncol=N) prevtime <- imp.times[which(x$data$mf$"(state)" %in% dstates) - 1,] imp.times[x$data$mf$"(state)" %in% dstates, ] <- prevtime + imputation[,,"times"] } else imp.times <- NULL if (boot) { if (!is.null(groups)) stop("Bootstrapping not valid with user-specified groups") cat("Starting bootstrap refitting...\n") boot.stats <- pearson.boot.msm(x, imp.times=imp.times, transitions=transitions, timegroups=timegroups, intervalgroups=intervalgroups, covgroups=covgroups, groups=groups, B=B) test$p.boot <- sum(boot.stats > stat) / B } pearson <- list(observed=obstable, expected=exptable, deviance=devtable*sign(obstable-exptable), test=test, intervalq=intervalq) names(pearson) <- c("Observed","Expected","Deviance*sign(O-E)","test","intervalq") if (exact.death && is.null(next.obstime)) pearson$sim <- list(observed=obs.rep, expected=exp.rep, deviances=dev.rep, stat=stat.sim, imputation=imputation) if (boot) pearson$boot <- boot.stats if (acc.p) pearson$lambda <- lambda pearson <- reformat.pearson.msm(pearson) class(pearson) <- "pearson.msm" pearson } ### Reformat array output from Pearson test as a matrix with transition type in columns reformat.pearson.msm <- function(pearson) { pp <- pearson nd <- length(dim(pearson$Observed)) for (i in 1:3) { dim(pp[[i]]) <- c(prod(dim(pp[[i]])[-nd]), dim(pp[[i]])[nd]) rnames <- do.call("expand.grid", dimnames(pearson$Observed)[1:4]) colnames(pp[[i]]) <- dimnames(pearson$Observed)[[nd]] pp[[i]] <- as.data.frame(pp[[i]]) pp[[i]] <- cbind(rnames, pp[[i]]) colnames(pp[[i]])[1:4] <- c("Time","Interval","Cov","User") drop <- NULL # drop columns labelling categories with only one value for (j in 1:4) if (length(unique(pp[[i]][,j]))==1) drop <- c(drop,j) pp[[i]] <- pp[[i]][,-drop] } pp } ### Keep the simulation and bootstrap output but don't print it print.pearson.msm <- function(x, ...){ print(x[!(names(x) %in% c("sim","boot","intervalq","lambda"))]) } ### Adaptation of cut(quantile()) so that if two quantiles are equal, a unique category is created for x equal to that ### For point intervals, the label is just the value of the point ### Else, the labels are in (a,b] or [a,b) type interval notation qcut <- function(x, n, qu=NULL, eps=1e-06, digits=2, drop.unused.levels=FALSE) { if (is.null(qu)) qu <- quantile(x, probs = seq(0, 1, 1/n)) q2.equal <- sequence(table(qu)) <= 2 qu <- qu[q2.equal] ## If three or more quantiles are equal, only keep two of them. ## Ensure all x fall within intervals, widening upper and lower intervals if necessary. qu[qu==max(qu)] <- max(max(qu),x) qu[qu==min(qu)] <- min(min(qu),x) n <- length(qu)-1 lagq <- c(-Inf, qu[1:n]) qlabs <- paste("[",round(qu[1:n],digits),",",round(qu[2:(n+1)],digits),")",sep="") inti <- qu[1:n]==qu[2:(n+1)] # which intervals are points qlabs[inti] <- round(qu[1:n][inti], digits) lastopen <- if (n==1) FALSE else c(FALSE, inti[1:(n-1)]) substr(qlabs[lastopen],1,1) <- "(" # interval with a point interval just before it is open on the left if (!inti[n]) substr(qlabs[length(qlabs)], nchar(qlabs[length(qlabs)]), nchar(qlabs[length(qlabs)])) <- "]" # last interval is closed on the right qu[qu==lagq] <- qu[qu==lagq] + eps x.cut <- cut(x, qu, right=FALSE, include.lowest=TRUE, labels=qlabs) tx <- tapply(x, x.cut, unique) nxcats <- sapply(tx, length) # number of unique x values in each category nxcats[is.na(tx)] <- 0 ## If only one unique x value is in a category, then label the category with that value if (any(nxcats==1)) levels(x.cut)[nxcats == 1] <- round(unlist(tx[nxcats==1]), digits) if (drop.unused.levels) x.cut <- factor(x.cut, exclude=NULL) # drop unused factor levels x.cut } pearson.boot.msm <- function(x, imp.times=NULL, transitions=NULL, timegroups=4, intervalgroups=4, covgroups=4, groups=NULL, B=500){ bootstat <- numeric(B) x$call$formula <- if (x$emodel$misc) substitute(obs ~ time) else substitute(state ~ time) x$call$qmatrix <- qmatrix.msm(x,ci="none") # put MLE in inits. x$call$hessian <- x$call$death <- FALSE x$call$obstype <- NULL x$call$subject <- substitute(subject) i <- 1 while (i <= B) { if (!is.null(imp.times)) x$data$mf$"(time)" <- imp.times[,sample(ncol(imp.times), size=1)] # resample one of the imputed sets of observation times boot.df <- simfitted.msm(x,drop.absorb=TRUE) x$call$data <- substitute(boot.df) refit.msm <- try(eval(x$call)) # estimation might not converge for a particular bootstrap resample if (inherits(refit.msm, "msm")) { p <- pearson.msm(refit.msm, transitions=transitions, timegroups=timegroups, intervalgroups=intervalgroups, covgroups=covgroups, groups=groups, boot=FALSE, pval=FALSE) bootstat[i] <- p$test$stat i <- i + 1 } } bootstat } ### Work out empirical distribution of sampling times for each observation (or time since initiation) group: empiricaldists <- function(timeinterval, state, obgroup, obgroups, ndstates) { empdist <- array(0,c(3, obgroups, max(table(obgroup[state %in% ndstates])))) # Need times, cum value and point mass value dimnames(empdist) <- list(c("time", "surv", "pdeath"), levels(obgroup), NULL) ## First dimension: 1: time, 2: surv prob 3: death prob in prev interval ## Second dim: observation group. Third dim: size of biggest obs group (i.e. maximum number of event times for KM estimate) for (i in 1:obgroups) { ##s1 <- survfit(Surv(timeinterval[obgroup==i],(state[obgroup==i] %in% ndstates))~1,type="kaplan-meier") ##survfit seems to ignore increments of small size ## TODO investigate this ##Instead use own code to create KM t <- round(timeinterval[(obgroup==i & state %in% ndstates)],4) eligt <- sort(unique(t)) events <- table(t) allt <- sort(round(timeinterval[obgroup==i],4)) empdist["time",i,1:length(eligt)] <- eligt for (j in 1:length(eligt)) { nrisk <- sum(allt + sqrt(.Machine$double.eps) >= eligt[j]) if (nrisk==0) nrisk <- 1 # avoid floating point fuzz in comparing last point empdist["surv",i,j] <- if (j>1) (empdist["surv",i,j-1]*(1 - events[j]/nrisk)) else (1 - events[j]/nrisk) empdist["pdeath",i,j] <- if (j>1) (empdist["surv",i,j-1] - empdist["surv",i,j]) else (1 - empdist["surv",i,j]) ## Now deals with ties correctly } } empdist } ### For a single death, sample N points from the distribution of the next sampling time ### mintime, centime: minimum and maximum possible times ### dist: matrix of times, survival probs and previous-interval death probs sampletimes <- function(mintime, centime, dist, N, obgroup, intervalq) { ## dist takes the overall distribution from the relevant obgroup, but since we supply obgroup it might be better to just supply the whole thing dist <- dist[,dist[1,]>mintime,drop=FALSE] # Remove times before the minimum possible time. if (length(dist) > 0) { dist[c("surv","pdeath"),] <- dist[c("surv","pdeath"),] / dist["surv",1] # Normalise ## Compute the censoring fraction cen <- 1 - sum(dist["pdeath",dist["time",]0) { cend <- as.numeric(runif(N) < cen) if (length(dist["time",])>1) { ## Suppress "Walker's alias method used, results incompatible with R < 2.2.0" warning times <- suppressWarnings(sample(dist["time",],N,replace=TRUE,prob=dist["pdeath",])) * (cend==0) + centime*(cend==1) }else{ times <- dist["time",]*(cend==0) + centime*(cend==1) } }else{ cend <- rep(1,N) times <- rep(centime,N) } }else{ cend <- rep(1,N) times <- rep(centime,N) } intervalgroup <- qcut(times,qu=intervalq[[obgroup]]) cbind(times=times, cens=cend, intervalgroup=intervalgroup) } ## make internal to pearson function ## requires table of expected values with dims: nstcens, nndstates, groupdims ## also observed table with same dims ## prob need to calculate these in every case. ## why not do this calculation with the ungrouped version of the table, collapse the first two dims, then aggregate the table by trans$use ### Replace fromstate,tostate dimensions at beginning by a single allowed-transition dimension at end agg.tables <- function(obs.full, exp.full, groupdims, groupdimnames, trans) { obstable <- exptable <- array(dim=c(groupdims, trans$na)) for (i in 1:trans$na) { obstable[,,,,i] <- obs.full[trans$allowed[i,2],trans$allowed[i,1],,,,] exptable[,,,,i] <- exp.full[trans$allowed[i,2],trans$allowed[i,1],,,,] } obstable <- replace(obstable,is.na(obstable),0) exptable <- replace(exptable,is.na(exptable),0) ## Aggregate by transition groups obstable <- aperm(apply(obstable, 1:4, function(u)tapply(u, trans$use, sum)), c(2:5,1)) exptable <- aperm(apply(exptable, 1:4, function(u)tapply(u, trans$use, sum)), c(2:5,1)) dimnames(obstable) <- dimnames(exptable) <- c(groupdimnames, list(trans$labsagg)) list(obs=obstable, exp=exptable) } ### Adjust expected counts to account for informative censoring times, according to method in paper addendum. adjust.expected.cens <- function(exp.unadj, obs, nst, ndstates, dstates, groupdims, N, cens, md, nstcens) { ## Compute total expected counts from each from-state, summed over destination state (n-tilde in paper addendum) nndstates <- length(ndstates) dims <- c(nndstates, groupdims) nobs <- apply(obs, 2:6, sum) # Obs trans summed over first dimension = destination state = Number of trans from state r in group nobs.xd <- nobs - array(obs[nst,,,,,], dim=dims) # Number of trans excluding death nobs.xdc <- if (cens) nobs.xd - array(obs[nst+1,,,,,,drop=FALSE], dim=dims) else nobs.xd # excluding death and censoring po <- array(0, dim = c(nst+1, dims)) # p-hat in appendix to paper, MLEs from unrestricted alternative model for (j in ndstates) # prop of uncensored trans from state r (and group) ending in state j (not death), multiplied by prop of trans not ending in death. po[j,,,,,] <- (array(obs[j,,,,,], dim=dims) * nobs.xd)/(nobs.xdc*nobs + (nobs.xdc*nobs==0)) for (j in dstates) po[nst,,,,,] <- array(obs[j,,,,,], dim=dims) / (nobs + (nobs==0)) # prop of trans from state r (and group) ending in death. (if zero in denom, this is 0) po[nst+1,,,,,] <- 1 - apply(po[dstates,,,,,,drop=FALSE], 2:6, sum) po <- replace(po, is.na(po), 0) nexp <- apply(exp.unadj, 2:6, sum) nexp.xd <- nexp - array(exp.unadj[nst,,,,,], dim=dims) nexp.xdc <- if (cens) nexp.xd - array(exp.unadj[nst+1,,,,,,drop=FALSE],dim=dims) else nexp.xd ps <- array(0,dim=c(nst+1, dims)) # p-tilde-star in addendum to paper. "robustified" MLEs from null Markov model for (j in ndstates) ps[j,,,,,] <- (array(exp.unadj[j,,,,,], dim=dims)*nexp.xd)/(nexp.xdc*nexp + (nexp.xdc*nexp==0)) for (j in dstates) ps[j,,,,,] <- array(exp.unadj[j,,,,,], dim=dims)/(nexp + (nexp==0)) ps[nst+1,,,,,] <- 1 - apply(ps[dstates,,,,,,drop=FALSE], 2:6, sum) ps <- replace(ps,is.na(ps),0) ncen <- tapply(md$cens, list(md$prevstate,md$timegroup,md$intervalgroup,md$covgroup,md$usergroup), function(x)sum(x==1)) dim(ncen) <- dims ncen <- replace(ncen, is.na(ncen), 0) exp.adj <- array(0, dim=c(nstcens,dims)) # = p-tilde-star * n / phat (in notation of paper) = ps * obs / po exp.adj[ndstates,,,,,] <- ps[ndstates,,,,,,drop=FALSE] * rep(nobs.xdc * nobs,each=nndstates) / rep(nobs.xd + (nobs.xd==0),each=nndstates) for (j in dstates) exp.adj[j,,,,,] <- array(ps[j,,,,,], dim=dims) * nobs if (cens) exp.adj[nst+1,,,,,] <- nobs - apply(exp.adj[1:nst,,,,,,drop=FALSE], 2:6, sum) exp.adj } msm/vignettes/0000755000176200001440000000000012774212430013060 5ustar liggesusersmsm/vignettes/figures/0000755000176200001440000000000012774212430014524 5ustar liggesusersmsm/vignettes/figures/p3q16.eps0000755000176200001440000000600712250051206016104 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:32 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> /CCITTFaxDecode filter}!/FX{<> /CCITTFaxDecode filter}!/FX{<> /CCITTFaxDecode filter}!/FX{<> stream xXKo6WXF #=w6` "EPyP$QUgxQ }64A @JAΰ2Q5 *dk}Q!LaH15FT0R-ۜc\y͙̌ml)Ml,$j򮴚fvkl&&9MKn5mZMAY&&EYvɖaXJPn -}.1D]⫩(#<Ă/= {qk$̷>pQLj$(9\J~BSs p?aP8Yx L6O)e`dx2LOrl GlW gHFm1n.BHiM4=qr|\g[FfvX׺;Cmf]2XklՀNa [muޖ=9v[h@]46/4 eئk]hk͌!?$Ůc .MBa [muؑi''X)C:Th%LG 8y Ei&*\븀kw 6SZ[Ӡ59~ YIʣ)soʰ͔ЉاmtK>FX>^fe&*52l3eg]}6 . :2 izGSwT $2l˿4ܝԻG%E/GqiROÏ9\{dn>~WwY@?oEg;C Yx> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 9 0 obj <> endobj 10 0 obj <> endobj 8 0 obj <> endobj 11 0 obj <> endobj 2 0 obj <>endobj xref 0 12 0000000000 65535 f 0000001554 00000 n 0000001845 00000 n 0000001495 00000 n 0000001336 00000 n 0000000015 00000 n 0000001316 00000 n 0000001602 00000 n 0000001702 00000 n 0000001643 00000 n 0000001672 00000 n 0000001787 00000 n trailer << /Size 12 /Root 1 0 R /Info 2 0 R /ID [<4772CDDC270CC9832170B8A6062C540F><4772CDDC270CC9832170B8A6062C540F>] >> startxref 2063 %%EOF msm/vignettes/figures/p3q135.eps0000755000176200001440000000607112250051206016167 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:31 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream xeK 1 @9E.4/ \G: `v> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000470 00000 n 0000000588 00000 n 0000000411 00000 n 0000000280 00000 n 0000000015 00000 n 0000000261 00000 n 0000000518 00000 n 0000000559 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<246D0C83F38FA09D6CA84E3971E1D234><246D0C83F38FA09D6CA84E3971E1D234>] >> startxref 740 %%EOF msm/vignettes/figures/illdeath.pdf0000755000176200001440000000327712250051205017007 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream xTn0 +tLTM=)>5pm @C|Hw"A<5$ghzO{Ϋyw n{dhޮ;!8>RRlʔE`Ĕ fX^ FN*X2 -{Ε4|3GN.XLZCŒ[B].IpkaͪlS>KB׍A%A&lnOq<^H `w=Ƞ ˆkØXCDi,]Z&#@M\ƔP]Yiړ&Tz Ddy -7PTtFZ_Jx^Z?^Met  PjOFhtċ<×xwL?L Qo(G<3twwHk):C"1Wm+d9 C>Iޣ.m/g9aL|OU̐v3zI[&&G˹)| ,X$F%D֬QwnVES֗ҝR[,$vc>_ ,bendstream endobj 6 0 obj 596 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 9 0 obj <> endobj 10 0 obj <> endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 11 0000000000 65535 f 0000000918 00000 n 0000001135 00000 n 0000000859 00000 n 0000000700 00000 n 0000000015 00000 n 0000000681 00000 n 0000000966 00000 n 0000001066 00000 n 0000001007 00000 n 0000001036 00000 n trailer << /Size 11 /Root 1 0 R /Info 2 0 R /ID [<8524F37507AD62BF2165B7063CA4B90E><8524F37507AD62BF2165B7063CA4B90E>] >> startxref 1354 %%EOF msm/vignettes/figures/p5q1_4_6_8_11_12_16.pdf0000755000176200001440000000240412250051206020007 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream xUSIN0>saĦDǽ8hR\U^#r^{KJ~N8z).rz{LgU-bVJH]1!f=]+88 o5(Pn2\պ͓܄V/XX_"qиbV 6fK)V=͎WlКhj",^bssqe Z,DȕBŶң+6Nh5j&Pܜ5l4h>[G,qfkb(D< mkUuj9n\bulĹAQ#Tq+FX>m\1.$11y_wf-=֗ݻs^C%endstream endobj 6 0 obj 390 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000684 00000 n 0000000802 00000 n 0000000625 00000 n 0000000494 00000 n 0000000015 00000 n 0000000475 00000 n 0000000732 00000 n 0000000773 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [] >> startxref 954 %%EOF msm/vignettes/figures/p3q12.eps0000755000176200001440000000601012250051206016072 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:29 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream xURN1 +|~=C?B/NvzfϟQ QDx1`Q nK(2M "Y5æGܱsּnȢ~L5IK1QNj_/*e>UOCfxpH;f`2*uYZ ,f 9K^CcS0Μ-YXV+侇<'8&osYT} c9 HJӬ;Ƶ\Effﵗn)̴ϥVW.qjt1$+gy:endstream endobj 6 0 obj 334 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000628 00000 n 0000000746 00000 n 0000000569 00000 n 0000000438 00000 n 0000000015 00000 n 0000000419 00000 n 0000000676 00000 n 0000000717 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<49ADAC326405A727B34AB09603D356DB><49ADAC326405A727B34AB09603D356DB>] >> startxref 898 %%EOF msm/vignettes/figures/p5q1_4_6_8_11_12_16.eps0000755000176200001440000000701612250051206020031 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 643 539 814 %%HiResBoundingBox: 28.300000 643.600000 538.600000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:34 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> /CCITTFaxDecode filter}!/FX{<> stream xMOK1s . \Iga"V'M Cy#^n0z_@x)Y Uߘ֘i O'a31pgh7p(%hpI(1 㠖úE(trgң zO`QmNNPgl8_.*,{h|+|Gendstream endobj 6 0 obj 175 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000468 00000 n 0000000586 00000 n 0000000409 00000 n 0000000279 00000 n 0000000015 00000 n 0000000260 00000 n 0000000516 00000 n 0000000557 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [] >> startxref 738 %%EOF msm/vignettes/figures/p3q12.pdf0000755000176200001440000000206412250051206016061 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream x]K0 D>,8=k(f "tdrze8]0> .) V=J{ٺÿf`y20JZݳew8@qPڰ8 >ջ dZ|MP(:Y~ث.BLi2k%7 ,qb?V+Liendstream endobj 6 0 obj 182 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000476 00000 n 0000000594 00000 n 0000000417 00000 n 0000000286 00000 n 0000000015 00000 n 0000000267 00000 n 0000000524 00000 n 0000000565 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [] >> startxref 746 %%EOF msm/vignettes/figures/p2q1.pdf0000755000176200001440000000200412250051205015767 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream xMA 0  {h%; ΡPJ KvGK|b}Nn/LAېWWE܉\#K &,@LKӐD"ATC7?-endstream endobj 6 0 obj 135 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000428 00000 n 0000000546 00000 n 0000000369 00000 n 0000000239 00000 n 0000000015 00000 n 0000000220 00000 n 0000000476 00000 n 0000000517 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<325056F4C9C207604170BC2D639E1D53><325056F4C9C207604170BC2D639E1D53>] >> startxref 698 %%EOF msm/vignettes/figures/p3q1246.eps0000755000176200001440000000616112250051206016253 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:30 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPK{l4Ollmeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:35:55en-GB13PT15M37SPK{l4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100 {8Ty{t^I?yݴ$sAh{mS'#%/[AZaC# b~\zы_~w#zgykv^ԝx} F% cKqkg^9@G&0=4@rnߏ79"*?4/2[A%O?1](sV{qg׽M{>a7dr0=zH?fLhϼ`*atsYPKʴ ELPK{l4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {si /ezV_Xfjsq}]i싂U=*r°{Z U8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(ձ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|1K-#韚ӗg%02 D2i3ByW@/6]?ogv4 AIae<菶扄zi_ZhpbIʔ C3Q`@"01|g΀Qf[h8"mQah+e'Gf/3J`T[_ԫ@k*e$4KC=~q}E2|1;MkÞxRGa80"fVng|'N;PK'f#PK{l4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPK{l4.++mimetypePK{l4QConfigurations2/statusbar/PK{l4'Configurations2/accelerator/current.xmlPK{l4Configurations2/floater/PK{l4Configurations2/popupmenu/PK{l4NConfigurations2/progressbar/PK{l4Configurations2/menubar/PK{l4Configurations2/toolbar/PK{l4Configurations2/images/Bitmaps/PK{l4IۈDq 1content.xmlPK{l4|3F styles.xmlPK{l4Oll meta.xmlPK{l4ʴ ELVThumbnails/thumbnail.pngPK{l4'f# settings.xmlPK{l4AN META-INF/manifest.xmlPKmsm/vignettes/figures/dags/p3q16.odg0000755000176200001440000001712412250051205017005 0ustar liggesusersPKVk4.++mimetypeapplication/vnd.oasis.opendocument.graphicsPKVk4Configurations2/statusbar/PKVk4'Configurations2/accelerator/current.xmlPKPKVk4Configurations2/floater/PKVk4Configurations2/popupmenu/PKVk4Configurations2/progressbar/PKVk4Configurations2/menubar/PKVk4Configurations2/toolbar/PKVk4Configurations2/images/Bitmaps/PKVk4 content.xmlWn }WD~wvj$դiOTiWj8N&nQu{I8{IwTLMьr"2ƋMǷ&~ZTt ٚu(`G\L.l`OE(y8z`^W?oR&Ey YA0pM++5)tTP}KmDe5X㳬6*qMa-sF+kWLLJ,̂ǥKer"7&d"5th/kv+wX\!7ݫN2M' ศ/";SC#aVҿfocƕ䌪YN-, k5=Nj%^![- Ķv:~ܳ|eMܻ1npA#4M-)9,d#_3,nO &Hͨi* IsYz8.dU+Vv1u9r䄪YUD;k[X>S \x5Ke1_:C]l/R,~&= oB.EO<0 ݮ!M:f9=Л@~+q[_RR0:L/jlW}l̸(o38hjQ%.%72zI=KSɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPKVk4iimeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:26:45en-GB9PT8M9SPKVk4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100qz8Ty{;P`ϑ}50X\A9ʦ_7~S3dv0|xE\ퟕVlW;#x^BRC[ʣW͒+ 3Ia!Z4a 6?y8^Yleإ{I ΰv~9k ?[qG} _odk1Q.g~pw1J?gX2Gja5Ou,<>*OqÑʈS׌Bph{70m0xsJhPK O(@BPKWk4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s~u}S/exV_Xf*sq}]i싂U=*p°{Z U8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(թ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|1K-#韚ӗg%02 D2i3ByW@/6]?ogt4 AIae:菶扄ziYhpbIʔ C3Q`@"01|g΀Qf[h8"mQah+e'Gf/3J`T[_ӫT yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPKVk4.++mimetypePKVk4QConfigurations2/statusbar/PKVk4'Configurations2/accelerator/current.xmlPKVk4Configurations2/floater/PKVk4Configurations2/popupmenu/PKVk4NConfigurations2/progressbar/PKVk4Configurations2/menubar/PKVk4Configurations2/toolbar/PKVk4Configurations2/images/Bitmaps/PKVk4rW 1content.xmlPKVk4|3F qstyles.xmlPKVk4ii meta.xmlPKVk4 O(@BThumbnails/thumbnail.pngPKWk49E~# settings.xmlPKWk4ANMETA-INF/manifest.xmlPKPmsm/vignettes/figures/dags/p2q1.ps0000755000176200001440000000571012250051204016564 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 757 199 814 %%HiResBoundingBox: 28.300000 757.000000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:09 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> /CCITTFaxDecode filter}!/FX{<> stream xM 0a]'=N UЍw2)BRG޼ox>R@> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152821+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000448 00000 n 0000000021 00000 n 0000000324 00000 n 0000000633 00000 n 0000000350 00000 n 0000000377 00000 n 0000000769 00000 n 0000000828 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ <0C24517CCB13A965D9C6104BA475DA8D> <0C24517CCB13A965D9C6104BA475DA8D> ] >> startxref 1018 %%EOF msm/vignettes/figures/dags/p3q124.ps0000755000176200001440000000613712250051204016737 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:09 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<MpSglRKbރa*|%Ur}%w6(Y.Ⱦ\Dp `sm<X1qPi(}5=PN9|f ٹ](`T^PQq!ŚRqFmPunDU'8\EњJ  8Ty2Ů*rM09|tIep,xuusEP\&t.XE$k٣}I5[jm]wi*=8 '&qѼeL!2FB|v_IE|߃cƕjX -,8 5=vEoB0lۓvDEl&FyDCGA wcFhZ j)q[12vX6d|ͱ̣q܁LQ0`96vq%$ 7c\ 0w0Ñ3ay^!oI֗,_.楲Z&u6$.bs.2`hgM(Jżh6CY'Ev2= TϴZGÐ}9= IJO/١̆gee#?6GSkr??|[ҿwLɡ.]ncB^־dז\ӆ\%Mf~PK6S PKSɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPK OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:33:57en-GB6PT4M45SPKĖgw]s5$g߁ héW3> 0]4_q>7c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8-}&&,r7:R71NrUsq~ {s ^TFr_U/\\_(`+`d .0BrNSEq Dj=cusDsFM| SM/y\}SaOb "`>WK1 !3"G4 ZdWb5b$Y'f eaRCY6\cG/J vn៛.#"%:mcU܏YK?GaX>؟c_/?)GQ  ~THBL1mHea`e3 D@g٦@gLpb}|iޕYRLRal|嫦eſC8Wqrhu)h] [e7>!p$g],Hjd|x|c .@Q]veN>nfLEtθ;-ɻ`'m 1OʍxItr":ѱ0}̃昀v^U\\ɱ8oO^sOeZ})6b╪튴9lfEtwXzD:QDZb'̉7EbybLC&0G1Xfq^FVOR 36Ha8m (mr }ڌ3vFwW襅(&}, q@RiX'24y"abv`+=X2%P (`-9L,r g&3}CN&FH[p-qJI|# XW*h}8(aC5R"3rE*h?POE_aj _D}DNӚ@6F:QN ١pPK.0#PKT yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPK> stream x}TIn1 7A/3 I55DtE|ۛqGɴ/ɼ~|#o[.yٷlŠe}$w߷v۷ z! CgGtq@?peHOhn LiM!H CS"Ѕ&IЂ -> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152514+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000714 00000 n 0000000021 00000 n 0000000590 00000 n 0000000899 00000 n 0000000616 00000 n 0000000643 00000 n 0000001035 00000 n 0000001094 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ ] >> startxref 1284 %%EOF msm/vignettes/figures/dags/p4q159.ps0000755000176200001440000000621212250051205016743 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 757 426 814 %%HiResBoundingBox: 28.300000 757.000000 425.200000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:10 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<Ts2ȶbDI 3`Ku2SpI\1Yɞ̯{-۩dq=8dSdSCzFĹ׫[B^pJk irt[䣃`2E b J x> %mdk'Zkfœ3]1vI:q,RYҐ[a[^Ap+]M]aGVi萯:B{ؽtB8@7- 'XqU3 p DvC0)jЋpG0si,GgL]셢ŒO. NצGwæڍ7h[$ͪ=s>1(?T,B>%'t nIW5v`\RI?. xKO񰈱A`WcνQTPk_37FquIk՜̟cuOjL>a&4!W^ u'뢋= t7++6V'3Йk@.x+3) *@2ŕNfĞjjآQi=:/`ȺR%Ei=>oVW<+qe q}.гrbKWZB]gzO]XDZ Wl PK3 PKk4 styles.xml\]r6~)8o$'j9Ly;:9De}z.)l+&3K~]`W.ƑqYFh4݉c8i@w| CE@< 2~$[(Y(#"A1_'B^ȩԈ|X_qɬKs| ކ,ZY2C۾‚0CW6Z>SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPKk48Aiimeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:28:28en-GB9PT8M9SPKk4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100{8Ty{`^I?y(3Ǚ*BzP7nz 02˹LK鶟=mW2]Է:yDzj>i76Wⴸa߭Ι$(/Î2W5CMF% $8@fys8~G1@]=h7UgyL R<]\9%4PKPFPPKk4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {si /ezV_Xfjsq}]i싂U=*r°{Z U8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(ձ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|1K-#韚ӗg%02 D2i3ByW@/6]?ogv4 AIae<菶扄zi_ZhpbIʔ C3Q`@"01|g΀Qf[h8"mQah+e'Gf/3J`T[_ԫ@k*e$4KC=~q}E2|1;MkÞxRGa80"fVng|'N;PK'f#PKk4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPKk4.++mimetypePKk4QConfigurations2/statusbar/PKk4'Configurations2/accelerator/current.xmlPKk4Configurations2/floater/PKk4Configurations2/popupmenu/PKk4NConfigurations2/progressbar/PKk4Configurations2/menubar/PKk4Configurations2/toolbar/PKk4Configurations2/images/Bitmaps/PKk43 1content.xmlPKk4|3F styles.xmlPKk48Aii meta.xmlPKk4PFPBThumbnails/thumbnail.pngPKk4'f# settings.xmlPKk4ANMETA-INF/manifest.xmlPK}msm/vignettes/figures/dags/p3q14.ps0000755000176200001440000000605112250051205016651 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 757 312 814 %%HiResBoundingBox: 28.300000 757.000000 311.800000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:10 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{< %}@dtiJ Ĥk3סvס)3OVY@]gpg+ĮeR!I4{tBx7q^wj"8z CyhHZ7-!@`g_;I`wpJҐ+ʢw`gL 93ӓa7^+'^ Fd>]Hp%D ƴI<J¶hnד=C%m)Ԕs& {Y67d)d2@f)`_Ψb\F HVo_#k*WjIHH)X^ @/ P '≺u'?ۺ$t{v P\eT8{Ͻ掞;ϚJӻ*!SƮ}m)DF`2N/[4ads%ڔP&u0q4G|w[5W3sV"'xZGV}BVֳ_7sw}ISɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|fqV;5 xl-Աz2-Ա:P"4PiP= ZKD+lP)Lr_¦[4j lx8{&NW.7|9Y~S#jA|kp*UwbirǺzO걮걮>mƺuzw|REh)Bj3@\yr 4g^ahы^浰l0'OYˍ:!"c9UL JUw9Rr+Tnxm!m＆[|ﺊWx}$1kw4 rCtZNțKjpyUf(%V>Q_0̸z4w[m/0>3Da#-H~[ iokFsps+?W%Aj5~k! Y 8X"Ow[YBJ=,r'$KέDz:v?P B2.]z= OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:23:27en-GB6PT5M43SPKj4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100tq F WA{Omc_aci? t޶bw]x dI˵4C2؝Iw?3p~u?*# J}:<w~&9eW#WV`ɻ坙WUu]i3::$F3g6r֗^OW?uN MPKyPKj4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s^ r^/J^,3. _ QT4WE*U9|]DaX =-*!~8{3 4(1(0-%^$-ž9rELO}.Z2bCfDbqh@@ -]GX=j$=#8I1N6TdKL{WUä:l(ձ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|g\yRmEd=HWCm,щ0g4<դt<'ů:8Ky{ڽ5~BX-OЧkݍTmW̹`33.HռB=.҉"r ;cN^.c29Td2 կ2 }bZG?5/MiK`DG1eldf셀6_l2~8?/-D94AciXpJx>m ۵[_Ē)g@dmVDaJ&eic:3 83̶p21REڂh9VN,^f@W17DÁ6F [UTHi+R)&)z*Veb#v=!4 ApaD=N wPK#PKj4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPKj4.++mimetypePKj4QConfigurations2/statusbar/PKj4'Configurations2/accelerator/current.xmlPKj4Configurations2/floater/PKj4Configurations2/popupmenu/PKj4NConfigurations2/progressbar/PKj4Configurations2/menubar/PKj4Configurations2/toolbar/PKj4Configurations2/images/Bitmaps/PKj4Ccf+3 1content.xmlPKj4MqF styles.xmlPKj4{jj meta.xmlPKj4yCThumbnails/thumbnail.pngPKj4# \settings.xmlPKj4ANMETA-INF/manifest.xmlPKmsm/vignettes/figures/dags/p2q1.odg0000755000176200001440000001676112250051204016723 0ustar liggesusersPKj4.++mimetypeapplication/vnd.oasis.opendocument.graphicsPKj4Configurations2/statusbar/PKj4'Configurations2/accelerator/current.xmlPKPKj4Configurations2/floater/PKj4Configurations2/popupmenu/PKj4Configurations2/progressbar/PKj4Configurations2/menubar/PKj4Configurations2/toolbar/PKj4Configurations2/images/Bitmaps/PKj4 content.xmlVAo WD;&VjҴS+U&Jۨ, q_ԝ7i%1|ޝj82m$[DQ.]&ۿ۪TCͤM&]r2WpK\3[ɞ܏z=tٖ\Îi\Â1Ps'#Bu-$|%MP۶vTD-A0pA 1`e ؚYX$;aGExvdIQ`P~p6 .Y7'}w|# $+Ś&{;Jh0A[ .r$,pxXX 0wt#T)~F([[X?3 \8ҖSwkR':b|ZWIWS`P(/ⅺqd“Ewt Z]; \*|'V揞?/ ػp\Xk(68^Z+2iF%E뱯|v9eE+F'82sxoW</q~C|CĭD)%a,VeCJ?\";&?PKU PKj4 styles.xml\]r6~)8o$'j9Ly;:9De}z.)l+&3K~]`W.ƑqYFh4݉c8i@w| CE@< 2~$[(Y(#"A1_'B^ȩԈ|X_qɬKs| ކ,ZY2C۾‚0CW6Z>SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|fqV;5 xl-Աz2-Ա:P"4PiP= ZKD+lP)Lr_¦[4j lx8{&NW.7|9Y~S#jA|kp*UwbirǺzO걮걮>mƺuzw|REh)Bj3@\yr 4g^ahы^浰l0'OYˍ:!"c9UL JUw9Rr+Tnxm!m＆[|ﺊWx}$1kw4 rCtZNțKjpyUf(%V>Q_0̸z4w[m/0>3Da#-H~[ iokFsps+?W%Aj5~k! Y 8X"Ow[YBJ=,r'$KέDz:v?P B2.]z= OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:21:39en-GB4PT3M55SPKj4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100tq F WA=/X1.}*X?۟.!A0O]'7}KƏM02P}4Q2󺂬U :w Qѹ~ڑ. >rQ*5K) PKbPKj4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s ^V/e|V_Xfsq}]i싂U=*t°{Z U 8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(չ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|sAsLS]JsxRZ\}S.XaZs'2}zXJvEZϜ 63j:T];,c="("G-FQ"<1&!HEf,Z8/+'f{$Ss0 FtS_ƶZH>m^; h#F߻+B O>U@A8 4<0QO];M[ N,Ia(x0JlH`TV93>!l '#U-88 m$>reY ,j zsC>hmcUEաĚf)"R`b"/޿hZ/">"`iMsO@T( 'F ݃oeyi~PKHo3#PKj4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPKj4.++mimetypePKj4QConfigurations2/statusbar/PKj4'Configurations2/accelerator/current.xmlPKj4Configurations2/floater/PKj4Configurations2/popupmenu/PKj4NConfigurations2/progressbar/PKj4Configurations2/menubar/PKj4Configurations2/toolbar/PKj4Configurations2/images/Bitmaps/PKj4U 1content.xmlPKj4MqF styles.xmlPKj4HTjj meta.xmlPKj4b0Thumbnails/thumbnail.pngPKj4Ho3# 7settings.xmlPKj4ANiMETA-INF/manifest.xmlPKmsm/vignettes/figures/dags/p4q159.odg0000755000176200001440000001705612250051205017102 0ustar liggesusersPKl4.++mimetypeapplication/vnd.oasis.opendocument.graphicsPKl4Configurations2/statusbar/PKl4'Configurations2/accelerator/current.xmlPKPKl4Configurations2/floater/PKl4Configurations2/popupmenu/PKl4Configurations2/progressbar/PKl4Configurations2/menubar/PKl4Configurations2/toolbar/PKl4Configurations2/images/Bitmaps/PKl4 content.xmlW]o }߯P'XqIӞZ6i'&3wR۽${9r$Cf{"HU2# LyU$?|K?'7kQ )\ash$TTD!g1:wkl2݁c&=l.|l,a;l1SR HZ79m\ d hIPˆ]Ll[ XDN. lWIt1( &k_m3Ze[ecn vd?;tw'_zZ;(G|!Dj ;#t{J"ABE\ .|8Dj> w%5<)JC~) ;bZd+Xltt6=6E7^0wZX6JIV?sE,&Jh͔i+qj%Ϩ͖~^Onz+'{;JHS)Q3+ /)3%炛Mp0VHxU/}:j1s(K-^1G" ״6 n|Q$_s7/LQK: E(Dٺ`]Actݬ]>]Վ3W]+)YsgISiήiW%dSLI/&}t$A\;Taֺ# unN﫼3o :8?f~5A{~8<'n/Y| gEBd#gҵu]oi=e{ tS  "PKl;kPKl4 styles.xml\]r6~)8o$'j9Ly;:9De}z.)l+&3K~]`W.ƑqYFh4݉c8i@w| CE@< 2~$[(Y(#"A1_'B^ȩԈ|X_qɬKs| ކ,ZY2C۾‚0CW6Z>SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|fqV;5 xl-Աz2-Ա:P"4PiP= ZKD+lP)Lr_¦[4j lx8{&NW.7|9Y~S#jA|kp*UwbirǺzO걮걮>mƺuzw|REh)Bj3@\yr 4g^ahы^浰l0'OYˍ:!"c9UL JUw9Rr+Tnxm!m＆[|ﺊWx}$1kw4 rCtZNțKjpyUf(%V>Q_0̸z4w[m/0>3Da#-H~[ iokFsps+?W%Aj5~k! Y 8X"Ow[YBJ=,r'$KέDz:v?P B2.]z= OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:39:57en-GB7PT22M13SPKl4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100^tq F4!G{O]dW *{}ͯ Odm>/22/Wܢq7?rprF% J~&O6/Ozx[w 0|`~p-uu]["`pdACWE!`$3xsJhPKW PKl4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s^V+ 2V_Xfjsq}]i싂U=*r°{Z U8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(ձ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|nfTLEtθ;,ɻ_l 1OxItj":ѱ0}挃昀v^U\\ɱ8oO^sOeZ})6`╪튴9lfEtwXz@:QDZa'}̉7EbybLC&0G1XfWq^FVOR 36Ha8m (mur|ڌ3uFwW祅(ۙ&}, q@RiX'24y"abv`+=X2%P (`-9L,r _g&3}CN&FH[p-qJI|#̱X*h}8(aC5R"3rE*d?POE__j C}DNӚ@6F:QN ١pPK!#PKl4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPKl4.++mimetypePKl4QConfigurations2/statusbar/PKl4'Configurations2/accelerator/current.xmlPKl4Configurations2/floater/PKl4Configurations2/popupmenu/PKl4NConfigurations2/progressbar/PKl4Configurations2/menubar/PKl4Configurations2/toolbar/PKl4Configurations2/images/Bitmaps/PKl4l;k 1content.xmlPKl4MqF styles.xmlPKl4XFakk meta.xmlPKl4W TThumbnails/thumbnail.pngPKl4!# usettings.xmlPKl4ANMETA-INF/manifest.xmlPK*msm/vignettes/figures/dags/p3q12.ps0000755000176200001440000000605212250051204016647 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:09 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<,T0,'ԉ$Wf 5>nCTEҴ43Δ/Ubjk Me2Q.WYs~uqj@ͤ5!cFuG/,ُtW 3I]t[; psf@gP*Lwo8R]#y܁Y ^=<#%3X=Z*6ydOtjwja.M6*;ĩ>%.qh#WU 6#]ZGꚽGœ9̕MYjQ4SGgLjtwUfþ}j0mtpgv_+ sBWQv3,{Oeg [fo`w?YPK-bTPK@r4 styles.xml\]r6~)8o$'j9Ly;:9De}z.)l+&3K~]`W.ƑqYFh4݉c8i@w| CE@< 2~$[(Y(#"A1_'B^ȩԈ|X_qɬKs| ކ,ZY2C۾‚0CW6Z>SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPK@r4%۹mmmeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T15:18:00en-GB10PT58M15SPK@r4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100mtq ŢfVOmgPj&.ƛ\ юqwe_΍@ALYtˬe=>5~Y\j V! 1Mx {f]ۡ|sYٺӃ$YoybΘgWgaٶ17]w1&~Zgkvq[ǜeg-]}d_A', _>1pzwmoXMm7M?{g& cRqg߫l8 Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s~],2 V/J^,3. _ QT4WE*U9|]DaX =-*!~8{3 4(1(0-%^$-ž9rELO}.Z2bCfDbqh@@ -]GX=j$=#8I1N6TdKL{Wժ)CY6\cG/J vn៛.#"%:mcU܏YK?GaX>؟c_?)GQ  ~THBL1mHea`e3 D@g٦@gLpb}|iޕYRLRalvjͱV˴SmZwc+Ui9s.̌*8Re5PtNoFĘL`b"̮k+㼌xflOK3pQL}"{!`g+mﮌK Qη3;MXV Ұ2OdhG[cDD=v4V/-z48$eJP(Y[ s҃IYZL3g(-4LT(Z0#F}c%-/U pQVU2kDfTJ~x8zj5am<uP0@C+3t}PK@ n#PK@r4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPK@r4.++mimetypePK@r4QConfigurations2/statusbar/PK@r4'Configurations2/accelerator/current.xmlPK@r4Configurations2/floater/PK@r4Configurations2/popupmenu/PK@r4NConfigurations2/progressbar/PK@r4Configurations2/menubar/PK@r4Configurations2/toolbar/PK@r4Configurations2/images/Bitmaps/PK@r4-bT 1content.xmlPK@r4|3F styles.xmlPK@r4%۹mm meta.xmlPK@r4B@gThumbnails/thumbnail.pngPK@r4@ n# settings.xmlPK@r4ANMETA-INF/manifest.xmlPKSmsm/vignettes/figures/dags/p2q12.ps0000755000176200001440000000577212250051204016656 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 757 199 814 %%HiResBoundingBox: 28.300000 757.000000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:09 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<WGSrWS?|9qKmYtbJbTkt]<Ү.]i~F~Fd%Q׼Pm\rTM.˱A W_PKWy3PKv4 styles.xml\]r6~)8o$'j9Ly;:9De}z.)l+&3K~]`W.ƑqYFh4݉c8i@w| CE@< 2~$[(Y(#"A1_'B^ȩԈ|X_qɬKs| ކ,ZY2C۾‚0CW6Z>SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPKv43llmeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T15:54:36en-GB13PT30M8SPKv4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100Iy8Ty{!?Up6-L9iӢnfR!bxA瑉oܲ}g.UP>3۾t?Y&őѨvlc::ٴ2GW93c]vc򓮙uW>u{Z~[$8`%._~'Zp#)_L+}5&OW?uN MPK.LSPKv4 settings.xmlZs6~_L$w'pφ9]߄YHJƤ' #󌼱8, N ͭo.mަD7*XB}ky GQ~`XF?dZЄE\G!iV굛Ϸ!Oa.Яo/KB]]\K^,3>}*_ QT4e*Y;|]DcX =5*%~8{3 4(1(0-%^$-ž9rEL}K1X!-BkCWh1V[<z" #F։نj@sZ5es(ˆR Z]|H˶R[aH6C?C*P%?aX>؟b __=S.W[pߌ  ~THBL1mHI+Gcʇ ^s2,% xb1'a*͢<GfrW҉"\|2; qWMѽz_eƹC[|KAtؒ5-[!#ɸ=|eIJ-DY*ZL,6-s)t _4#g*sn$qځɞ @mb?tkEYO.PKEtca4i1O) Jks9Ncqޞ޷vjͱVӴcZwc+UiBs.̌J8R5Put5N*oFĘL`b"k+sX>1K-!韚ӗW%02U Di3LNyW@6 ]vK Qη=MXf $ӰҠOdh[DDbv`+=!eJ P(Y[= s҃^Y>!, ;#-88 mI|#tXU*h}(aC5R"3ΊTJ~vE}cj D}DNњ@[sO@]T* 'Fʭ ݃eyiPK_#PKv4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPKv4.++mimetypePKv4QConfigurations2/statusbar/PKv4'Configurations2/accelerator/current.xmlPKv4Configurations2/floater/PKv4Configurations2/popupmenu/PKv4NConfigurations2/progressbar/PKv4Configurations2/menubar/PKv4Configurations2/toolbar/PKv4Configurations2/images/Bitmaps/PKv4Wy3 1content.xmlPKv4|3F styles.xmlPKv43ll meta.xmlPKv4.LSEThumbnails/thumbnail.pngPKv4_# settings.xmlPKv4ANMETA-INF/manifest.xmlPKmsm/vignettes/figures/dags/p3q1246.ps0000755000176200001440000000622312250051204017021 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:09 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream x}Tn1 C *F9 Pʅǎl,B=&?PK~~Ţʃ ~⃌}XLg(aVR2ם-X:*vUǍSDNYuQg~aY055Kl>+Uue*VTiԬs4V2;Jd7Vd{YxQ%nYedm V! :q9N٦Au8fF؎quey;sUsMR\yJW*s -F6Hb ݙЙuTHPry{CI݇:Y,Y[|U-㶊ACAE?{D7\rdp^鶙7#vl^endstream endobj 3 0 obj 409 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152535+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000639 00000 n 0000000021 00000 n 0000000515 00000 n 0000000824 00000 n 0000000541 00000 n 0000000568 00000 n 0000000960 00000 n 0000001019 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ <9D5AA8DE0D7CBF3727E646EC8D851B8E> <9D5AA8DE0D7CBF3727E646EC8D851B8E> ] >> startxref 1209 %%EOF msm/vignettes/figures/dags/p3q14.pdf0000755000176200001440000000255312250051205017003 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj << /Length 3 0 R /Filter /FlateDecode >> stream xmQI0 G|`Iܺ/@xPA~섂He2c;XzApS.>VXOK!e"V7Zi萊89*? EF ~̫Keûo6z=4aS> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152830+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000453 00000 n 0000000021 00000 n 0000000329 00000 n 0000000638 00000 n 0000000355 00000 n 0000000382 00000 n 0000000774 00000 n 0000000833 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ ] >> startxref 1023 %%EOF msm/vignettes/figures/dags/p3q12.pdf0000755000176200001440000000255512250051204017002 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj << /Length 3 0 R /Filter /FlateDecode >> stream x=0 Hg(n8=0p~ ,>J*PU՟zy'G8nZ%@Z# ]5] ̱)q9Zsfo;fK8i18!Tuϔ>9{AUaN= r}aDjR#Ӫea7$7Իw`"d(`d,$4(5ҿ%Yw$mjendstream endobj 3 0 obj 225 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152844+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000455 00000 n 0000000021 00000 n 0000000331 00000 n 0000000640 00000 n 0000000357 00000 n 0000000384 00000 n 0000000776 00000 n 0000000835 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ ] >> startxref 1025 %%EOF msm/vignettes/figures/dags/p2q1.pdf0000755000176200001440000000247012250051204016713 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj << /Length 3 0 R /Filter /FlateDecode >> stream xe= 0 w9lVNPv CI ͒ǎc7~dt xKovy8eJOQ" 8%.,Te1W8X^?j562S% #'#ͫ҄:`bݺ佾@}LBendstream endobj 3 0 obj 173 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152908+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000403 00000 n 0000000021 00000 n 0000000279 00000 n 0000000588 00000 n 0000000305 00000 n 0000000332 00000 n 0000000724 00000 n 0000000783 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ <6E0EC88F90721DE09933C42F4A56F82D> <6E0EC88F90721DE09933C42F4A56F82D> ] >> startxref 973 %%EOF msm/vignettes/figures/dags/p5q1_6_7_11_12.ps0000755000176200001440000000645112250051205020051 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 643 312 814 %%HiResBoundingBox: 28.300000 643.600000 311.800000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:55:21 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> /CCITTFaxDecode filter}!/FX{<> stream xmM 0a] ;Tnz}3I#J)G| )^C jp)*Yc<M zYmn&(MA!mpM@R_n5@2_6r$Av6Uڸd&ȄSCEk0 [AG-J}}JXL-XVIendstream endobj 3 0 obj 203 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152859+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000433 00000 n 0000000021 00000 n 0000000309 00000 n 0000000618 00000 n 0000000335 00000 n 0000000362 00000 n 0000000754 00000 n 0000000813 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ ] >> startxref 1003 %%EOF msm/vignettes/figures/dags/p5q1_6_11_16.pdf0000755000176200001440000000271412250051205017754 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj << /Length 3 0 R /Filter /FlateDecode >> stream x}Rn #>ŀzk/CUZ{_ݨ"y0jL\.v_kz$kJnfƳ ^4BVk9[P1U.Pux|恉9SKzGBC) iLuݔj}{6=IϑzгdD =YT5BU%)KH7@jՍ=j.pCztRKp# kSc~̎pjfrd AjA{٣ֻ9Է$ze).endstream endobj 3 0 obj 320 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621155455+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000550 00000 n 0000000021 00000 n 0000000426 00000 n 0000000735 00000 n 0000000452 00000 n 0000000479 00000 n 0000000871 00000 n 0000000930 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ <3C103CC8F41886FCB09AD9858B892A3F> <3C103CC8F41886FCB09AD9858B892A3F> ] >> startxref 1120 %%EOF msm/vignettes/figures/dags/p3q135.odg0000755000176200001440000001715312250051204017070 0ustar liggesusersPK2l4.++mimetypeapplication/vnd.oasis.opendocument.graphicsPK2l4Configurations2/statusbar/PK2l4'Configurations2/accelerator/current.xmlPKPK2l4Configurations2/floater/PK2l4Configurations2/popupmenu/PK2l4Configurations2/progressbar/PK2l4Configurations2/menubar/PK2l4Configurations2/toolbar/PK2l4Configurations2/images/Bitmaps/PK2l4 content.xmlW]o }߯;ZIIӞZ6i'nI9lnX6\m,WтI(6[9}ڨSɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPK2l40>7llmeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:33:35en-GB11PT13M17SPK2l4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100~tq UM [qywrfx/B% ;NozRo]<>:8+Rzn4^$?\|,C}tK^Kʷ) NqߵN^QT^ gMs Ҋ%ި=o-SZ"w(ZqaFgV3]x 024Z[PsC?00xsJhPK=%+PK2l4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {si /ezV_Xfjsq}]i싂U=*r°{Z U8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(ձ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|1K-#韚ӗg%02 D2i3ByW@/6]?ogv4 AIae<菶扄zi_ZhpbIʔ C3Q`@"01|g΀Qf[h8"mQah+e'Gf/3J`T[_ԫ@k*e$4KC=~q}E2|1;MkÞxRGa80"fVng|'N;PK'f#PK2l4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPK2l4.++mimetypePK2l4QConfigurations2/statusbar/PK2l4'Configurations2/accelerator/current.xmlPK2l4Configurations2/floater/PK2l4Configurations2/popupmenu/PK2l4NConfigurations2/progressbar/PK2l4Configurations2/menubar/PK2l4Configurations2/toolbar/PK2l4Configurations2/images/Bitmaps/PK2l4ٖ; 1content.xmlPK2l4|3F styles.xmlPK2l40>7ll meta.xmlPK2l4=%+MThumbnails/thumbnail.pngPK2l4'f# settings.xmlPK2l4ANMETA-INF/manifest.xmlPKgmsm/vignettes/figures/dags/p3q124.pdf0000755000176200001440000000260112250051204017056 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj << /Length 3 0 R /Filter /FlateDecode >> stream x}QKj1 |?c ٥YmBMي 0ϲ5Ks=\sָzWMX&̐S_k> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152809+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000475 00000 n 0000000021 00000 n 0000000351 00000 n 0000000660 00000 n 0000000377 00000 n 0000000404 00000 n 0000000796 00000 n 0000000855 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ ] >> startxref 1045 %%EOF msm/vignettes/figures/dags/p3q135.pdf0000755000176200001440000000261012250051204017060 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj << /Length 3 0 R /Filter /FlateDecode >> stream x}QKjC1 |>A4k<Xvp%P+mӃ. ֤J*eoR@!5 f͇5'k8aNt<Iz+ίA*݀&b(B|w"k:UA̭Ŵ S Z?G❝Xtw}bAR0t_b }endstream endobj 3 0 obj 252 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152716+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000482 00000 n 0000000021 00000 n 0000000358 00000 n 0000000667 00000 n 0000000384 00000 n 0000000411 00000 n 0000000803 00000 n 0000000862 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ <9BE3F9135CD5B57B7682B0B733769DBE> <9BE3F9135CD5B57B7682B0B733769DBE> ] >> startxref 1052 %%EOF msm/vignettes/figures/dags/p5q1_6_11_16.odg0000755000176200001440000001706412250051205017760 0ustar liggesusersPKWr4.++mimetypeapplication/vnd.oasis.opendocument.graphicsPKWr4Configurations2/statusbar/PKWr4'Configurations2/accelerator/current.xmlPKPKWr4Configurations2/floater/PKWr4Configurations2/popupmenu/PKWr4Configurations2/progressbar/PKWr4Configurations2/menubar/PKWr4Configurations2/toolbar/PKWr4Configurations2/images/Bitmaps/PKWr4 content.xmlW_o |ߧP'XqIӞZ6i'?/wgd}olGI6Hf#)zi-ʒ"c :Ek=3lZ$[sU9 QFh ?,![%[ Gv%bkL 饈%KKa\oZ#{FCZ9]ͻ\ d ++?xZW}LZ._s-3jY6ջv9Uo {`t؛PKnEPKWr4 styles.xml\]r6~)8o$'j9Ly;:9De}z.)l+&3K~]`W.ƑqYFh4݉c8i@w| CE@< 2~$[(Y(#"A1_'B^ȩԈ|X_qɬKs| ކ,ZY2C۾‚0CW6Z>SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPKWr43Kkkmeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T15:18:46en-GB9PT23M57SPKWr4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100^tq F WESE-;{ѣy=umz% ;NozSurن;bͽJ)$5t0*>{ħYĖgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s ^]V/e|V_Xfsq}]i싂U=*t°{Z U 8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(չ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|sAsLS]JsxRZ\}S.XaZs'2}zXJvEZϜ 63j:T];,c="("G-FQ"<1&!HEf,Z8/+'f{$Ss0 FtS_ƶZH>m^; h#F߻+B O>U@A8 4<0QO];M[ N,Ia(x0JlH`TV93>!l '#U-88 m$>reY ,j zsC>hmcUEաĚf)"R`b"/޿hZ/">"`iMsO@T( 'F ݃oeyi~PK٤/#PKWr4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPKWr4.++mimetypePKWr4QConfigurations2/statusbar/PKWr4'Configurations2/accelerator/current.xmlPKWr4Configurations2/floater/PKWr4Configurations2/popupmenu/PKWr4NConfigurations2/progressbar/PKWr4Configurations2/menubar/PKWr4Configurations2/toolbar/PKWr4Configurations2/images/Bitmaps/PKWr4nE 1content.xmlPKWr4|3F styles.xmlPKWr43Kkk meta.xmlPKWr4 VThumbnails/thumbnail.pngPKWr4٤/# zsettings.xmlPKWr4ANMETA-INF/manifest.xmlPK0msm/vignettes/figures/dags/p5q1_6_7_11_12.pdf0000755000176200001440000000275212250051205020200 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj << /Length 3 0 R /Filter /FlateDecode >> stream xRj0 {AzKsAq %j%ˎK  M_d"`p}heS|i`J|k>/Gt4+[AMָ&k7 uqJr( D1eiM.ЛDa4P(Z1*q¾3Gc33GLrfL=U/(>sw-,PUX+J`$̭'m'bYZEG+bWkkJ2H۠o9'i7-=Eq1h/oHt胘3DV63=N쯋uA&7՜endstream endobj 3 0 obj 350 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621155441+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000580 00000 n 0000000021 00000 n 0000000456 00000 n 0000000765 00000 n 0000000482 00000 n 0000000509 00000 n 0000000901 00000 n 0000000960 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ <58D06F6B2D57E47E8526B6AEAD0C21F9> <58D06F6B2D57E47E8526B6AEAD0C21F9> ] >> startxref 1150 %%EOF msm/vignettes/figures/dags/p5q1_4_6_8_11_12_16.ps0000755000176200001440000000706012250051205020600 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 643 539 814 %%HiResBoundingBox: 28.300000 643.600000 538.600000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:55:21 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<;"DbE8%g9. ❎|b0܃E:?P+xCB茨H= ;ZHw4Y:6=86A`'^n%l,6kΓ mȠR~PMvo kSs~B9 r}<В)iн5W&pIhqFJe9eTMiЇz u2%ɕHs9U4-͈3K㛿*ȟ1W\5 I2Q *Is֜cI'P@3ނ5!cF u'D'6ժwhJI~[3-qgb6꣦L]]e*X!LP + Zu#y,~z*%<\]V*wyFA?tj~6_WQ▯9qSɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|fqV;5 xl-Աz2-Ա:P"4PiP= ZKD+lP)Lr_¦[4j lx8{&NW.7|9Y~S#jA|kp*UwbirǺzO걮걮>mƺuzw|REh)Bj3@\yr 4g^ahы^浰l0'OYˍ:!"c9UL JUw9Rr+Tnxm!m＆[|ﺊWx}$1kw4 rCtZNțKjpyUf(%V>Q_0̸z4w[m/0>3Da#-H~[ iokFsps+?W%Aj5~k! Y 8X"Ow[YBJ=,r'$KέDz:v?P B2.]z= OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:41:37en-GB11PT23M52SPK2m4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100Mtq  {wCˢg;}*[r]]Ylz+v{[//oK,KޛI r`Hn}нggBWTouXKCiAGCr_amvq̹+b{/>뿆\3oセ獾b5H 2zqK|Jζwjfϔ;z9vMo줾_^5-}w)%o?.T'%0}ъ_? ?5ZV{]?=WTW+m v=c }Sg˾"h,ۙ]Pbe4l.R<]\9%4PKE PK2m4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s~uq{[/ezV_Xfjsq}]i싂U=*r°{Z U8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(ձ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|1K-#韚ӗg%02 D2i3ByW@/6]?ogv4 AIae<菶扄zi_ZhpbIʔ C3Q`@"01|g΀Qf[h8"mQah+e'Gf/3J`T[_ԫ@k*e$4KC=~q}E2|1;MkÞxRGa80"fVng|'N;PK'#PK2m4META-INF/manifest.xmlKj0@=VU1q-&fW6X; HFi[S0Oͣ)k7vc^aaӠNZu`ZVzEdZ>T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPK2m4.++mimetypePK2m4QConfigurations2/statusbar/PK2m4'Configurations2/accelerator/current.xmlPK2m4Configurations2/floater/PK2m4Configurations2/popupmenu/PK2m4NConfigurations2/progressbar/PK2m4Configurations2/menubar/PK2m4Configurations2/toolbar/PK2m4Configurations2/images/Bitmaps/PK2m4"W{Tgl 1content.xmlPK2m4MqF styles.xmlPK2m4Vtmm meta.xmlPK2m4E Thumbnails/thumbnail.pngPK2m4'# settings.xmlPK2m4ANMETA-INF/manifest.xmlPKSmsm/vignettes/figures/dags/p3q16.ps0000755000176200001440000000605112250051205016653 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 643 199 814 %%HiResBoundingBox: 28.300000 643.600000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:10 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream x}Qj0 :A%GBo}PB_۲6ь4rp\h%L)^NmkB<|ZCXh/kcld۬lm8*Z5uyC`v].e`T󧌹TW Az;ͩt]EٳL#H> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152615+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000501 00000 n 0000000021 00000 n 0000000377 00000 n 0000000686 00000 n 0000000403 00000 n 0000000430 00000 n 0000000822 00000 n 0000000881 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ <30714F62D20957CAE82C55C9381F3FD8> <30714F62D20957CAE82C55C9381F3FD8> ] >> startxref 1071 %%EOF msm/vignettes/figures/dags/p4q13569.ps0000755000176200001440000000663112250051205017121 0ustar liggesusers%!PS-Adobe-3.0 %%Pages: (atend) %%BoundingBox: 28 643 426 814 %%HiResBoundingBox: 28.300000 643.600000 425.200000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (pswrite) %%CreationDate: 2006/06/21 15:30:10 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_pswrite_2_0_1001 /GS_pswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream x}RIn0 xABY tAh.~؎a g#\O5 f~zd+ϐ˻:6.S(ZAKJ%:FX}zwZ iOzL$ͼU?nDI|86Fdqܢ6 >ǚPuRBf8Y"y4RX0n_"e0zWI!E@1LN[Xy5 @⯌HVڎO,"ͶĞi(d/uRp؍nDn$(Pendstream endobj 3 0 obj 287 endobj 5 0 obj << >> endobj 6 0 obj << /Font 5 0 R /ProcSet [ /PDF /Text ] >> endobj 1 0 obj << /Type /Page /Parent 4 0 R /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Group << /S /Transparency /CS /DeviceRGB /I true >> /Contents 2 0 R >> endobj 4 0 obj << /Type /Pages /Resources 6 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 1 0 R ] /Count 1 >> endobj 7 0 obj << /Type /Catalog /Pages 4 0 R >> endobj 8 0 obj << /Creator /Producer /CreationDate (D:20060621152643+01'00') >> endobj xref 0 9 0000000000 65535 f 0000000517 00000 n 0000000021 00000 n 0000000393 00000 n 0000000702 00000 n 0000000419 00000 n 0000000446 00000 n 0000000838 00000 n 0000000897 00000 n trailer << /Size 9 /Root 7 0 R /Info 8 0 R /ID [ ] >> startxref 1087 %%EOF msm/vignettes/figures/dags/p3q12.odg0000755000176200001440000001712712250051204017003 0ustar liggesusersPK-k4.++mimetypeapplication/vnd.oasis.opendocument.graphicsPK-k4Configurations2/statusbar/PK-k4'Configurations2/accelerator/current.xmlPKPK-k4Configurations2/floater/PK-k4Configurations2/popupmenu/PK-k4Configurations2/progressbar/PK-k4Configurations2/menubar/PK-k4Configurations2/toolbar/PK-k4Configurations2/images/Bitmaps/PK-k4 content.xmlWn }WD~wvZ$դiOTiWj$NCpShֽ$r{$CT*&&dF9&k)~Xd r5|πUf7N\`TqKUI.:OP +♺}dE8P۵MKi5l0 <3 T KJJzx84h`; |8?{zf\SV:O k3FyE%:K"rʫZN.#u}օ|kӷ5% PKր PK-k4 styles.xml\]r6~)8o$'j9Ly;:9De}z.)l+&3K~]`W.ƑqYFh4݉c8i@w| CE@< 2~$[(Y(#"A1_'B^ȩԈ|X_qɬKs| ކ,ZY2C۾‚0CW6Z>SɎI- ¶d;P|nKj_9$W8bv']Ƙ ^]$Wq)/=Hiͺwݬ;`73tiU.#Xs ?jbq߹o*[V R]qfqooiAvE~8@> Ijp ^UHŗeUBd 3C_L4?0Fλ!x.Mp 1]\1}y.!ʣ"j,D`\3no)bHY)' (H9R$`XQnYy\Znm43.鐰bAR8#>/) Z1 $6%X,6(Be9J ͪ؅]{ tk}QHy`IHF%f~& ƟxkMcZK GJ1"z|PYXu09< tmJpW$@5J2KB8[BЩdPK\(WTm$]_?6RbGjKrM&vF,،$@,0 ~2!07@E vqcpϟ4LnU NBtCXM]Rb $* JPnq f w&+ʹm\P7EAܓH-m&Xtz )R*" E-"Y⠱4+[kXxE#sH&SevF!ug$)#7koĊ d*DGDhz4܉*W&Wۣ!4};>4O +#": +Qk0? έQZhp>[[ng|uV7&YN!%p3Ō|f)i&'ctl,BctlV٥,AY5NvՎ$%l6w Go/\Ucrx×{h:MϺRW{'&ǺzǺd걮걮Fh^WXگw˷:Uj=&:A_n0 /@su1VH@j^*obAá{Zd܉#,1FYΞ#^Pu*׸UK=ஈ΋Gx ׷JB þvGs+l9I/ fVWSoKB_`3!͌wOzNS8C6~?҂t/` }p/Vf47W~,;/o^2V%t}K%"* -NdW<3n (2/ÓŐ8՟ՊbQwnV"Rrٻv(P c WMt\':6-zǶkwPK|3FPK-k4Tjjmeta.xml OpenOffice.org/2.0$Win32 OpenOffice.org_project/680m5$Build-90112006-06-21T14:17:492006-06-21T14:25:26en-GB8PT6M50SPK-k4Thumbnails/thumbnail.png sb``p ҅@ HZ4G100q{8Ty{t!n]Vzؚ#{w}߶Wv0t8ҰVqE׭/lO~z}3*uH($5t9?nx^x=Z*<9r/Ty^FgAc?J,j.ѭMb<ҝNq9OJݶKO??ٝ;U6v۱n~y;O|v i9L732ܐyfZ ":`2#e 0u0xsJhPKӞrBDPK-k4 settings.xmlZms6_L?yi 0G7a/F<|1)Qi>Ėgw]s5$g߀ héW3> 0]4_q>5c9 @eEj8S۩6N̩ǐ£(Ic6ow\y%4纫|uq­޺҈PPH& gW/lVg)7l%׫Kwv1)*K,3V(^:5;w7ݺy` YzYk8 -}&&,r7:R71NrUsq~ {s~u}S/exV_Xf*sq}]i싂U=*p°{Z U8M53Cq09g@iP71bLQ4aZJqIZ L=!s)8f/\].e3d̈рhZ[ _.GzH{#Gp)0bdm.ȖUS6l(թ\_|4?7 3]F*EJt* ǪC=TfÁ;T|?9՟9R.Ws32 ,b xI+b^e/g|1K-#韚ӗg%02 D2i3ByW@/6]?ogt4 AIae:菶扄ziYhpbIʔ C3Q`@"01|g΀Qf[h8"mQah+e'Gf/3J`T[_ӫT yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPK-k4.++mimetypePK-k4QConfigurations2/statusbar/PK-k4'Configurations2/accelerator/current.xmlPK-k4Configurations2/floater/PK-k4Configurations2/popupmenu/PK-k4NConfigurations2/progressbar/PK-k4Configurations2/menubar/PK-k4Configurations2/toolbar/PK-k4Configurations2/images/Bitmaps/PK-k4ր 1content.xmlPK-k4|3F qstyles.xmlPK-k4Tjj meta.xmlPK-k4ӞrBDThumbnails/thumbnail.pngPK-k49E~# settings.xmlPK-k4ANMETA-INF/manifest.xmlPKSmsm/vignettes/figures/p2q12.pdf0000755000176200001440000000203312250051205016053 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream xMN;09slc''6r Ƒ"HFp{\a*6v)tBƸ*p Mѧ 3MTNYU\GNc.*<~4.! l &Y&I{<p9endstream endobj 6 0 obj 158 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000451 00000 n 0000000569 00000 n 0000000392 00000 n 0000000262 00000 n 0000000015 00000 n 0000000243 00000 n 0000000499 00000 n 0000000540 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [] >> startxref 721 %%EOF msm/vignettes/figures/sampling.ps0000755000176200001440000001050712250051206016677 0ustar liggesusers%!PS-Adobe-3.0 %%DocumentNeededResources: font Symbol %%+ font Helvetica %%+ font Helvetica-Bold %%+ font Helvetica-Oblique %%+ font Helvetica-BoldOblique %%DocumentMedia: a4 595 841 0 () () %%Title: R Graphics Output %%Creator: R Software %%Pages: (atend) %%Orientation: Landscape %%BoundingBox: 118 61 478 781 %%EndComments %%BeginProlog /bp { gs 595.00 0 translate 90 rotate gs } def % begin .ps.prolog /gs { gsave } def /gr { grestore } def /ep { showpage gr gr } def /m { moveto } def /l { lineto } def /np { newpath } def /cp { closepath } def /f { fill } def /o { stroke } def /c { newpath 0 360 arc } def /r { 3 index 3 index moveto 1 index 4 -1 roll lineto exch 1 index lineto lineto closepath } def /p1 { stroke } def /p2 { gsave bg setrgbcolor fill grestore newpath } def /p3 { gsave bg setrgbcolor fill grestore stroke } def /t { 6 -2 roll moveto gsave rotate ps mul neg 0 2 1 roll rmoveto 1 index stringwidth pop mul neg 0 rmoveto show grestore } def /cl { grestore gsave newpath 3 index 3 index moveto 1 index 4 -1 roll lineto exch 1 index lineto lineto closepath clip newpath } def /rgb { setrgbcolor } def /s { scalefont setfont } def /R { /Font1 findfont } def /B { /Font2 findfont } def /I { /Font3 findfont } def /BI { /Font4 findfont } def /S { /Font5 findfont } def 1 setlinecap 1 setlinejoin % end .ps.prolog /Helvetica findfont dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall /Encoding ISOLatin1Encoding def currentdict end /Font1 exch definefont pop /Helvetica-Bold findfont dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall /Encoding ISOLatin1Encoding def currentdict end /Font2 exch definefont pop /Helvetica-Oblique findfont dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall /Encoding ISOLatin1Encoding def currentdict end /Font3 exch definefont pop /Helvetica-BoldOblique findfont dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall /Encoding ISOLatin1Encoding def currentdict end /Font4 exch definefont pop /Symbol findfont dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall currentdict end /Font5 exch definefont pop %%EndProlog %%Page: 1 1 bp 60.94 117.64 780.94 477.64 cl /ps 12 def R 12 s 0.0000 0.0000 0.0000 rgb 435.34 136.36 (Time) 0.50 0.00 0.00 t 60.94 117.64 780.94 477.64 cl /ps 12 def R 12 s 0.0000 0.0000 0.0000 rgb 105.58 247.85 (Stage 1) 1.00 0.00 0.00 t 105.58 300.52 (Stage 2) 1.00 0.00 0.00 t 105.58 353.18 (Stage 3) 1.00 0.00 0.00 t 105.58 405.85 (Death) 1.00 0.00 0.00 t 0.75 setlinewidth [] 0 setdash np 143.34 191.08 m 581.34 191.08 l o np 143.34 191.08 m 143.34 183.88 l o np 216.34 191.08 m 216.34 183.88 l o np 313.68 191.08 m 313.68 183.88 l o np 386.68 191.08 m 386.68 183.88 l o np 581.34 191.08 m 581.34 183.88 l o 143.34 165.16 (0.0) 0.50 0.00 0.00 t 216.34 165.16 (1.5) 0.50 0.00 0.00 t 313.68 165.16 (3.5) 0.50 0.00 0.00 t 386.68 165.16 (5.0) 0.50 0.00 0.00 t 581.34 165.16 (9.0) 0.50 0.00 0.00 t 119.98 191.08 750.70 418.60 cl 0.0000 0.0000 0.0000 rgb 0.75 setlinewidth [] 0 setdash np 143.34 252.17 m 192.01 252.17 l o np 185.78 248.57 m 192.01 252.17 l 185.78 255.77 l o np 192.01 304.84 m 338.01 304.84 l o np 331.78 301.24 m 338.01 304.84 l 331.78 308.44 l o np 338.01 252.17 m 435.34 252.17 l o np 429.11 248.57 m 435.34 252.17 l 429.11 255.77 l o np 435.34 357.50 m 581.34 357.50 l o np 575.11 353.90 m 581.34 357.50 l 575.11 361.10 l o np 581.34 410.17 m 630.01 410.17 l o np 623.78 406.57 m 630.01 410.17 l 623.78 413.77 l o np 192.01 252.17 m 192.01 304.84 l o np 338.01 304.84 m 338.01 252.17 l o np 435.34 252.17 m 435.34 357.50 l o np 581.34 357.50 m 581.34 410.17 l o 0.75 setlinewidth [ 3.00 5.00] 0 setdash np 216.34 191.08 m 216.34 418.60 l o np 313.68 191.08 m 313.68 418.60 l o np 386.68 191.08 m 386.68 418.60 l o np 582.80 191.08 m 582.80 418.60 l o np 216.34 191.08 m 216.34 418.60 l o np 313.68 191.08 m 313.68 418.60 l o np 386.68 191.08 m 386.68 418.60 l o np 582.80 191.08 m 582.80 418.60 l o np 216.34 191.08 m 216.34 418.60 l o np 313.68 191.08 m 313.68 418.60 l o np 386.68 191.08 m 386.68 418.60 l o np 582.80 191.08 m 582.80 418.60 l o np 216.34 191.08 m 216.34 418.60 l o np 313.68 191.08 m 313.68 418.60 l o np 386.68 191.08 m 386.68 418.60 l o np 582.80 191.08 m 582.80 418.60 l o ep %%Trailer %%Pages: 1 %%EOF msm/vignettes/figures/p3q14.eps0000755000176200001440000000600712250051206016102 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 757 312 814 %%HiResBoundingBox: 28.300000 757.000000 311.800000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:31 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream xMQKN0 Y&=kxԷ@_${&I,7t%Iw+i^{zZ{|AI_tdN@ F9HJfCmIK3:4''lHmƹp* Z-By&{Wy@'+2e[qq۫^a!΅/3" R,º1%+"fr1 0ԓ_a!s%3afH5%z?(B}]endstream endobj 6 0 obj 254 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000547 00000 n 0000000665 00000 n 0000000488 00000 n 0000000358 00000 n 0000000015 00000 n 0000000339 00000 n 0000000595 00000 n 0000000636 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<7C8FD2A157BC7182115B5A22DDCBAA1B><7C8FD2A157BC7182115B5A22DDCBAA1B>] >> startxref 817 %%EOF msm/vignettes/figures/p3q124.pdf0000755000176200001440000000210212250051206016136 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream x]M! =E.pL,OȌ!/Hy_t>83,WTB;,pp-aϭgh+ǀhZjQ|w۠V۔SK $/Q?TڳPe=RUF#WI+EmL ?\u~c!7,.Xendstream endobj 6 0 obj 196 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000490 00000 n 0000000608 00000 n 0000000431 00000 n 0000000300 00000 n 0000000015 00000 n 0000000281 00000 n 0000000538 00000 n 0000000579 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<18776D8BF95E9FF7BDC22AF23A1A5A27><18776D8BF95E9FF7BDC22AF23A1A5A27>] >> startxref 760 %%EOF msm/vignettes/figures/hidden.pdf0000755000176200001440000000502312250051205016443 0ustar liggesusers%PDF-1.3 %쏢 8 0 obj <> stream xVMo!+8R2ǵR.Tn\Me-%Zw`5%VR}7?J@)^<{nw=zZ>Cک]|G(! ^~زX (XdX?Xm~[oq{AʻG!12FvxN\N+چV[J1ƙVz` 3Zccb"ޭq,ϞxIZeB3"uqatSB;sN ex5TysΆW$ ARUtϰi/F6<ۗ`kx& _K}.*.* L r|}d pVǛK48xC8G@x‡#*MskDbF+=Ao R^ۤgљ^2ZȶPq8#K.Ei5{$-ozzSB9~/9vSvA16qDRD'~WHl,-Ƅ+y/үdL8ɕ~Wul2F_FѨbvu06x1⻂KOB}Fwe> /Contents 8 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 6 0 obj <> endobj 15 0 obj <> endobj 16 0 obj <> endobj 5 0 obj <>stream xkhD endstream endobj 4 0 obj <>stream xc` endstream endobj 14 0 obj <> endobj 13 0 obj <> endobj 12 0 obj <> endobj 11 0 obj <> endobj 10 0 obj <> endobj 2 0 obj <>endobj xref 0 17 0000000000 65535 f 0000001076 00000 n 0000002005 00000 n 0000001017 00000 n 0000001466 00000 n 0000001318 00000 n 0000001124 00000 n 0000000866 00000 n 0000000015 00000 n 0000000847 00000 n 0000001934 00000 n 0000001848 00000 n 0000001766 00000 n 0000001687 00000 n 0000001613 00000 n 0000001212 00000 n 0000001242 00000 n trailer << /Size 17 /Root 1 0 R /Info 2 0 R >> startxref 2161 %%EOF msm/vignettes/figures/p4q159.eps0000755000176200001440000000615012250051206016174 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 757 426 814 %%HiResBoundingBox: 28.300000 757.000000 425.200000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:33 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream xU;0 w3I'`BKqRQUU>8HqJFpd .^0{s5gO1yw0iMKmTw{pn%݄$(G{zVx4z*]\UH"ȑľ3.nX2v n9(Ǎj=^hZVendstream endobj 6 0 obj 203 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000497 00000 n 0000000615 00000 n 0000000438 00000 n 0000000307 00000 n 0000000015 00000 n 0000000288 00000 n 0000000545 00000 n 0000000586 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [] >> startxref 767 %%EOF msm/vignettes/figures/sampling.pdf0000755000176200001440000000440012250051206017021 0ustar liggesusers%PDF-1.3 %쏢 8 0 obj <> stream xTn@+ mvflq@ ÅaDB ')} DPS8o?-<WlSvWtxM]$}ZI-J<Ɨ_W_(H4*^=Shu0>43-fۙ9d~p<ँ?2>yMXXZTGqAghJPq CVEQq`2+Eŝ5+> /Contents 8 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 6 0 obj <> endobj 15 0 obj <> endobj 16 0 obj <> endobj 5 0 obj <>stream xkhD endstream endobj 4 0 obj <>stream xc` endstream endobj 14 0 obj <> endobj 13 0 obj <> endobj 12 0 obj <> endobj 11 0 obj <> endobj 10 0 obj <> endobj 2 0 obj <>endobj xref 0 17 0000000000 65535 f 0000000801 00000 n 0000001730 00000 n 0000000742 00000 n 0000001191 00000 n 0000001043 00000 n 0000000849 00000 n 0000000591 00000 n 0000000015 00000 n 0000000572 00000 n 0000001659 00000 n 0000001573 00000 n 0000001491 00000 n 0000001412 00000 n 0000001338 00000 n 0000000937 00000 n 0000000967 00000 n trailer << /Size 17 /Root 1 0 R /Info 2 0 R >> startxref 1886 %%EOF msm/vignettes/figures/p5q1_6_7_11_12.pdf0000755000176200001440000000222512250051206017256 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream x]QAn0 >Y%;/y [lY3EؚdH'W }ocxB27PbQ%O_p̄naS#LypeJGX%`ڸp{QcǗN02a3<8ݰul [KVjg<8S'x.ɗZbAi \;%o1z[+㹙x-Nfk,P?, 1Ɉ@\ӄ0Ӝ^ƫkʒ: U!Fkh|V!?ٕendstream endobj 6 0 obj 279 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000573 00000 n 0000000691 00000 n 0000000514 00000 n 0000000383 00000 n 0000000015 00000 n 0000000364 00000 n 0000000621 00000 n 0000000662 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<0507AE57B35FF484D029A4B37E531833><0507AE57B35FF484D029A4B37E531833>] >> startxref 843 %%EOF msm/vignettes/figures/p4q13569.eps0000755000176200001440000000656712250051206016361 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 643 426 814 %%HiResBoundingBox: 28.300000 643.600000 425.200000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:33 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream xMP;0 u ohc@H,:i&DRI|MKI/Iz$N'Z{w.Cn$JD 0HanNwR-PcҜیMU-/4eѨ g&V-Ϫ_b8[  bX'Ŧ{4 ݴL`{Xclg:?bendstream endobj 6 0 obj 215 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000508 00000 n 0000000626 00000 n 0000000449 00000 n 0000000319 00000 n 0000000015 00000 n 0000000300 00000 n 0000000556 00000 n 0000000597 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<8F7CF8F2C2D4FF6135A25FAEF128A59F><8F7CF8F2C2D4FF6135A25FAEF128A59F>] >> startxref 778 %%EOF msm/vignettes/figures/p2q12.eps0000755000176200001440000000573012250051205016100 0ustar liggesusers%!PS-Adobe-3.0 EPSF-3.0 %%BoundingBox: 28 757 199 814 %%HiResBoundingBox: 28.300000 757.000000 198.400000 813.700000 %................................... %%Creator: GPL Ghostscript 850 (epswrite) %%CreationDate: 2006/06/22 17:45:28 %%DocumentData: Clean7Bit %%LanguageLevel: 2 %%EndComments %%BeginProlog % This copyright applies to everything between here and the %%EndProlog: % Copyright (C) 2005 artofcode LLC, Benicia, CA. All rights reserved. %%BeginResource: procset GS_epswrite_2_0_1001 /GS_epswrite_2_0_1001 80 dict dup begin /PageSize 2 array def/setpagesize{ PageSize aload pop 3 index eq exch 4 index eq and{ pop pop pop}{ PageSize dup 1 5 -1 roll put 0 4 -1 roll put dup null eq {false} {dup where} ifelse{ exch get exec} { pop/setpagedevice where { pop 1 dict dup /PageSize PageSize put setpagedevice} { /setpage where{ pop PageSize aload pop pageparams 3 {exch pop} repeat setpage}if}ifelse}ifelse}ifelse} bind def /!{bind def}bind def/#{load def}!/N/counttomark # /rG{3{3 -1 roll 255 div}repeat setrgbcolor}!/G{255 div setgray}!/K{0 G}! /r6{dup 3 -1 roll rG}!/r5{dup 3 1 roll rG}!/r3{dup rG}! /w/setlinewidth #/J/setlinecap # /j/setlinejoin #/M/setmiterlimit #/d/setdash #/i/setflat # /m/moveto #/l/lineto #/c/rcurveto # /p{N 2 idiv{N -2 roll rlineto}repeat}! /P{N 0 gt{N -2 roll moveto p}if}! /h{p closepath}!/H{P closepath}! /lx{0 rlineto}!/ly{0 exch rlineto}!/v{0 0 6 2 roll c}!/y{2 copy c}! /re{4 -2 roll m exch dup lx exch ly neg lx h}! /^{3 index neg 3 index neg}! /f{P fill}!/f*{P eofill}!/s{H stroke}!/S{P stroke}! /q/gsave #/Q/grestore #/rf{re fill}! /Y{P clip newpath}!/Y*{P eoclip newpath}!/rY{re Y}! /|={pop exch 4 1 roll 1 array astore cvx 3 array astore cvx exch 1 index def exec}! /|{exch string readstring |=}! /+{dup type/nametype eq{2 index 7 add -3 bitshift 2 index mul}if}! /@/currentfile #/${+ @ |}! /B{{2 copy string{readstring pop}aload pop 4 array astore cvx 3 1 roll}repeat pop pop true}! /Ix{[1 0 0 1 11 -2 roll exch neg exch neg]exch}! /,{true exch Ix imagemask}!/If{false exch Ix imagemask}!/I{exch Ix image}! /Ic{exch Ix false 3 colorimage}! /F{/Columns counttomark 3 add -2 roll/Rows exch/K -1/BlackIs1 true>> /CCITTFaxDecode filter}!/FX{<> stream xWK'h)zG!i8HN 3+D{70_8׶̗hxun&ᶬ/yb-s4ץC_Lb:/ sDnKf~ЭtMxF3hU!;MP|T@7.fG.n(n Ь 8\9R9v4BCJkH؂b~W`#a)s"ͮ( ::p!{ӡ`RY29̫ebZ#۵2*2TphH8#LC7zQs}87܁TCCuvڕmt+(h U3:\AKB2$*(J VTgj/?tR޼t[|l/b%;tW1k5VAH{ӎ6 ަd#x-/5$mGD+;AѺ~QG[y *gvƃ"=,S@>1z'`9:Gp;{QMer,k j:}mnCdקuTx6 zh&G>)N\H.Ҹudhd3OPhw)Ou9F@k5'`p5[l6ʮuTV]IsQE񃗉; *C6Ub.$ڨakbc'O"1Z ?!JղS^f{ TFB@}#rnO$1*J_ph9Ry>Kt_ 7Iݣ1ȍsMqKS`,e+sK,05,lD: O[?fvKz2"$Xn4&}v?}ijP`x^dwm ‡\X>T̥-> S|4r\~_} |Ao_Jendstream endobj 6 0 obj 1020 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 9 0 obj <> endobj 10 0 obj <> endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 11 0000000000 65535 f 0000001343 00000 n 0000001560 00000 n 0000001284 00000 n 0000001125 00000 n 0000000015 00000 n 0000001105 00000 n 0000001391 00000 n 0000001491 00000 n 0000001432 00000 n 0000001461 00000 n trailer << /Size 11 /Root 1 0 R /Info 2 0 R /ID [] >> startxref 1781 %%EOF msm/vignettes/figures/p3q1246.pdf0000755000176200001440000000214712250051206016235 0ustar liggesusers%PDF-1.3 %쏢 5 0 obj <> stream xUQAn1 {H6`6OԴPRn`'7^?4]7`z4ULw(j`[rjeAT68vg<{6$i2SYr{Fw(1]g" $pq~ţiK%}g]FHx$N*{ Xm2{P־\ #1I:=ᥔWp. a_,ZUEq3a_Ezu8+^gendstream endobj 6 0 obj 233 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 7 0 obj <>endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000527 00000 n 0000000645 00000 n 0000000468 00000 n 0000000337 00000 n 0000000015 00000 n 0000000318 00000 n 0000000575 00000 n 0000000616 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [<043BADFF288CA31BAAF50CBE8CB75FF8><043BADFF288CA31BAAF50CBE8CB75FF8>] >> startxref 797 %%EOF msm/vignettes/figures/fev_viterbi.pdf0000755000176200001440000001157112263740173017536 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20140103094218) /ModDate (D:20140103094218) /Title (R Graphics Output) /Producer (R 3.0.2) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 1046 /Filter /FlateDecode >> stream xWMo7 ϯUI0!a:@x }iFᤝ$o2]5}^' XOɳ7I%6A~o?5Z?/_@Ooߑ?& \O)y-9'X2N3yLt3`b,΄@F3Eifgb$؈qV).GR0a>/p"u,lr!TcR+8ZS\ɓ cv⬎JaSb?+kB$YT GFaײ >AfR2|fa 'Mtfᐇ|9kzE0 Ť^X+Vh>Y-dw/ &.Uհ+Ft>cyHy(6uf[}9zIN;+_Z1=`75zv>k)V{]呇n_猌o}$ tGch<HqXyuzVΣ~+U:/tY_Z4jYEɥNovm`pewG|7u#Y ΋DV v^ 78ָ0+_a'w]JzQ4ӈQ6@Ұ7 ֞z:Ϻ,̐xlemA|uArZeuGMZM=`>-iqy,> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus 96/quoteleft 144/dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F2 /BaseFont /Helvetica /Encoding 9 0 R >> endobj xref 0 11 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000001410 00000 n 0000001493 00000 n 0000001605 00000 n 0000001638 00000 n 0000000212 00000 n 0000000292 00000 n 0000004333 00000 n 0000004590 00000 n trailer << /Size 11 /Info 1 0 R /Root 2 0 R >> startxref 4687 %%EOF msm/vignettes/msm-manual.Rnw0000755000176200001440000035751412767444102015646 0ustar liggesusers%%\VignetteIndexEntry{User guide to msm with worked examples} %\VignettePackage{msm} \documentclass{article} %% Need to modify Sweave.sty to pass pdftex option to graphicx. %\usepackage{Sweave-local} \usepackage{graphics} \RequirePackage[T1]{fontenc} %%Check if we are compiling under latex or pdflatex \ifx\pdftexversion\undefined \RequirePackage[dvips]{graphicx} \else \RequirePackage[pdftex]{graphicx} \RequirePackage{epstopdf} \fi \RequirePackage{ae,fancyvrb} \IfFileExists{upquote.sty}{\RequirePackage{upquote}}{} \setkeys{Gin}{width=0.8\textwidth} \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontshape=sl} \newenvironment{Schunk}{}{} \usepackage{times} \usepackage{url} \addtolength{\textwidth}{2cm} \newcommand{\Exp}{\mathop{\mathrm{Exp}}} \newcommand{\etal}{{\textit{et al.}}} \newcommand{\Rfunction}[1]{{\texttt{#1}}} \newcommand{\Robject}[1]{{\texttt{#1}}} \newcommand{\Rpackage}[1]{{\textit{#1}}} \newcommand{\Rmethod}[1]{{\texttt{#1}}} \newcommand{\Rfunarg}[1]{{\texttt{#1}}} \newcommand{\Rclass}[1]{{\textit{#1}}} %% version <- 1.3 <>= version <- gsub("Version: +", "", packageDescription("msm", lib.loc=c("../..",.libPaths()))$Version) @ \title{Multi-state modelling with R: the {\tt msm} package \vskip 0.2in \large{Version % <>= cat(version) @ \vskip 0.1in <>= cat(format(Sys.time(), "%d %B, %Y")) @ }} \author{Christopher Jackson\\MRC Biostatistics Unit\\Cambridge, U.K.\\ \texttt{chris.jackson@mrc-bsu.cam.ac.uk}} \date{} %% label with date when Rnw is compiled, not when tex is compiled. should be release date of package \bibliographystyle{unsrt} \begin{document} \maketitle \begin{abstract} The multi-state Markov model is a useful way of describing a process in which an individual moves through a series of states in continuous time. The \Rpackage{msm} package for R allows a general multi-state model to be fitted to longitudinal data. Data often consist of observations of the process at arbitrary times, so that the exact times when the state changes are unobserved. For example, the progression of chronic diseases is often described by stages of severity, and the state of the patient may only be known at doctor or hospital visits. Features of \Rpackage{msm} include the ability to model transition rates and hidden Markov output models in terms of covariates, and the ability to model data with a variety of observation schemes, including censored states. Hidden Markov models, in which the true path through states is only observed through some error-prone marker, can also be fitted. The observation is generated, conditionally on the underlying states, via some distribution. An example is a screening misclassification model in which states are observed with error. More generally, hidden Markov models can have a continuous response, with some arbitrary distribution, conditionally on the underlying state. This manual introduces the theory behind multi-state Markov and hidden Markov models, and gives a tutorial in the typical use of the \Rpackage{msm} package, illustrated by some typical applications to modelling chronic diseases. Much of the material in this manual is published, in a more concise form, in Journal of Statistical Software (2011) 38(8):1-29, \url{http://www.jstatsoft.org/v38/i08/} \end{abstract} \section{Multi-state models} \label{sec:multistate} \subsection{Introduction} \label{sec:intro} Figure \ref{fig:multi} illustrates a multi-state model in continuous time. Its four states are labelled {\bf 1, 2, 3, 4}. At a time $t$ the individual is in state $S(t)$. The arrows show which transitions are possible between states. The next state to which the individual moves, and the time of the change, are governed by a set of {\em transition intensities} $q_{rs}(t, z(t))$ for each pair of states $r$ and $s$. The intensities may also depend on the time of the process $t$, or more generally a set of individual-specific or time-varying explanatory variables $z(t)$. The intensity represents the instantaneous risk of moving from state $r$ to state $s$: \begin{equation} \label{eq:multi:intensity} q_{rs}(t, z(t)) = \lim_{\delta t \rightarrow 0} P (S(t+\delta t) = s | S(t) = r) / \delta t \end{equation} The intensities form a matrix $Q$ whose rows sum to zero, so that the diagonal entries are defined by $q_{rr} = - \sum_{s \neq r} q_{rs}$. To fit a multi-state model to data, we estimate this transition intensity matrix. We concentrate on {\em Markov} models here. The Markov assumption is that future evolution only depends on the current state. That is, $q_{rs}(t, z(t), \mathcal{F}_t)$ is independent of $\mathcal{F}_t$, the observation history $\mathcal{F}_t$ of the process up to the time preceding $t$. See, for example, Cox and Miller\cite{cox:miller} for a thorough introduction to the theory of continuous-time Markov chains. \begin{figure}[p] \begin{center} \scalebox{0.4}{\includegraphics{figures/multistate}} \[ Q = \left( \begin{array}{llll} q_{11} & q_{12} & q_{13} & q_{14}\\ q_{21} & q_{22} & q_{23} & q_{24}\\ q_{31} & q_{32} & q_{33} & q_{34}\\ q_{41} & q_{42} & q_{43} & q_{44}\\ \end{array} \right ) \] \caption{\label{fig:multi}General multi-state model.} \end{center} \end{figure} In a time-homogeneous continuous-time Markov model, a single period of occupancy (or \emph{sojourn time}) in state $r$ has an exponential distribution, with rate given by $-q_{rr}$, (or mean $-1 / q_{rr}$). The remaining elements of the $r$th row of $Q$ are \emph{proportional to} the probabilities governing the next state after $r$ to which the individual makes a transition. The probability that the individual's next move from state $r$ is to state $s$ is $-q_{rs} / q_{rr}$. \subsection{Disease progression models} The development of the \Rpackage{msm} package was motivated by applications to disease modelling. Many chronic diseases have a natural interpretation in terms of staged progression. Multi-state Markov models in continuous time are often used to model the course of diseases. A commonly-used model is illustrated in Figure \ref{fig:disease}. This represents a series of successively more severe disease stages, and an `absorbing' state, often death. The patient may advance into or recover from adjacent disease stages, or die at any disease stage. Observations of the state $S_i(t)$ are made on a number of individuals $i$ at arbitrary times $t$, which may vary between individuals. The stages of disease may be modelled as a homogeneous continuous-time Markov process, with a transition matrix $Q$, pictured below Figure \ref{fig:disease}. A commonly-used model is the \emph{illness-death} model, with three states representing health, illness and death (Figure \ref{fig:multi:illdeath}). Transitions are permitted from health to illness, illness to death and health to death. Recovery from illness to health is sometimes also considered. A wide range of medical situations have been modelled using multi-state methods, for example, screening for abdominal aortic aneurysms (Jackson \etal\cite{jackson:sharples:2003}), problems following lung transplantation (Jackson and Sharples\cite{jackson:sharples:2002}), problems following heart transplantation (Sharples\cite{sharp:gibbs}, Klotz and Sharples\cite{klotz:est}), hepatic cancer (Kay\cite{kay:mark}), HIV infection and AIDS (Longini \etal\cite{long1}, Satten and Longini\cite{sattlong}, Guihenneuc-Jouyaux \etal\cite{rich}, Gentleman \etal\cite{gentlaw}), diabetic complications (Marshall and Jones\cite{retino2}, Andersen\cite{andersen88}), breast cancer screening (Duffy and Chen\cite{duffy95}, Chen \emph{et al.}\cite{duffy96}), cervical cancer screening (Kirby and Spiegelhalter\cite{kirby:spiegelhalter}) and liver cirrhosis (Andersen \etal\cite{ander:proth}). Many of these references also describe the mathematical theory, which will be reviewed in the following sections. \begin{figure}[p] \centering \vskip 1cm \scalebox{1.0}{\includegraphics{figures/general}} \[ Q = \left( \begin{array}{llllll} q_{11} & q_{12} & 0 & 0 & \ldots & q_{1n}\\ q_{21} & q_{22} & q_{23} & 0 & \ldots & q_{2n}\\ 0 & q_{32} & q_{33} & q_{34} & \ddots & q_{3n}\\ 0 & 0 & q_{43} & q_{44} & \ddots & q_{4n}\\ \vdots & \vdots & \ddots & \ddots & \ddots & \vdots\\ 0 & 0 & 0 & 0 & \ldots & 0\\ \end{array} \right ) \] \caption{\label{fig:disease}General model for disease progression.} \end{figure} \begin{figure}[p] \begin{center} \scalebox{0.4}{\includegraphics{figures/illdeath}} \caption{Illness-death model.} \label{fig:multi:illdeath} \end{center} \end{figure} \subsection{Arbitrary observation times} \label{sec:arbitr-observ-times} Longitudinal data from monitoring disease progression are often incomplete in some way. Usually patients are seen at intermittent follow-up visits, at which monitoring information is collected, but information from the periods between visits is not available. Often the exact time of disease onset is unknown. Thus, the changes of state in a multi-state model usually occur at unknown times. Also a subject may only be followed up for a portion of their disease history. A fixed observation schedule may be specified in advance, but in practice times of visits may vary due to patient and hospital pressures. The states of disease progression models often include death. Death times are commonly recorded to within a day. Also observations may be censored. For example, at the end of a study, an individual may be known only to be alive, and in an unknown state. A typical sampling situation is illustrated in Figure \ref{fig:multi:sampling}. The individual is observed at four occasions through 10 months. The final occasion is the death date which is recorded to within a day. The only other information available is the occupation of states 2, 2, and 1 at respective times 1.5, 3.5 and 5. The times of movement between states and the state occupancy in between the observation times are unknown. Although the patient was in state 3 between 7 and 9 months this was not observed at all. \paragraph{Informative sampling times} To fit a model to longitudinal data with arbitrary sampling times we must consider the reasons why observations were made at the given times. This is analogous to the problem of missing data, where the fact that a particular observation is missing may implicitly give information about the value of that observation. Possible observation schemes include: \begin{itemize} \item {\em fixed}. Each patient is observed at fixed intervals specified in advance. \item {\em random}. The sampling times vary randomly, independently of the current state of the disease. \item {\em doctor's care}. More severely ill patients are monitored more closely. The next sampling time is chosen on the basis of the current disease state. \item patient {\em self-selection}. A patient may decide to visit the doctor on occasions when they are in a poor condition. \end{itemize} Gr\"uger \etal \cite{gruger:valid} discussed conditions under which sampling times are \emph{informative}. If a multi-state model is fitted, ignoring the information available in the sampling times, then inference may be biased. Mathematically, because the sampling times are often themselves random, they should be modelled along with the observation process $X_t$. However the ideal situation is where the joint likelihood for the times and the process is proportional to the likelihood obtained if the sampling times were fixed in advance. Then the parameters of the process can be estimated independently of the parameters of the sampling scheme. In particular, they showed that fixed, random and doctor's care observation policies are not informative, whereas patient self-selection is informative. Note that \Rpackage{msm} does not deal with informative sampling times. See, e.g. \cite{sweeting:inform:msm} for some methods in this case, which require specialised programming. \begin{figure}[p] \begin{center} \scalebox{0.6}{\rotatebox{270}{\includegraphics{figures/sampling}}} \caption{Evolution of a multi-state model. The process is observed on four occasions.} \label{fig:multi:sampling} \end{center} \end{figure} \subsection{Likelihood for the multi-state model} \label{sec:multi:likelihood} Kalbfleisch and Lawless\cite{kalbfleisch:lawless} and later Kay \cite{kay:mark} described a general method for evaluating the likelihood for a general multi-state model in continuous time, applicable to any form of transition matrix. The only available information is the observed state at a set of times, as in Figure \ref{fig:multi:sampling}. The sampling times are assumed to be non-informative. \paragraph{Transition probability matrix} The likelihood is calculated from the \emph{transition probability matrix} $P(t)$. For a time-homogeneous process, the $(r,s)$ entry of $P(t)$, $p_{rs}(t)$, is the probability of being in state $s$ at a time $t+u$ in the future, given the state at time $u$ is $r$. It does not say anything about the time of transition from $r$ to $s$, indeed the process may have entered other states between times $u$ and $t+u$. $P(t)$ can be calculated by taking the matrix exponential of the scaled transition intensity matrix (see, for example, Cox and Miller \cite{cox:miller}). \begin{equation} \label{eq:exptq} P(t) = \Exp(tQ) \end{equation} The matrix exponential $\Exp$ is different from a scalar exponential. The exponential of a matrix is defined by the same "power series" $\Exp(X) = 1 + X^2/2! + X^3/3! + ...$ as the scalar exponential, except that each term $X^k$ in the series is defined by matrix products, not element-wise scalar multiplication. It is notoriously difficult to calculate reliably, as discussed by Moler and van Loan \cite{matrixexp}. For simpler models, it is feasible to calculate an analytic expression for each element of $P(t)$ in terms of $Q$. This is generally faster and avoids the potential numerical instability of calculating the matrix exponential. Symbolic algebra sofware, such as Mathematica, can be helpful for obtaining these expressions. For example, the three-state illness-death model with no recovery has a transition intensity matrix of \[ Q = \left( \begin{array}{llllll} -(q_{12} + q_{13}) & q_{12} & q_{13}\\ 0 & - q_{23} & q_{23}\\ 0 & 0 & 0\\ \end{array} \right ) \] The corresponding time $t$ transition probabilities are \begin{eqnarray*} p_{11}(t) & = & e^{-(q_{12} + q_{13})t}\\ p_{12}(t) & = & \left\{ \begin{array}{ll} \frac{ q_{12} }{q_{12} + q_{13} - q_{23} } (e^{-q_{23} t} - e^{-(q_{12} + q_{13})t}) & (q_{12} + q_{13} \neq q_{23})\\ q_{12}te^{(-(q_{12} + q_{13})t} & (q_{12} + q_{13} = q_{23}) \end{array} \right. \\ p_{13}(t) & = & \left\{ \begin{array}{ll} 1 - e^{-(q_{12} + q_{13})t} - \frac{ q_{12} }{q_{12} + q_{13} - q_{23} } (e^{-q_{23} t} - e^{-(q_{12} + q_{13})t}) & (q_{12} + q_{13} \neq q_{23})\\ (-1 + e^{(q_{12} + q_{13})t} - q_{12}t)e^{-(q_{12} + q_{13})t} & (q_{12} + q_{13} = q_{23}) \end{array} \right. \\ p_{21}(t) & = & 0\\ p_{22}(t) & = & e^{-q_{23}t}\\ p_{23}(t) & = & 1 - e^{-q_{23}t}\\ p_{31}(t) & = & 0\\ p_{32}(t) & = & 0\\ p_{33}(t) & = & 1\\ \end{eqnarray*} The \Rpackage{msm} package calculates $P(t)$ analytically for selected 2, 3, 4 and 5-state models, illustrated in Figures \ref{fig:anp2}--\ref{fig:anp5}. For other models, which can have any transition structure on any number of states in principle, $P(t)$ is determined from the matrix exponential. This is calculated using eigensystem decomposition (if eigenvalues are distinct) or a method based on Pad\'e approximants with scaling and squaring \cite{matrixexp} (if there are repeated eigenvalues). Notice that the states are not labelled in these figures. Each graph can correspond to several different $Q$ matrices, depending on how the states are labelled. For example, Figure 1 a) illustrates the model defined by either \( Q = \left( \begin{array}{ll} - q_{12} & q_{12} \\ 0 & 0 \end{array} \right) \) or \( Q = \left( \begin{array}{ll} 0 & 0\\ q_{21} & - q_{21} \end{array} \right) \). \begin{figure} \begin{center} a) \includegraphics[width=3cm]{figures/p2q1} \hskip 3cm b) \includegraphics[width=3cm]{figures/p2q12} \end{center} \caption{\label{fig:anp2}Two-state models fitted using analytic $P(t)$ matrices in \Rpackage{msm}. Implemented for all permutations of state labels 1, 2.} \end{figure} \begin{figure} \begin{center} a) \includegraphics[width=3cm]{figures/p3q12} \hskip 3cm b) \includegraphics[width=5cm]{figures/p3q14} \vskip 1cm c) \includegraphics[width=3cm]{figures/p3q16}\hskip 3cm d) \includegraphics[width=3cm]{figures/p3q124}\vskip 1cm e) \includegraphics[width=3cm]{figures/p3q135}\hskip 3cm f) \includegraphics[width=3cm]{figures/p3q1246} \end{center} \caption{\label{fig:anp3}Three-state models fitted using analytic $P(t)$ matrices in \Rpackage{msm}. Implemented for all permutations of state labels 1, 2, 3.} \end{figure} \begin{figure} \begin{center} a) \includegraphics[width=7cm]{figures/p4q159} \vskip 1cm b) \includegraphics[width=7cm]{figures/p4q13569} \end{center} \caption{\label{fig:anp4}Four-state models fitted using analytic $P(t)$ matrices in \Rpackage{msm}. Implemented for all permutations of state labels 1, 2, 3, 4.} \end{figure} \begin{figure} \begin{center} a) \includegraphics[width=9cm]{figures/p5q1_6_11_16}\vskip 1cm b) \includegraphics[width=9cm]{figures/p5q1_4_6_8_11_12_16}\vskip 1cm c) \includegraphics[width=5cm]{figures/p5q1_6_7_11_12} \end{center} \caption{\label{fig:anp5}Five-state models fitted using analytic $P(t)$ matrices in \Rpackage{msm}. Implemented for all permutations of state labels 1, 2, 3, 4, 5.} \end{figure} \paragraph{Likelihood for intermittently-observed processes} Suppose $i$ indexes $M$ individuals. The data for individual $i$ consist of a series of times $(t_{i1}, \ldots, t_{in_i})$ and corresponding states $(S(t_{i1}), \ldots, S(t_{in_i}))$. Consider a general multi state model, with a pair of successive observed disease states $S(t_j), S(t_{j+1})$ at times $t_j, t_{j+1}$. The contribution to the likelihood from this pair of states is \begin{equation} \label{eq:multi:lik:contrib} L_{i, j} = p_{S(t_j)S(t_{j+1})}(t_{j+1} - t_j) \end{equation} This is the entry of the transition matrix $P(t)$ at the $S(t_j)$th row and $S(t_{j+1})$th column, evaluated at $t = t_{j+1} - t_j$. The full likelihood $L(Q)$ is the product of all such terms $L_{i,j}$ over all individuals and all transitions. It depends on the unknown transition matrix $Q$, which was used to determine $P(t)$. \paragraph{Exactly-observed death times} In observational studies of chronic diseases, it is common that the time of death is known, but the state on the previous instant before death is unknown. If $S(t_{j+1}) = D $ is such a death state, then the contribution to the likelihood is summed over the unknown state $m$ on the instant before death: \begin{equation} \label{eq:multi:lik:death} L_{i, j} = \sum_{m \neq D} p_{S(t_j),m}(t_{j+1} - t_j) q_{m, D} \end{equation} The sum is taken over all possible states $m$ which can be visited between $S(t_j)$ and $D$. \paragraph{Exactly observed transition times} If the times $(t_{i1}, \ldots, t_{in_i})$ had been the {\em exact} transition times between the states, with no transitions between the observation times, then the contributions would be of the form \begin{equation} \label{eq:multi:lik:exact} L_{i, j} = \exp(q_{S(t_j)S(t_{j})}(t_{j+1} - t_j)) q_{S(t_j)S(t_{j+1})} \end{equation} since the state is assumed to be $S(t_j)$ throughout the interval between $t_j$ and $t_{j+1}$ with a known transition to state $S(t_{j+1})$ at $t_{j+1}$. \Rpackage{msm} is restricted to Markov models, but much richer models are possible for this type of data. For example, Putter \etal \cite{putter:mstate} discussed the \Rpackage{mstate} software for semi-parametric multi-state models with non-parametric baseline hazards and Cox regression. The Markov assumption is restrictive but necessary in general to compute a likelihood for intermittently-observed processes. \paragraph{Censored states} A censored quantity is one whose exact value is unknown, but known to be in a certain interval. For example, in survival analysis, a death time is \emph{right-censored} if the study ends and the patient is still alive, since the death time is known to be greater than the end time. In multi-state models for intermittently-observed processes, the times of changes of state are usually \emph{interval censored}, known to be within bounded intervals. This leads to a likelihood based on equation \ref{eq:multi:lik:contrib}. In some circumstances, \emph{states} may be censored as well as \emph{event times}. For example, at the end of some chronic disease studies, patients are known to be alive but in an \emph{unknown state}. For such a censored observation $S(t_{j+1})$, known only to be a state in the set $C$, the equivalent contribution to the likelihood is \begin{equation} \label{eq:multi:lik:deathcens} L_{i, j} = \sum_{m \in C} p_{S(t_j),m}(t_{j+1} - t_j) \end{equation} Note that this special likelihood is not needed if the state is known at the end of the study. In this case, likelihood \ref{eq:multi:lik:contrib} applies. Although the \emph{survival time} is censored, the \emph{state} at the end of the study is not censored. More generally, suppose every observation from a particular individual is censored. Observations $1, 2, \ldots n_i$ are known only to be in the sets $C_1, C_2, \ldots, C_{n_i}$ respectively. The likelihood for this individual is a sum of the likelihoods of all possible paths through the unobserved states. \begin{equation} \label{eq:multi:lik:cens} L_i = \sum_{s_{n_i} \in C_{n_i}} \ldots \sum_{s_2 \in C_2} \sum_{s_1 \in C_1} p_{s_1 s_2}(t_2 - t_1) p_{s_2 s_3} (t_3 - t_2) \ldots p_{s_{n_i-1} s_{n_i}} (t_{n_i} - t_{n_i-1}) \end{equation} Suppose the states comprising the set $C_j$ are $c^{(j)}_1, \ldots, c^{(j)}_{m_j}$. This likelihood can also be written as a matrix product, say, \begin{equation} \label{eq:multi:lik:cens:matrix} L_i = \mathbf{1}^T P^{1,2} P^{2,3} \ldots P^{n_i-1, n_i} \mathbf{1} \end{equation} where $P^{j-1, j}$ is a $m_{j-1} \times m_j$ matrix with $(r,s)$ entry $p_{c^{(j-1)}_r c^{(j)}_s}(t_j - t_{j-1})$, and $\mathbf{1}$ is the vector of ones. The \Rpackage{msm} package allows multi-state models to be fitted to data from processes with arbitrary observation times (panel data), exactly-observed transition times, exact death times and censored states, or a mixture of these schemes. \subsection{Covariates} \label{sec:multi:covariates} The relation of constant or time-varying characteristics of individuals to their transition rates is often of interest in a multi-state model. Explanatory variables for a particular transition intensity can be investigated by modelling the intensity as a function of these variables. Marshall and Jones \cite{retino2} described a form of a {\em proportional hazards} model, where the transition intensity matrix elements $q_{rs}$ which are of interest can be replaced by \[ q_{rs}(z(t)) = q_{rs}^{(0)} \exp(\beta_{rs}^T z(t)) \] The new $Q$ is then used to determine the likelihood. If the covariates $z(t)$ are time dependent, the contributions to the likelihood of the form $p_{rs} (t - u)$ are replaced by \[ p_{rs}(t - u, z(u)) \] although this requires that the value of the covariate is known at every observation time $u$. Sometimes covariates are observed at different times to the main response, for example recurrent disease events or other biological markers. In some of these cases it could be assumed that the covariate is a step function which remains constant between its observation times. If the main response (the state of the Markov process) is not observed at the times when the covariate changes, it could be considered as a "censored" state (as in Section \ref{sec:multi:likelihood}). The \Rpackage{msm} package allows individual-specific or time dependent covariates to be fitted to transition intensities. In order to calculate transition probabilities $P(t)$ on which the likelihood depends, time-dependent covariates are assumed to be piecewise-constant. Models whose intensities change with time are called \emph{time-inhomogeneous}. An important special case handled by \Rpackage{msm} is the model in which intensities change at a series of times common to each individual. Marshall and Jones \cite{retino2} described likelihood ratio and Wald tests for covariate selection and testing hypotheses, for example whether the effect of a covariate is the same for all forward transitions in a disease progression model, or whether the effect on backward transitions is equal to minus the effect on forward transitions. \subsection{Hidden Markov models} \label{sec:hmm} In a {\em hidden Markov model} (HMM) the states of the Markov chain are not observed. The observed data are governed by some probability distribution (the \emph{emission} distribution) conditionally on the unobserved state. The evolution of the underlying Markov chain is governed by a transition intensity matrix $Q$ as before. (Figure \ref{fig:multi:hidden}). Hidden Markov models are mixture models, where observations are generated from a certain number of unknown distributions. However the distribution changes through time according to states of a hidden Markov chain. This class of model is commonly used in areas such as speech and signal processing \cite{juang:rabiner} and the analysis of biological sequence data \cite{biolog:seq}. In engineering and biological sequencing applications, the Markov process usually evolves over an equally-spaced, discrete `time' space. Therefore most of the theory of HMM estimation was developed for discrete-time models. HMMs have less frequently been used in medicine, where continuous time processes are often more suitable. A disease process evolves in continuous time, and patients are often monitored at irregular and differing intervals. These models are suitable for estimating population quantities for chronic diseases which have a natural staged interpretation, but which can only be diagnosed by an error-prone marker. The \Rpackage{msm} package can fit continuous-time hidden Markov models with a variety of emission distributions. \begin{figure}[htbp] \begin{center} \scalebox{0.6}{\rotatebox{270}{\includegraphics{figures/hidden}}} \caption{A hidden Markov model in continuous time. Observed states are generated conditionally on an underlying Markov process. } \label{fig:multi:hidden} \end{center} \end{figure} \subsubsection{Misclassification models} An example of a hidden Markov model is a multi-state model with misclassification. Here the observed data are states, assumed to be misclassifications of the true, underlying states. For example, consider a disease progression model with at least a disease-free and a disease state. When screening for the presence of the disease, the screening process can sometimes be subject to error. Then the Markov disease process $S_i(t)$ for individual $i$ is not observed directly, but through realisations $O_i(t)$. The quality of a diagnostic test is often measured by the probabilities that the true and observed states are equal, $Pr(O_i(t) = r | S_i(t) = r)$. Where $r$ represents a `positive' disease state, this is the {\em sensitivity}, or the probability that a true positive is detected by the test. Where $r$ represents a `negative' or disease-free state, this represents the {\em specificity}, or the probability that, given the condition of interest is absent, the test produces a negative result. As an extension to the simple multi-state model described in section \ref{sec:multistate}, the \Rpackage{msm} package can fit a general multi-state model with misclassification. For patient $i$, observation time $t_{ij}$, observed states $O_{ij}$ are generated conditionally on true states $S_{ij}$ according to a {\em misclassification matrix} $E$. This is a $n \times n$ matrix, whose $(r,s)$ entry is \begin{equation} \label{eq:misc} e_{rs} = Pr(O(t_{ij}) = s | S(t_{ij}) = r), \end{equation} which we first assume to be independent of time $t$. Analogously to the entries of $Q$, some of the $e_{rs}$ may be fixed to reflect knowledge of the diagnosis process. For example, the probability of misclassification may be negligibly small for non-adjacent states of disease. Thus the progression through underlying states is governed by the transition intensity matrix $Q$, while the observation process of the underlying states is governed by the misclassification matrix $E$. To investigate explanatory variables $w(t)$ for the probability $e_{rs}$ of misclassification as state $s$ given underlying state $r$, a multinomial logistic regression model can be used: \begin{equation} \label{eq:misccovs} \log \frac{e_{rs}(t)}{e_{rs_0}(t)} = \gamma_{rs}^T w(t). \end{equation} where $s_0$ is some baseline state, usually chosen as the underlying state, or the state with the highest probability (for numerical stability). \subsubsection{General hidden Markov model} \label{sec:hmm:general} Consider now a general hidden Markov model in continuous time. The true state of the model $S_{ij}$ evolves as an unobserved Markov process. Observed data $y_{ij}$ are generated conditionally true states $S_{ij} = 1, 2, \ldots, n$ according to a set of distributions $f_1(y | \theta_1, \gamma_1)$, $f_2(y | \theta_2, \gamma_2)$, $\ldots$, $f_n(y | \theta_n, \gamma_n)$, respectively. $\theta_r$ is a vector of parameters for the state $r$ distribution. One or more of these parameters may depend on explanatory variables through a link-transformed linear model with coefficients $\gamma_r$. \subsubsection{Likelihood for general hidden Markov models} A type of EM algorithm known as the {\em Baum-Welch} or {\em forward-backward} algorithm \cite{baum:petrie66, baum:petrie70}, is commonly used for hidden Markov model estimation in discrete-time applications. See, for example, Durbin \etal \cite{biolog:seq}, Albert \cite{albert99}. A generalisation of this algorithm to continuous time was described by Bureau \etal \cite{bureau:hughes:shiboski:00}. The \Rpackage{msm} package uses a direct method of calculating likelihoods in discrete or continuous time based on matrix products. This type of method has been described by Macdonald and Zucchini \cite[pp. 77--79]{macdonald:zucchini}, Lindsey \cite[p.73]{lindsey:rm} and Guttorp \cite{guttorp}. Satten and Longini \cite{sattlong} used this method to calculate likelihoods for a hidden Markov model in continuous time with observations of a continuous marker generated conditionally on underlying discrete states. Patient $i$'s contribution to the likelihood is \begin{eqnarray} \label{eq:multi:hiddencontrib} L_i & = & Pr(y_{i1}, \ldots, y_{in_i})\\ & = & \sum Pr(y_{i1}, \ldots, y_{in_i} | S_{i1}, \ldots, S_{in_i}) Pr(S_{i1}, \ldots, S_{in_i}) \nonumber \end{eqnarray} where the sum is taken over all possible paths of underlying states $S_{i1}, \ldots, S_{in_i}$. Assume that the observed states are conditionally independent given the values of the underlying states. Also assume the Markov property, $Pr(S_{ij}|S_{i,j-1}, \ldots, S_{i1}) = Pr(S_{ij}|S_{i,j-1})$. Then the contribution $L_i$ can be written as a product of matrices, as follows. To derive this matrix product, decompose the overall sum in equation \ref{eq:multi:hiddencontrib} into sums over each underlying state. The sum is accumulated over the unknown first state, the unknown second state, and so on until the unknown final state: \begin{eqnarray} \label{eq:multi:hiddenlik} L_i & = & \sum_{S_{i1}} Pr(y_{i1}|S_{i1})Pr(S_{i1}) \sum_{S_{i2}} Pr(y_{i2}|S_{i2})Pr(S_{i2}|S_{i1}) \sum_{S_{i3}} Pr(y_{i3}|S_{i3}) Pr(S_{i3}|S_{i2}) \nonumber \\ & & \ldots \sum_{S_{in_i}} Pr(y_{in_i}|S_{in_i}) Pr(S_{in_i}|S_{in_{i-1}}) \end{eqnarray} where $Pr(y_{ij}|S_{ij})$ is the emission probability density. For misclassification models, this is the misclassification probability $e_{S_{ij} O_{ij}}$. For general hidden Markov models, this is the probability density $f_{S_{ij}}(y_{ij}|\theta_{S_{ij}},\gamma_{S_{ij}})$. $Pr(S_{i,j+1}|S_{ij})$ is the $(S_{ij}, S_{i,j+1})$ entry of the Markov chain transition matrix $P(t)$ evaluated at $t = t_{i,j+1} - t_{ij}$. Let $f$ be the vector with $r$ element the product of the initial state occupation probability $Pr(S_{i1}=r)$ and $Pr(y_{i1}| r)$, and let $\mathbf 1$ be a column vector consisting of ones. For $j = 2, \ldots, n_i$ let $T_{ij}$ be the $R \times R$ matrix (where $R$ is the number of states) with $(r,s)$ entry \[ Pr(y_{ij}| s) p_{rs} (t_{ij} - t_{i,j-1}) \] Then subject $i$'s likelihood contribution is \begin{equation} L_i = f T_{i2} T_{i3}, \ldots T_{in_i} \mathbf 1 \label{eq:multi:hidden:matprod} \end{equation} If $S(t_{j}) = D$ is an absorbing state such as death, measured without error, whose entry time is known exactly, then the contribution to the likelihood is summed over the unknown state at the previous instant before death. The $(r,s)$ entry of $T_{ij}$ is then \[ p_{rs}(t_{j} - t_{j-1}) q_{s, D} \] Section \ref{sec:fitting:hmm:misc} describes how to fit multi-state models with misclassification using the \Rpackage{msm} package, and Section \ref{sec:fitting:hmm:general} describes how to apply general hidden Markov models. \subsubsection{Example of a general hidden Markov model} \label{sec:hmm:example:fev} Jackson and Sharples \cite{jackson:sharples:2002} described a model for FEV$_1$ (forced expiratory volume in 1 second) in recipients of lung transplants. These patients were at risk of BOS (bronchiolitis obliterans syndrome), a progressive, chronic deterioration in lung function. In this example, BOS was modelled as a discrete, staged process, a model of the form illustrated in Figure \ref{fig:disease}, with 4 states. State 1 represents absence of BOS. State 1 BOS is roughly defined as a sustained drop below 80\% below baseline FEV$_1$, while state 2 BOS is a sustained drop below 65\% baseline. FEV$_1$ is measured as a percentage of a baseline value for each individual, determined in the first six months after transplant, and assumed to be 100\% baseline at six months. As FEV$_1$ is subject to high short-term variability due to acute events and natural fluctuations, the exact BOS state at each observation time is difficult to determine. Therefore, a hidden Markov model for FEV$_1$, conditionally on underlying BOS states, was used to model the natural history of the disease. Discrete states are appropriate as onset is often sudden. \paragraph{Model 1} Jackson \cite{my:phd} considered models for these data where FEV$_1$ were Normally distributed, with an unknown mean and variance conditionally each state (\ref{eq:fev:normal}). This model seeks the most likely location for the within-state FEV$_1$ means. \begin{equation} \label{eq:fev:normal} y_{ij} | \{ S_{ij} = k\} \sim N(\mu_k + \beta x_{ij}, \sigma^2_k) \end{equation} \paragraph{Model 2} Jackson and Sharples \cite{jackson:sharples:2002} used a more complex two-level model for FEV$_1$ measurements. Level 1 (\ref{eq:fev:level1}) represents the short-term fluctuation error of the marker around its underlying continuous value $y^{hid}_{ij}$. Level 2 (\ref{eq:fev:level2}) represents the distribution of $y^{hid}_{ij}$ conditionally on each underlying state, as follows. \begin{equation} \label{eq:fev:level1} y_{ij} | y^{hid}_{ij} \qquad \sim N ( y^{hid}_{ij} + \beta x_{ij} , \sigma^2_\epsilon) \end{equation} \begin{equation} \label{eq:fev:level2} y^{hid}_{ij} | S_{ij} \quad \sim \quad \left\{ \begin{array}{cll} \mbox{State}& \mbox{Three state model} & \mbox{Four state model} \\ S_{ij} = 0 & N(\mu_0, \sigma^2_0)I_{[80, \infty)} & N(\mu_0, \sigma^2_0)I_{[80, \infty)} \\ S_{ij} = 1 & N(\mu_1, \sigma^2_1)I_{(0, 80)} & Uniform(65, 80) \\ S_{ij} = 2 & \mbox{(death)} & N(\mu_2, \sigma^2_2)I_{(0, 65)} \\ S_{ij} = 3 & & \mbox{(death)} \end{array} \right . \end{equation} Integrating over $y^{hid}_{ij}$ gives an explicit distribution for $y_{ij}$ conditionally on each underlying state (given in Section \ref{sec:fitting:hmm:general}, Table \ref{tab:hmm:dists}). Similar distributions were originally applied by Satten and Longini \cite{sattlong} to modelling the progression through discrete, unobserved HIV disease states using continuous CD4 cell counts. The \Rpackage{msm} package includes density, quantile, cumulative density and random number generation functions for these distributions. In both models 1 and 2, the term $\beta x_{ij}$ models the short-term fluctuation of the marker in terms of acute events. $x_{ij}$ is an indicator for the occurrence of an acute rejection or infection episode within 14 days of the observation of FEV$_1$. Section \ref{sec:fitting:hmm:general} describes how these and more general hidden Markov models can be fitted with the \Rpackage{msm} package. \clearpage \section{Fitting multi-state models with {\tt msm}} <>= options(width = 60) @ \Rpackage{msm} is a package of functions for multi-state modelling using the R statistical software. The \Rfunction{msm} function itself implements maximum-likelihood estimation for general multi-state Markov or hidden Markov models in continuous time. We illustrate its use with a set of data from monitoring heart transplant patients. Throughout this section ``\textsl{\texttt{>}}'' indicates the R command prompt, \textsl{\texttt{slanted typewriter}} text indicates R commands, and \texttt{typewriter} text R output. \subsection{Installing \tt{msm}} \label{sec:installing} The easiest way to install the \Rpackage{msm} package on a computer connected to the Internet is to run the R command: \begin{Scode} install.packages("msm") \end{Scode} This downloads \Rpackage{msm} from the CRAN archive of contributed R packages (\texttt{cran.r-project.org} or one of its mirrors) and installs it to the default R system library. To install to a different location, for example if you are a normal user with no administrative privileges, create a directory in which R packages are to be stored, say, \texttt{/your/library/dir}, and run \begin{Scode} install.packages("msm", lib='/your/library/dir') \end{Scode} After \Rpackage{msm} has been installed, its functions can be made visible in an R session by <<>>= library(msm) @ or, if it has been installed into a non-default library, \begin{Scode} library(msm, lib.loc='/your/library/dir') \end{Scode} \subsection{Getting the data in} \label{sec:datain} The data are specified as a series of observations, grouped by patient. At minimum there should be a data frame with variables indicating \begin{itemize} \item the time of the observation, \item the observed state of the process. \end{itemize} If the data do not also contain \begin{itemize} \item the subject identification number, \end{itemize} then all the observations are assumed to be from the same subject. The subject ID does not need to be numeric, but data must be grouped by subject, and observations must be ordered by time within subjects. If the model includes variables with missing values, then the corresponding observations are omitted by \Rfunction{msm} with a warning. If you have missing data, as in any statistical model, it is recommended to ensure these do not result in biases. An example data set, taken from monitoring a set of heart transplant recipients, is provided with \Rpackage{msm}. (Note: since \Rpackage{msm} version 1.3, the command \Rfunction{data(cav)} is no longer needed to load the data --- it is now ``lazy-loaded'' when required). Sharples \etal \cite{my:cav} studied the progression of coronary allograft vasculopathy (CAV), a post-transplant deterioration of the arterial walls, using these data. Risk factors and the accuracy of the screening test were investigated using multi-state Markov and hidden Markov models. The first three patient histories are shown below. There are 622 patients in all. \Robject{PTNUM} is the subject identifier. Approximately each year after transplant, each patient has an angiogram, at which CAV can be diagnosed. The result of the test is in the variable \Robject{state}, with possible values 1, 2, 3 representing CAV-free, mild CAV and moderate or severe CAV respectively. A value of 4 is recorded at the date of death. \Robject{years} gives the time of the test in years since the heart transplant. Other variables include \Robject{age} (age at screen), \Robject{dage} (donor age), \Robject{sex} (0=male, 1=female), \Robject{pdiag} (primary diagnosis, or reason for transplant - IHD represents ischaemic heart disease, IDC represents idiopathic dilated cardiomyopathy), \Robject{cumrej} (cumulative number of rejection episodes), and \Robject{firstobs}, an indicator which is 1 when the observation corresponds to the patient's transplant (the first observation), and 0 when the observation corresponds to a later angiogram. <<>>= cav[1:21,] @ A useful way to summarise multi-state data is as a frequency table of pairs of consecutive states. This counts over all individuals, for each state $r$ and $s$, the number of times an individual had an observation of state $r$ followed by an observation of state $s$. The function \Rfunction{statetable.msm} can be used to produce such a table, as follows, <<>>= statetable.msm(state, PTNUM, data=cav) @ Thus there were 148 CAV-free deaths, 48 deaths from state 2, and 55 deaths from state 3. On only four occasions was there an observation of severe CAV followed by an observation of no CAV. \subsection{Specifying a model} \label{sec:specifying:model} We now specify the multi-state model to be fitted to the data. A model is governed by a transition intensity matrix $Q$. For the heart transplant example, there are four possible states through which the patient can move, corresponding to CAV-free, mild/moderate CAV, severe CAV and death. We assume that the patient can advance or recover from consecutive states while alive, and die from any state. Thus the model is illustrated by Figure \ref{fig:disease} with four states, and we have \[ Q = \left( \begin{array}{llll} -(q_{12} + q_{14}) & q_{12} & 0 & q_{14}\\ q_{21} & -(q_{21}+q_{23}+q_{24}) & q_{23} & q_{24}\\ 0 & q_{32} & -(q_{32}+q_{34}) & q_{34}\\ 0 & 0 & 0 & 0 \\ \end{array} \right ) \] It is important to remember that this defines which \emph{instantaneous} transitions can occur in the Markov process, and that the data are \emph{snapshots} of the process (see section \ref{sec:arbitr-observ-times}). Although there were 44 occasions on which a patient was observed in state 1 followed by state 3, we can still have $q_{13}=0$. The underlying model specifies that the patient must have passed through state 2 in between, rather than jumping straight from 1 to 3. If your data represent the exact and complete transition times of the process, then you must specify \Rfunarg{exacttimes=TRUE} or \Rfunarg{obstype=2} in the call to \Rfunction{msm}. To tell \Rfunction{msm} what the allowed transitions of our model are, we define a matrix of the same size as $Q$, containing zeroes in the positions where the entries of $Q$ are zero. All other positions contain an initial value for the corresponding transition intensity. The diagonal entries supplied in this matrix do not matter, as the diagonal entries of $Q$ are defined as minus the sum of all the other entries in the row. This matrix will eventually be used as the \Rfunarg{qmatrix} argument to the \Rfunction{msm} function. For example, <<>>= Q <- rbind ( c(0, 0.25, 0, 0.25), c(0.166, 0, 0.166, 0.166), c(0, 0.25, 0, 0.25), c(0, 0, 0, 0) ) @ Fitting the model is a process of finding values of the seven unknown transition intensities: $q_{12}$, $q_{14}$, $q_{21}$, $q_{23}$, $q_{24}$, $q_{32}$, $q_{34}$, which maximise the likelihood. \subsection{Specifying initial values} \label{sec:inits} The likelihood is maximised by numerical methods, which need a set of initial values to start the search for the maximum. For reassurance that the true maximum likelihood estimates have been found, models should be run repeatedly starting from different initial values. However a sensible choice of initial values can be important for unstable models with flat or multi-modal likelihoods. For example, the transition rates for a model with misclassification could be initialised at the corresponding estimates for an approximating model without misclassification. Initial values for a model without misclassification could be set by supposing that transitions between states take place only at the observation times. If we observe $n_{rs}$ transitions from state $r$ to state $s$, and a total of $n_r$ transitions from state $r$, then $q_{rs} / q_{rr}$ can be estimated by $n_{rs} / n_r$. Then, given a total of $T_r$ years spent in state $r$, the mean sojourn time $1 / q_{rr}$ can be estimated as $T_r / n_r$. Thus, $n_{rs} / T_r$ is a crude estimate of $q_{rs}$. Such default initial values can be used by supplying \Rfunarg{gen.inits=TRUE} in the call to \Rfunction{msm} below, along with a \Rfunarg{qmatrix} whose non-zero entries represent the allowed transitions of the model. Alternatively the function \Rfunction{crudeinits.msm} could be used to get this matrix of initial values explicitly as follows. These methods are only available for non-hidden Markov models. <<>>= Q.crude <- crudeinits.msm(state ~ years, PTNUM, data=cav, qmatrix=Q) @ However, if there are are many changes of state in between the observation times, then this crude approach may fail to give sensible initial values. For the heart transplant example we could also guess that the mean period in each state before moving to the next is about 2 years, and there is an equal probability of progression, recovery or death. This gives $q_{rr} = - 0.5$ for $r = 1, 2, 3$, and $q_{12} = q_{14} = 0.25$, $q_{21} = q_{23} = q_{24} = 0.166$, $q_{32} = q_{34} = 0.25$, and the initial value matrix \Robject{Q} shown above, which we now use to fit the model. \subsection{Running \Rfunction{msm}} \label{sec:running} To fit the model, call the \Rfunction{msm} function with the appropriate arguments. For our running example, we have defined a data set \Robject{cav}, a matrix \Robject{Q} indicating the allowed transitions, and initial values. We are ready to run \Rfunction{msm}. \paragraph{Model 1: simple bidirectional model} <<>>= cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4) @ In this example the day of death is assumed to be recorded exactly, as is usual in studies of chronic diseases. At the previous instant before death the state of the patient is unknown. Thus we specify \Rfunarg{deathexact = 4}, to indicate to \Rfunction{msm} that the entry times into state 4 are observed in this manner. If the model had five states, and states 4 and 5 were two competing causes of death with times recorded exactly in this way, then we would specify \Rfunarg{deathexact = c(4,5)}. By default, the data are assumed to represent snapshots of the process at arbitrary times. However, observations can also represent exact times of transition, ``exact death times'', or a mixture of these. See the \Rfunarg{obstype} argument to \Rfunction{msm}. While the \Rfunction{msm} function runs, it searches for the maximum of the likelihood of the unknown parameters. Internally, it uses the R function \Rfunction{optim} to minimise the minus log-likelihood. When the data set, the model, or both, are large, then this may take a long time. It can then be useful to see the progress of the optimisation algorithm. To do this, we can specify a \Rfunarg{control} argument to \Rfunction{msm}, which is passed internally to the \Rfunction{optim} function. For example \texttt{control = list(trace=1, REPORT=1)}. See the help page for \Rfunction{optim}, <>= help(optim) @ for more options to control the optimisation. \footnote{Note that since version 1.3.2, \Rfunarg{method=''BFGS''}, is the default optimisation algorithm in \Rfunction{msm}, since it can use analytic derivatives, which are available for most models.} When completed, the \Rfunction{msm} function returns a value. This value is a list of the important results of the model fitting, including the parameter estimates and their covariances. To keep these results for post-processing, we store them in an R object, here called \Robject{cav.msm}. When running several similar \Rfunction{msm} models, it is recommended to store the respective results in informatively-named objects. \subsection{Showing results} To show the maximum likelihood estimates and 95\% confidence intervals, type the name of the fitted model object at the R command prompt. \footnote{This is equivalent to typing \texttt{print.msm(cav.msm)}. The function \Rfunction{print.msm} formats the important information in the model object for printing on the screen.} The confidence level can be changed using the \Rfunarg{cl} argument to \Rfunction{msm}. <<>>= cav.msm @ From the estimated intensities, we see patients are three times as likely to develop symptoms than die without symptoms (transitions from state 1). After disease onset (state 2), progression to severe symptoms (state 3) is 50\% more likely than recovery. Once in the severe state, death is more likely than recovery, and a mean of 1 / -0.44 = 2.3 years is spent in state 3 before death or recovery. Section \ref{sec:extractor} describes various functions that can be used to obtain summary information from the fitted model. \subsection{Covariates on the transition rates} \label{sec:msm:covariates} We now model the effect of explanatory variables on the rates of transition, using a proportional intensities model. Now we have an intensity matrix $Q(z)$ which depends on a covariate vector $z$. For each entry of $Q(z)$, the transition intensity for patient $i$ at observation time $j$ is $q_{rs}(z_{ij}) = q_{rs}^{(0)} \exp(\beta_{rs}^T z_{ij})$. The covariates $z$ are specified through the \Rfunarg{covariates} argument to \Rfunction{msm}. If $z_{ij}$ is time-dependent, we assume it is constant in between the observation times of the Markov process. \Rfunction{msm} calculates the probability for a state transition from times $t_{i,j-1}$ to $t_{ij}$ using the covariate value at time $t_{i,j-1}$. We consider a model with just one covariate, female sex. Out of the 622 transplant recipients, 535 are male and 87 are female. By default, all linear covariate effects $\beta_{rs}$ are initialised to zero. To specify different initial values, use a \Rfunarg{covinits} argument, as described in \Rfunction{help(msm)}. Initial values given in the \Rfunarg{qmatrix} represent the intensities with covariate values set to their means in the data. In the following model, all transition intensities are modelled in terms of sex. \paragraph{Model 2: sex as a covariate} <<>>= cavsex.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4, covariates = ~ sex) @ Printing the \Robject{msm} object now displays the estimated covariate effects and their confidence intervals (note since version 1.3.2 these are \emph{hazard ratios} $\exp(\beta_{rs})$, not \emph{log hazard ratios} $\beta_{rs}$ as in previous versions). <<>>= cavsex.msm @ The sizes of the confidence intervals for some of the hazard ratios suggests there is no information in the data about the corresponding covariate effects, leading to a likelihood that is a flat function of these parameters, and this model should be simplified. The first column shown in the output is the estimated transition intensity matrix $q_{rs}(z) = q_{rs}^{(0)} \exp(\beta_{rs}^T z)$ with the covariate $z$ set to its mean value in the data. This represents an average intensity matrix for the population of 535 male and 87 female patients. To extract separate intensity matrices for male and female patients ($z = 0$ and $1$ respectively), use the function \Rfunction{qmatrix.msm}, as shown below. This and similar summary functions will be described in more detail in section \ref{sec:extractor}. <<>>= qmatrix.msm(cavsex.msm, covariates=list(sex=0)) # Male qmatrix.msm(cavsex.msm, covariates=list(sex=1)) # Female @ Since \Rpackage{msm} version 1.2.3, different transition rates may be easily modelled on different covariates by specifying a named list of formulae as the \Rfunarg{covariates} argument. Each element of the list has a name identifying the transition. In the model below, the transition rate from state 1 to state 2 and the rate from state 1 to state 4 are each modelled on sex as a covariate, but no other intensities have covariates on them. \paragraph{Model 2a: transition-specific covariates} <>= cavsex.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4, covariates = list("1-2" = ~ sex, "1-4" = ~sex) ) @ We may also want to constrain the effect of a covariate to be equal for certain transition rates, to reduce the number of parameters in the model, or to investigate hypotheses on the covariate effects. A \Rfunarg{constraint} argument can be used to indicate which of the transition rates have common covariate effects. \paragraph{Model 3: constrained covariate effects} <>= cav3.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4, covariates = ~ sex, constraint = list(sex=c(1,2,3,1,2,3,2)) ) @ This constrains the effect of sex to be equal for the progression rates $q_{12}, q_{23}$, equal for the death rates $q_{14}, q_{24}, q_{34}$, and equal for the recovery rates $q_{21}, q_{32}$. The intensity parameters are assumed to be ordered by reading across the rows of the transition matrix, starting at the first row: ($q_{12}, q_{14}, q_{21}, q_{23}, q_{24}, q_{32}, q_{34}$), giving constraint indicators \Rfunarg{(1,2,3,1,2,3,2)}. Any vector of increasing numbers can be used for the indicators. Negative entries can be used to indicate that some effects are equal to minus others: \Rfunarg{(1,2,3,-1,2,3,2)} sets the fourth effect to be minus the first. In a similar manner, we can constrain some of the baseline transition intensities to be equal to one another, using the \Rfunarg{qconstraint} argument. For example, to constrain the rates $q_{12}$ and $q_{23}$ to be equal, and $q_{24}$ and $q_{34}$ to be equal, specify \Rfunarg{qconstraint = c(1,2,3,1,4,5,4)}. \subsection{Fixing parameters at their initial values} For exploratory purposes we may want to fit a model assuming that some parameters are fixed, and estimate the remaining parameters. This may be necessary in cases where there is not enough information in the data to be able to estimate a proposed model, and we have strong prior information about a certain transition rate. To do this, use the \Rfunarg{fixedpars} argument to \Rfunction{msm}. For model 1, the following statement fixes the parameters numbered 6, 7, that is, $q_{32}$, $q_{34}$, to their initial values (0.25 and 0.25, respectively). \paragraph{Model 4: fixed parameters} <>= cav4.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4, control = list(trace=2, REPORT=1), fixedpars = c(6, 7) ) @ A \Rfunarg{fixedpars} statement can also be used for fixing covariate effect parameters to zero, that is to assume no effect of a covariate on a certain transition rate. \subsection{Extractor functions} \label{sec:extractor} We may want to extract some of the information from the \Rfunction{msm} model fit for post-processing, for example for plotting graphs or generating summary tables. A set of functions is provided for extracting interesting features of the fitted model. \begin{description} \item[Intensity matrices] The function \Rfunction{qmatrix.msm} extracts the estimated transition intensity matrix and its confidence intervals for a given set of covariate values, as shown in section \ref{sec:msm:covariates}. Confidence intervals are calculated from the covariance matrix of the estimates by assuming the distribution is symmetric on the log scale. Standard errors for the intensities are also available from the object returned by \Rfunction{qmatrix.msm}. These are calculated by the delta method. The \Rpackage{msm} package provides a general-purpose function \Rfunction{deltamethod} for estimating the variance of a function of a random variable $X$ given the expectation and variance of $X$. See \texttt{help(deltamethod)} for further details. Bootstrap confidence intervals are also available for \Rfunction{qmatrix.msm} and for most output functions; these are often more accurate, at the cost of computational time. For more about bootstrapping in \Rpackage{msm}, see Section \ref{sec:boot}. \item[Transition probability matrices] The function \Rfunction{pmatrix.msm} extracts the estimated transition probability matrix $P(t)$ within a given time. For example, for model 1, the 10 year transition probabilities are given by: <<>>= pmatrix.msm(cav.msm, t=10) @ Thus, a typical person in state 1, disease-free, has a probability of 0.5 of being dead ten years from now, a probability of 0.3 being still disease-free, and probabilities of 0.1 of being alive with mild/moderate or severe disease, respectively. This assumes $Q$ is constant within the desired time interval. For non-homogeneous processes, where $Q$ varies with time-dependent covariates but can be approximated as piecewise constant, there is an equivalent function \Rfunction{pmatrix.piecewise.msm}. Consult its help page for further details. If \Rfunarg{ci=''norm''} is specified, then a confidence interval is calculated based on drawing a random sample (default size 1000) from the assumed multivariate normal distribution of the maximum likelihood estimates and covariance matrix, and transforming. If \Rfunarg{ci=''boot''} is specified, then a bootstrap confidence interval for the transition probability matrix is calculated (see Section \ref{sec:boot}) . However, both of these are computationally intensive, particularly the bootstrap method, so no confidence interval is calculated by default. \item[Mean sojourn times] The function \Rfunction{sojourn.msm} extracts the estimated mean sojourn times in each transient state $r$, for a given set of covariate values. This is calculated as $-1 / \hat q_{rr}$, where $\hat q_{rr}$ is the $r$th diagonal entry of the estimated transition intensity matrix. <<>>= sojourn.msm(cav.msm) @ \item[Probability that each state is next] The function \Rfunction{pnext.msm} extracts the matrix of probabilities $-q_{rs} / q_{rr}$ that the next state after state $r$ is state $s$, for each $r$ and $s$. Together with the mean sojourn times, this gives a more intuitive parameterisation of a continuous-time Markov model than the raw transition intensities $q_{rs}$. Note these are different from the transition probabilities in a given time $t$ returned by \Rfunction{pmatrix.msm}. <<>>= pnext.msm(cav.msm) @ \item[Total length of stay] Mean sojourn times describe the average period in a single stay in a state. For processes with successive periods of recovery and relapse, we may want to forecast the total time spent healthy or diseased, before death. The function \Rfunction{totlos.msm} estimates the forecasted total length of time spent in each transient state $s$ between two future time points $t_1$ and $t_2$, for a given set of covariate values. This defaults to the expected amount of time spent in each state between the start of the process (time 0, the present time) and death or a specified future time. This is obtained as \[ L_s = \int_{t_1}^{t_2} P(t)_{r,s} dt \] where $r$ is the state at the start of the process, which defaults to 1. This is calculated using numerical integration. For model 1, each patient is forecasted to spend 8.8 years disease free, 2.2 years with mild or moderate disease and 1.8 years with severe disease. Bootstrap and asymptotic confidence intervals are available, as for \Rfunction{pmatrix.msm}, but are not calculated by default. <<>>= totlos.msm(cav.msm) @ \item[Expected first passage times] The function \Rfunction{efpt.msm} estimates the expected time until the process first enters a given state or set of states, also called the ``hitting time''. See its help page for further details. \item[Expected number of visits] The function \Rfunction{envisits.msm} estimates the expected number of visits to a state, computed in a similar way to the total length of stay. See its help page for further details. \item[Ratio of transition intensities] The function \Rfunction{qratio.msm} estimates a ratio of two entries of the transition intensity matrix at a given set of covariate values, together with a confidence interval estimated assuming normality on the log scale and using the delta method. For example, we may want to estimate the ratio of the progression rate $q_{12}$ into the first state of disease to the corresponding recovery rate $q_{21}$. For example in model 1, recovery is 1.8 times as likely as progression. <<>>= qratio.msm(cav.msm, ind1=c(2,1), ind2=c(1,2)) @ \item[Hazard ratios for transition] The function \Rfunction{hazard.msm} gives the estimated hazard ratios corresponding to each covariate effect on the transition intensities. 95\% confidence limits are computed by assuming normality of the log-effect. <<>>= hazard.msm(cavsex.msm) @ \end{description} \paragraph{Setting covariate values} All of these extractor functions take an argument called \Rfunarg{covariates}. If this argument is omitted, for example, <>= qmatrix.msm(cav.msm) @ then the intensity matrix is evaluated as $Q(\bar x)$ with all covariates set to their mean values $\bar x$ in the data. Alternatively, set \Rfunarg{covariates} to 0 to return the result $Q(0)$ with covariates set to zero. This will usually be preferable for categorical covariates, where we wish to see the result for the baseline category. <>= qmatrix.msm(cavsex.msm, covariates = 0) @ Alternatively, the desired covariate values can be specified explicitly as a list, <>= qmatrix.msm(cavsex.msm, covariates = list(sex = 1)) @ Values of categorical covariates must be quoted. For example, consider a covariate \texttt{smoke}, representing tobacco smoking status, with three levels, \texttt{NON, CURRENT, EX}, representing a non-smoker, current smoker or ex-smoker. \begin{Scode} qmatrix.msm(example.msm, covariates = list(age = 60, smoke=''CURRENT'')) \end{Scode} \subsection{Survival plots} In studies of chronic disease, an important use of multi-state models is in predicting the probability of survival for patients in increasingly severe states of disease, for some time $t$ in the future. This can be obtained directly from the transition probability matrix $P(t)$. The \Rfunction{plot} method for \Robject{msm} objects produces a plot of the expected probability of survival against time, from each transient state. Survival is defined as not entering the final absorbing state. <>= plot(cav.msm, legend.pos=c(8, 1)) @ This shows that the 10-year survival probability with severe CAV is approximately 0.1, as opposed to 0.3 with mild CAV and 0.5 without CAV. With severe CAV the survival probability diminishes very quickly to around 0.3 in the first five years after transplant. The \Rfunarg{legend.pos} argument adjusts the position of the legend in case of clashes with the plot lines. A \Rfunarg{times} argument can be supplied to indicate the time interval to forecast survival for. A more sophisticated analysis of these data might explore competing causes of death from causes related or unrelated to the disease under study. \subsection{Bootstrapping} \label{sec:boot} Most of \Rpackage{msm}'s output functions present confidence intervals based on asymptotic standard errors calculated from the Hessian, or transformations of these using the delta method. The asymptotic standard errors are expected to be underestimates of the true standard errors (Cramer-Rao lower bound). For some output functions, such as \Rfunction{pmatrix.msm}, and functions based on \Rfunction{pmatrix.msm} such as \Rfunction{totlos.msm} and \Rfunction{prevalence.msm}, the delta method cannot be used at all to obtain standard errors. In these cases, confidence intervals can be calculated by drawing a random sample from the assumed multivariate normal distribution of the maximum likelihood estimates and covariance matrix, and transforming. However, this is still based on potentially inaccurate asymptotic theory. The \Rpackage{msm} package provides the function \Rfunction{boot.msm} to enable bootstrap refitting of \Rfunction{msm} models, an alternative way to estimate uncertainty. For non-hidden Markov models, a bootstrap dataset is drawn by resampling pairs of consecutive states from the full data, i.e. \emph{transitions}. These are assumed to be independent when calculating the likelihood (Section \ref{sec:multi:likelihood}). For hidden Markov models and models with censoring, a bootstrap dataset is drawn by resampling complete series from independent subjects. The bootstrap datasets have the same number of transitions, or subjects, respectively, as the original data. For most output extractor functions provided with \Rpackage{msm}, the option \Rfunarg{ci=''boot''} is available, as a wrapper around \Rfunction{boot.msm}, to enable bootstrap confidence intervals to be calculated. But any user-defined output statistic can be bootstrapped, as follows. The function \Rfunction{boot.msm} is called with the fitted \Rfunction{msm} model as first argument, and an R function specifying the statistic to be bootstrapped as the second argument \texttt{stat}. The return value from \Rfunction{boot.msm} is a list of \texttt{B} replicates (by default, \texttt{B=1000}) of the desired statistic. For example, to bootstrap the transition intensity matrix of the heart transplantation model \Robject{cav.msm}: \begin{Scode} q.list <- boot.msm(cav.msm, stat=function(x){qmatrix.msm(x)$estimates}) \end{Scode} Note that for \Rfunction{boot.msm} to be able to refit the original model that produced \Robject{cav.msm}, all objects used in the original model fit (for example, in this case, \Robject{Q}) must be in the working environment. Otherwise, \Rfunction{boot.msm} will give an ``object not found'' error. The user can then summarise these replicates by calculating empirical standard deviations or quantile-based intervals. In this example, \Robject{q.list} is a list of 1000 4$\times$4 matrices. The following code calculates the bootstrap standard error as the empirical standard deviation of the 1000 replicates, and a similar 95\% bootstrap confidence interval. \begin{Scode} q.array <- array(unlist(q.list), dim=c(4,4,1000)) apply(q.array, c(1,2), sd) apply(q.array, c(1,2), function(x)quantile(x, c(0.025, 0.975))) \end{Scode} Note that when bootstrapping, the refits of the model to the resampled datasets may occasionally fail to converge (as discussed in Section \ref{sec:failure}) even if the original model fit did converge. In these cases, a warning is given, but \Rfunction{boot.msm} simply discards the failed dataset and moves on to the next bootstrap iteration. Unless convergence failure occurs for a large proportion of iterations, this should not affect the accuracy of the final bootstrap confidence intervals. \subsection{Convergence failure} \label{sec:failure} Inevitably if over-complex models are applied with insufficient data then the parameters of the model will not be identifiable. This will result in the optimisation algorithm failing to find the maximum of the log-likelihood, or even failing to evaluate the likelihood. For example, it will commonly be inadvisable to include several covariates in a model simultaneously. In some circumstances, the optimisation may report convergence, but fail to calculate any standard errors. In these cases, the Hessian of the log-likelihood at the reported solution is not positive definite. Thus the reported solution may be a saddle point rather than the maximum likelihood, or it may be close to the maximum. \begin{description} \item[Model simplification] Firstly, make sure there are not too many parameters in the model. There may not be enough information in the data on a certain transition rate. It is recommended to count all the pairs of transitions between states in successive observation times, making a frequency table of previous state against current state (function \Rfunction{statetable.msm}), and do this for any subgroups defining covariates. Although the data are a series of snapshots of a continuous-time process, and the actual transitions take place in between the observation times, this type of table may still be helpful. If there are not many observed `transitions' from state 2 to state 4, for example, then the data may be insufficient to estimate $q_{24}$. For a staged disease model (Figure \ref{fig:disease}), the number of disease states should be low enough that all transition rates can be estimated. Consecutive states of disease severity should be merged if necessary. If it is realistic, consider applying constraints on the intensities or the covariate effects so that the parameters are equal for certain transitions, or zero for certain transitions. Be careful to use a observation scheme and transition matrix appropriate to your data (see Section \ref{sec:arbitr-observ-times}). By default, \Rfunction{msm} assumes that the data represent snapshots of the process, and the true state is unknown between observation times. In such circumstances, it is rarely feasible to estimate an intensity matrix with \emph{instantaneous} transitions allowed between every pair of states. This would be easier if the complete course of the process is known \Rfunarg{(exacttimes = TRUE)} in the call to \Rfunction{msm}. Understand the difference between \emph{instantaneous} and \emph{interval} transitions - although individuals may be in state 1 at time $t_r$, and state 3 at time $t_{r+1}$, that doesn't mean that instantaneous transitions from 1 to 3 should be permitted. \item[Initial values] Make sure that a sensible set of initial values have been chosen. The optimisation may only converge within a limited range of `informative' initial values. It is also sensible to run the model for several different initial values to ensure that the estimation has converged to a global rather than a local optimum. \item[Scaling] It is often necessary to apply a scaling factor to normalise the likelihood (\Rfunarg{fnscale}), or certain individual parameters \Rfunarg{(parscale)}. This may prevent overflow or underflow problems within the optimisation. For example, if the value of the -2 $\times$ log-likelihood is around 5000, then the following option leads to an minimisation of the -2 $\times$ log-likelihood on an approximate unit scale: \Rfunarg{control = list(fnscale = 5000)}. % Though since version 1.4.1, \Rfunarg{fnscale} is applied automatically using the likelihood at the initial values, unless the user has already supplied it. % If not provided by the user, \code{control=list(fnscale = a)} is % applied automatically to normalise the optimisation, where \code{a} % is the minus twice log likelihood at the initial values. It is also advisable to analyse all variables, including covariates and the time unit, on a roughly normalised scale. For example, working in terms of a time unit of months or years instead of days, when the data range over thousands of days. \item[Convergence criteria] ``False convergence'', in which \Rfunction{optim()} reports convergence of the optimisation but the Hessian is not positive definite, can sometimes be solved by tightening the criteria (\Rfunarg{reltol}, defaults to \texttt{1e-08}) for reporting convergence. For example, \Rfunarg{control = list(reltol = 1e-16)}. Alternatively consider using smaller step sizes for the numerical approximation to the gradient, used in calculating the Hessian. This is given by the control parameter \Rfunarg{ndeps}. For example, for a model with 5 parameters, \Rfunarg{control = list(ndeps = rep(1e-6, 5))} \item[Choice of algorithm] By default, since version 1.3.2, \Rfunction{msm} uses the BFGS method of \Rfunction{optim}, which makes use of analytic derivatives. Analytic derivatives are available for all models in msm, apart from hidden Markov models with unknown initial state probabilities, misclassification models with equality constraints on misclassification probabilities, and truncated or measurement-error outcome distributions. This speeds up optimisation. Though alternative algorithms are available such as \Rfunarg{method = ``CG''}. Or use the \Rfunction{nlm} R function via \Rfunarg{msm(..., opt.method = "nlm" , ...)} Note also the Fisher scoring method available for non-hidden Markov models for panel data, via \Rfunarg{msm(..., opt.method = "fisher", ...)}, is expected to be faster than the generic methods, but less robust to bad initial values. Or since version 1.3.2, msm can also use \Rfunarg{method=``bobyqa''} from the \Rpackage{minqa} package, a fast derivative-free method. \item[\Rfunction{optim} "function cannot be evaluated at initial parameters"] To diagnose this problem, run \Rfunction{msm} again with \Rfunarg{fixedpars=TRUE} set, to calculate the -2 log-likelihood at the initial values. This will probably be \Robject{Inf}. To show the contributions of individual subjects to the overall log likelihood, call \Rfunction{logLik.msm(x, by.subject=TRUE)}, where \Robject{x} is the fitted model object. If only a few subjects give an infinite log-likelihood, then you can check whether their state histories are particularly unusual and conflict with the model. For example, they might appear to make unusually large jumps between states in short periods of time. For models with misclassification, note that the default true initial state distribution \Rfunarg{initprobs} puts all individuals in true state 1 at their first observation. If someone starts in a much higher state, this may result in an infinite log-likelihood, and changing \Rfunarg{initprobs} would be sensible. \end{description} \subsection{Model assessment} \label{sec:model-assessment} \paragraph{Observed and expected prevalence} To compare the relative fit of two nested models, it is easy to compare their likelihoods. However it is not always easy to determine how well a fitted multi-state model describes an irregularly-observed process. Ideally we would like to compare observed data with fitted or expected data under the model. If there were times at which all individuals were observed then the fit of the expected numbers in each state or {\em prevalences} can be assessed directly at those times. Otherwise, some approximations are necessary. We could assume that an individual's state at an arbitrary time $t$ was the same as the state at their previous observation time. This might be fairly accurate if observation times are close together. This approach is taken by the function \Rfunction{prevalence.msm}, which constructs a table of observed and expected numbers and percentages of individuals in each state at a set of times. A set of expected counts can be produced if the process begins at a common time for all individuals. Suppose at this time, each individual is in state 0. Then given $n(t)$ individuals are under observation at time $t$, the expected number of individuals in state $r$ at time $t$ is $n(t) P(t)_{0,r}$. If the covariates on which $P(t)$ depends vary between individuals, then this can be averaged over the covariates observed in the data. For example, we calculate the observed and expected numbers and percentages at two-yearly intervals up to 20 years after transplant, for the heart transplant model \Rfunction{cav.msm}. The number of individuals still alive and under observation decreases from 622 to 251 at year 20. The observed and expected percentages are plotted against time. <<>>= options(digits=3) prevalence.msm(cav.msm, times=seq(0,20,2)) @ <>= plot.prevalence.msm(cav.msm, mintime=0, maxtime=20) @ Comparing the observed and expected percentages in each state, we see that the predicted number of individuals who die (State 4) is under-estimated by the model from about year 8 onwards. Similarly the number of individuals sill alive and free of CAV (State 1) is over-estimated by the model from about year 8 onwards. Such discrepancies could have many causes. One possibility is that the transition rates vary with the time since the beginning of the process, the age of the patient, or some other omitted covariate, so that the Markov model is {\em non-homogeneous}. This could be accounted for by modelling the intensity as a function of age, for example, such as a piecewise-constant function. The \Rfunarg{pci} argument to \Rfunction{msm} can be used to automatically construct models with transition intensities which are piecewise-constant in time. In this example, the hazard of death may increase with age, so that the model underestimates the number of deaths when forecasting far into the future. Another cause of poor model fit may sometimes be the failure of the Markov assumption. That is, the transition intensities may depend on the time spent in the current state (a semi-Markov process) or other characteristics of the process history. Accounting for the process history is difficult as the process is only observed through a series of snapshots. Semi-Markov models may in principle be fitted to this type of data using phase-type distributions. Since version 1.4.1 the \Rfunarg{phase.states} option to \Rfunction{msm} can be used to define some phase-type models. See \Rfunction{help(msm)} for further details. However, if it is known that individuals who died would not have been followed up after a certain time, had they survived to that time, then they should not be included in the observed prevalence of the death state after that time. This can be accounted for by passing a vector of maximum potential follow-up times, one for each individual in the same order as the original data, in the \Rfunarg{censtime} argument to \Rfunction{prevalence.msm}. Ignoring the potential follow-up times is likely to have resulted in overestimates of the number of deaths at later times in the CAV example, though these times are not available in the data supplied with \Rpackage{msm}. \paragraph{Pearson-type goodness-of-fit test} \label{sec:pearson} Suppose that the true transition times are unknown, and data consist of observations of the process at arbitrary times which differ between individuals (panel data). Assessing goodness of fit by prevalence counts then involves estimating the observed prevalence at a series of points by some form of interpolation. This is only advisable if observation times are close together. An alternative method of assessing goodness-of-fit is to construct tables of observed and expected numbers of transitions, as described by Aguirre-Hernandez and Farewell \cite{ahf}. This leads to a formal test of goodness-of-fit, analogous to the classical Pearson $\chi^2$ test for contingency tables. The tables are constructed as follows. Each pair of successive observations in the data (\emph{transition}) is classified by \begin{itemize} \item the starting state $r$ and finishing state $s$, \item time between the start of the process and the first of the pair of observations (indexed by $h$), \item time interval between the observations (indexed by $l_h$, within categories $h$), \item (if there are fitted covariates) the impact of covariates, as summarised by $q_{rr}$ (indexed by $c$), \item any other grouping of interest for diagnosing lack of fit (indexed by $g$). \end{itemize} Groupings of continuous quantities are normally defined by quantiles, so that there are a similar number of observed transitions in each (one-dimensional) category. The observed and expected numbers of transitions in each group are then defined by \[ o_{hl_h rscg} = \sum I(S(t_{i,j+1}) = s, S(t_{ij}) = r) \] \[ e_{hl_h rscg} = \sum P(S(t_{i,j+1}) = s | S(t_{ij}) = r) \] where $I(A)$ is the indicator function for an event $A$ and the summation is over the set of transitions in the category defined by $h,l_h,c,g$, over all individuals $i$. The Pearson-type test statistic is then \[ T = \sum_{hl_h rscg} \frac{(o_{hl_h rscg} - e_{hl_h rscg})^2}{e_{hl_h rscg}} \] The classical Pearson test statistic is distributed as $\chi^2_{n-p}$, where $n$ is the number of independent cells in the table and $p$ is the number of estimated parameters $p$. But the null distribution of $T$ is not exactly $\chi^2$, since the time intervals are non-identical, therefore the observed transitions are realizations from a set of independent but non-identical multinomial distributions. Titman \cite{titman:asympnull} showed that the null distribution of $T$ is asymptotically approximated by a weighted sum of $\chi^2_1$ random variables. Aguirre-Hernandez and Farewell \cite{ahf} also showed that $\chi^2_{n-p}$ is a good approximation if there are no fitted covariates. For models with covariates, the null mean of $T$ is higher than $n - p$, but lower than $n$. Therefore, upper and lower bounds for the true $p$-value of the statistic can be obtained from the $\chi^2_{n-p}$ and $\chi^2_n$ distributions. Aguirre-Hernandez and Farewell \cite{ahf} also described a bootstrap procedure for obtaining an accurate $p$-value. Titman and Sharples \cite{titman:sharples} described modifications to the test to correct for the biases introduced where in addition to the panel-data observation scheme: \begin{itemize} \item Times of death are known exactly. In this case, transitions ending in death are classified according to the next scheduled observation time after the death, which is estimated by multiple imputation from a Kaplan-Meier estimate of the distribution of time intervals between observations. \item An individual's final observation is censored, so that they are only known to be alive at that point. \item States are misclassified. \end{itemize} The \Rpackage{msm} package provides the function \Rfunction{pearson.msm} to perform the Pearson-type test. By default, three groups are used for each of $h$, $l_h$ and $c$. Often the number of groups will need to be reduced in cases where the resulting contingency tables are sparse (thus there are several low expected counts and the variance of $T$ is inflated). The test is now performed on the model \Robject{cav.msm} for the heart transplant dataset (a version of which was also analysed by Titman and Sharples \cite{titman:sharples}). The default three interval groups are used, and two groups of the time since the start of the process. The \Rfunarg{transitions} argument groups the transitions from state 3 to each of states 1, 2 and 3 (the 9th, 10th and 11th transitions) together in the table, since these transitions are infrequent. <<>>= options(digits=2) pearson.msm(cav.msm, timegroups=2, transitions=c(1,2,3,4,5,6,7,8,9,9,9,10)) @ The first two tables in the output show the contingency tables of observed and expected numbers of transitions. Note that the observed number of transitions in certain categories is not a whole number, since these are averaged over multiple imputations of the next scheduled observation time following deaths. The column \texttt{Time} is the group defined by time since the start of the process, and the column \texttt{Interval} is the group defined by intervals between observations. The columns indicate the allowed transitions, or pairs of states which can be observed in successive observations. The third table presents the ``deviance'', the value of $\frac{(o_{hl_h rscg} - e_{hl_h rscg})^2}{e_{hl_h rscg}}$ for each cell, multipled by the sign of $o_{hl_h rscg} - e_{hl_h rscg}$ to indicate whether there were more or fewer transitions than expected in each cell. These can indicate areas of bad fit. For example, systematic changes in deviance by time or time interval between observations can indicate that a model with time-varying transition intensities is more suitable. Changes in deviance by covariate impact may indicate heterogeneity between individuals which is unexplained by the fitted covariates. Changes in deviance with the length of the interval between observations may also indicate failure of the Markov assumption, and that a semi-Markov model (in which intensities depend on the time spent in the current state) may fit better. In this example, the test statistic is 100. \Robject{p.upper} is an upper bound for the $p$-value of the statistic based on an asymptotic $\chi^2_{42}$ distribution, therefore the model does not fit well. It is not clear from the table of deviances which aspects of the fit are most influental to the test statistic. However, the two-way Markov model itself is not biologically plausible, as discussed in Section \ref{sec:fitting:hmm:misc}. For non-hidden Markov models for panel data, \Rfunction{pearson.msm} also presents the accurate analytic p-value of Titman \cite{titman:asympnull}. For all models, \Rfunction{pearson.msm} provides an option for parametric bootstrapping to obtain an accurate p-value. \subsection{Fitting misclassification models with \Rpackage{msm}} \label{sec:fitting:hmm:misc} In fact, in the heart transplant example from section \ref{sec:datain}, it is not medically realistic for patients to recover from a diseased state to a healthy state. Progression of coronary artery vasculopathy is thought to be an irreversible process. The angiography scan for CAV is actually subject to error, which leads to some false measurements of CAV states and apparent recoveries. Thus we account for misclassification by fitting a \emph{hidden Markov model} using \Rpackage{msm}. Firstly we replace the two-way multi-state model by a one-way model with transition intensity matrix \[ Q = \left( \begin{array}{llll} -(q_{12} + q_{14}) & q_{12} & 0 & q_{14}\\ 0 & -(q_{23}+q_{24}) & q_{23} & q_{24}\\ 0 & 0 & -q_{34} & q_{34}\\ 0 & 0 & 0 & 0 \\ \end{array} \right ) \] We also assume that true state 1 (CAV-free) can be classified as state 1 or 2, state 2 (mild/moderate CAV) can be classified as state 1, 2 or 3, while state 3 (severe CAV) can be classified as state 2 or 3. Recall that state 4 represents death. Thus our matrix of misclassification probabilities is \[ E = \left( \begin{array}{llll} 1 - e_{12} & e_{12} & 0 & 0 \\ e_{21} & 1 - e_{21} - e_{23} & e_{23} & 0 \\ 0 & e_{32} & 1 - e_{32} & 0 \\ 0 & 0 & 0 & 0\\ \end{array} \right) \] with underlying states as rows, and observed states as columns. To model observed states with misclassification, we define a matrix \Rfunarg{ematrix} indicating the states that can be misclassified. Rows of this matrix correspond to true states, columns to observed states. It should contains zeroes in the positions where misclassification is not permitted. Non-zero entries are initial values for the corresponding misclassification probabilities. We then call \Rfunction{msm} as before, but with this matrix as the \Rfunarg{ematrix} argument. Initial values of 0.1 are assumed for each of the four misclassification probabilities $e_{12}, e_{21}, e_{23}, e_{32}$. Zeroes are given where the elements of $E$ are zero. The diagonal elements supplied in \Rfunarg{ematrix} are ignored, as rows must sum to one. The matrix \Rfunarg{qmatrix}, specifying permitted transition intensities and their initial values, also changes to correspond to the new $Q$ representing the progression-only model for the underlying states. The true state for every patient at the date of transplant is known to be ``CAV-free'', not misclassified. To indicate this we use the argument \Rfunarg{obstrue} to \Rfunction{msm}. This is set to be a variable in the dataset, \Rfunarg{firstobs}, indicating where the observed state equals the true state. This takes the value of 1 at the patient's first observation, at the transplant date, and 0 elsewhere. We use an alternative quasi-Newton optimisation algorithm \Rfunarg{(method="BFGS")} which can often be faster or more robust than the default Nelder-Mead simplex-based algorithm. An optional argument \Rfunarg{initprobs} could also have been given here, representing the vector of the probabilities of occupying each true state at the initial observation (equation \ref{eq:multi:hidden:matprod}). This can also be a matrix with number of rows equal to the number of subjects, if these probabilities are subject-dependent and known. If not given, all individuals are assumed to be in true state 1 at their initial observation. If \Rfunarg{est.initprobs=TRUE} is specified, then these probabilites are estimated as part of the model fit, using a vector \Rfunarg{initprobs} as initial values. Covariate effects on these probabilities can also be estimated using a multinomial logistic regression model, if an \Rfunarg{initcovariates} argument is specified. See \Rfunction{help(msm)} for further details. \paragraph{Model 5: multi-state model with misclassification} <<>>= Qm <- rbind(c(0, 0.148, 0, 0.0171), c(0, 0, 0.202, 0.081), c(0, 0, 0, 0.126), c(0, 0, 0, 0)) ematrix <- rbind(c(0, 0.1, 0, 0), c(0.1, 0, 0.1, 0), c(0, 0.1, 0, 0), c(0, 0, 0, 0)) cavmisc.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = Qm, ematrix = ematrix, deathexact = 4, obstrue = firstobs) cavmisc.msm @ Thus there is an estimated probability of about 0.03 that mild/moderate CAV will be diagnosed erroneously, but a rather higher probability of 0.17 that underlying mild/moderate CAV will be diagnosed as CAV-free. Between the two CAV states, the mild state will be misdiagnosed as severe with a probability of 0.06, and the severe state will be misdiagnosed as mild with a probability of 0.12. The model also estimates the progression rates through underlying states. An average of 8 years is spent disease-free, an average of about 3 years is spent with mild/moderate disease, and periods of severe disease also last about 3 years on average before death. \subsection{Effects of covariates on misclassification rates} We can investigate how the probabilities of misclassification depend on covariates in a similar way to the transition intensities, using a \Rfunarg{misccovariates} argument to \Rfunction{msm}. For example, we now include female sex as a covariate for the misclassification probabilities. The linear effects on the log odds of each misclassified state relative to the true state are initialised to zero by default (but this can be changed with the \Rfunarg{misccovinits} argument). \paragraph{Model 6: misclassification model with misclassification probabilities modelled on sex} <<>>= cavmiscsex.msm <- msm(state ~ years, subject = PTNUM, data = cav, qmatrix = Qm, ematrix = ematrix, deathexact = 4, misccovariates = ~sex, obstrue=firstobs) @ <<>>= cavmiscsex.msm @ The large confidence interval for the odds ratio for 1/2 misclassification suggests there is no information in the data about the difference between genders in the false positive rates for angiography. On the other hand, women have slightly more false negatives. \subsection{Extractor functions} As well as the functions described in section \ref{sec:extractor} for extracting useful information from fitted models, there are a number of extractor functions specific to models with misclassification. \begin{description} \item[Misclassification matrix] The function \Rfunction{ematrix.msm} gives the estimated misclassification probability matrix at the given covariate values. For illustration, the fitted misclassification probabilities for men and women in model 6 are given by <<>>= ematrix.msm(cavmiscsex.msm, covariates=list(sex=0)) ematrix.msm(cavmiscsex.msm, covariates=list(sex=1)) @ The confidence intervals for the estimates for women are wider, since there are only 87 women in this set of 622 patients. \item[Odds ratios for misclassification] The function \Rfunction{odds.msm} would give the estimated odds ratios corresponding to each covariate effect on the misclassification probabilities. \begin{Scode} odds.msm(cavmiscsex.msm) \end{Scode} \item[Observed and expected prevalences] The function \Rfunction{prevalence.msm} is intended to assess the goodness of fit of the hidden Markov model for the \emph{observed} states to the data. Tables of observed prevalences of observed states are calculated as described in section \ref{sec:model-assessment}, by assuming that observed states are retained between observation times. The expected numbers of individuals in each observed state are calculated similarly. Suppose the process begins at a common time for all individuals, and at this time, the probability of occupying \emph{true} state $r$ is $f_r$. Then given $n(t)$ individuals under observation at time $t$, the expected number of individuals in true state $r$ at time $t$ is the $r$th element of the vector $n(t) f P(t)$. Thus the expected number of individuals in \emph{observed} state $r$ is the $r$th element of the vector $n(t) f P(t) E$, where $E$ is the misclassification probability matrix. The expected prevalences (not shown) for this example are similar to those forecasted by the model without misclassification, with underestimates of the rates of death from 8 years onwards. To improve this model's long-term prediction ability, it is probably necessary to account for the natural increase in the hazard of death from any cause as people become older. \item[Goodness-of-fit test] The Pearson-type goodness-of-fit test is performed, as in Section \ref{sec:pearson}. The table of deviances indicates that there are more 1-3 and 1-4 transitions than expected in short intervals, and fewer in long intervals. This may indicate some time-dependence in the transition rates. Indeed, Titman \cite{titman:phd} found that a model with piecewise-constant transition intensities gave a greatly improved fit to these data. <<>>= pearson.msm(cavmisc.msm, timegroups=2, transitions=c(1,2,3,4,5,6,7,8,9,9,9,10)) @ \end{description} \subsection{Recreating the path through underlying states} In speech recognition and signal processing, {\em decoding} is the procedure of determining the underlying states that are most likely to have given rise to the observations. The most common method of reconstructing the most likely state path is the {\em Viterbi} algorithm. Originally proposed by Viterbi \cite{viterbi}, it is also described by Durbin \etal \cite{biolog:seq} and Macdonald and Zucchini \cite{macdonald:zucchini} for discrete-time hidden Markov chains. For continuous-time models it proceeds as follows. Suppose that a hidden Markov model has been fitted and a Markov transition matrix $P(t)$ and misclassification matrix $E$ are known. Let $v_k(t_i)$ be the probability of the most probable path ending in state $k$ at time $t_i$. \begin{enumerate} \item Estimate $v_k(t_1)$ using known or estimated initial-state occupation probabilities. \item For $i = 1 \ldots N$, calculate $v_l(t_i) = e_{l,O_{t_i}} \max_k v_k(t_{i-1}) P_{kl}(t_{i} - t_{i-1})$. Let $K_i(l)$ be the maximising value of $k$. \item At the final time point $t_N$, the most likely underlying state $S^*_N$ is the value of $k$ which maximises $v_k(t_N)$. \item Retrace back through the time points, setting $S^*_{i-1} = K_i(S^*_i)$. \end{enumerate} The computations should be done in log space to prevent underflow. The \Rpackage{msm} package provides the function \Rfunction{viterbi.msm} to implement this method. For example, the following is an extract from a result of calling \Rfunction{viterbi.msm} to determine the most likely underlying states for all patients. The results for patient 100103 are shown, who appeared to `recover' to a less severe state of disease while in state 3. We assume this is not biologically possible for the true states, so we expect that either the observation of state 3 at time 4.98 was an erroneous observation of state 2, or their apparent state 2 at time 5.94 was actually state 3. According to the expected path constructed using the Viterbi algorithm, it is the observation at time 5.94 which is most probably misclassified. <<>>= vit <- viterbi.msm(cavmisc.msm) vit[vit$subject==100103,] @ \subsection{Fitting general hidden Markov models with \Rpackage{msm}} \label{sec:fitting:hmm:general} The \Rpackage{msm} package provides a framework for fitting continuous-time hidden Markov models with general, continuous outcomes. As before, we use the \Rfunction{msm} function itself. \paragraph{Specifying the hidden Markov model} A hidden Markov model consists of two related components: \begin{itemize} \item the model for the evolution of the underlying Markov chain, \item the set of models for the observed data conditionally on each underlying state. \end{itemize} The model for the transitions between underlying states is specified as before, by supplying a \Rfunarg{qmatrix}. The model for the outcomes is specified using the argument \Rfunarg{hmodel} to \Rfunction{msm}. This is a list, with one element for each underlying state, in order. Each element of the list should be an object returned by a hidden Markov model \emph{constructor function}. The HMM constructor functions provided with \Rpackage{msm} are listed in Table \ref{tab:hmm:dists}. There is a separate constructor function for each class of outcome distribution, such as uniform, normal or gamma. Consider a three-state hidden Markov model, with a transition intensity matrix of \[ Q = \left( \begin{array}{llll} -q_{12} & q_{12} & 0 \\ 0 & -q_{23} & q_{23}\\ 0 & 0 & 0 \\ \end{array} \right ) \] Suppose the outcome distribution for state 1 is Normal$(\mu_1, \sigma^2_1)$, the distribution for state 2 is Normal$(\mu_2, \sigma^2_2)$, and state 3 is exactly observed. Observations of state 3 are given a label of -9 in the data. Here our \Rfunarg{hmodel} argument should be a list of objects returned by \Rfunction{hmmNorm} and \Rfunction{hmmIdent} constructor functions. We must specify initial values for the parameters as the arguments to the constructor functions. For example, we take initial values of $\mu_1 = 90, \sigma_1 = 8, \mu_2 = 70, \sigma_2 = 8$. Initial values for $q_{12}$ and $q_{23}$ are 0.25 and 0.2. Finally suppose the observed data are in a variable called \Robject{y}, the measurement times are in \Robject{time}, and subject identifiers are in \Robject{ptnum}. The call to \Rfunction{msm} to estimate the parameters of this hidden Markov model would then be \begin{Scode} msm( y ~ time, subject=ptnum, data = example.df, qmatrix = rbind( c(0, 0.25, 0), c(0, 0, 0.2), c(0, 0, 0)), hmodel = list (hmmNorm(mean=90, sd=8), hmmNorm(mean=70, sd=8), hmmIdent(-9)) ) \end{Scode} \begin{table}[htbp] \scriptsize \centering \begin{tabular}{lp{0.8in}p{0.6in}p{0.6in}p{0.7in}l} \hline Function & Distribution & Parameters & & Location (link) & Density for an observation $x$ \\ \hline \Rfunction{hmmCat} & Categorical & \Rfunarg{prob, basecat} & $p,c_0$ & $p$ (logit) & $p_x$, $x = 1, \ldots, n$ \\ \Rfunction{hmmIdent} & Identity & \Rfunarg{x} & $x_0$ & & $I_{x = x_0}$ \\ \Rfunction{hmmUnif} & Uniform & \Rfunarg{lower, upper} & $l,u$ & & $1 / (u - l)$, $u \leq x \leq l$ \\ \Rfunction{hmmNorm} & Normal & \Rfunarg{mean, sd} & $\mu,\sigma$ & $\mu$ (identity) & $\phi(x, \mu, \sigma) = \frac{1}{\sqrt{2 \pi \sigma^2}} \exp(-(x - \mu)^2/(2 \sigma^2) )$ \\ \Rfunction{hmmLNorm} & Log-normal & \Rfunarg{meanlog, sdlog} & $\mu,\sigma$ & $\mu$ (identity) & $\frac{1}{x \sqrt{2 \pi \sigma^2}} \exp(-(\log x - \mu)^2 / (2 \sigma^2))$ \\ \Rfunction{hmmExp} & Exponential & \Rfunarg{rate} & $\lambda$ & $\lambda$ (log) & $\lambda e^{- \lambda x}$, $x > 0$ \\ \Rfunction{hmmGamma} & Gamma & \Rfunarg{shape, rate} & $n,\lambda$ & $\lambda$ (log) & $\frac{\lambda^n}{\Gamma(n)}x^{n-1} \exp(-\lambda x)$, $x > 0, n > 0, \lambda > 0$ \\ \Rfunction{hmmWeibull} & Weibull & \Rfunarg{shape, scale} & $a, b$ & $b$ (log) & $\frac{a}{b} (\frac{x}{b})^{a-1} \exp{(-(\frac{x}{b})^a)}$, $x > 0$ \\ \Rfunction{hmmPois} & Poisson & \Rfunarg{rate} & $\lambda$ & $\lambda$ (log) & $\lambda^x \exp(-\lambda)/x!$, $x = 0, 1, 2, \ldots$ \\ \Rfunction{hmmBinom} & Binomial & \Rfunarg{size, prob} & $n,p$ & $p$ (logit) & ${n \choose x} p^x (1-p)^{n-x}$ \\ \Rfunction{hmmNBinom} & Negative binomial & \Rfunarg{disp, prob} & $n,p$ & $p$ (logit) & $\Gamma(x+n)/(\Gamma(n)x!) p^n (1-p)^x$ \\ \Rfunction{hmmBeta} & Beta & \Rfunarg{shape1,shape2} & $a,b$ & & $ \Gamma(a+b) / (\Gamma(a)\Gamma(b))x^{a-1}(1-x)^{b-1}$ \\ \Rfunction{hmmT} & Student $t$ & \Rfunarg{mean, scale, df} & $\mu,\sigma,k$ & $\mu$ (identity) & $\frac{\Gamma\left((k+1)/2\right)}{\Gamma(k/2)}{\sqrt{\frac{1}{k\pi\sigma^2}}}\left\{1 + \frac{1}{k\sigma^2}(x - \mu)^{2} \right\}^{-(k + 1)/2}$ \\ \Rfunction{hmmTNorm} & Truncated normal & \Rfunarg{mean, sd, lower, upper} & $\mu,\sigma,l,u$ & $\mu$ (identity) & \parbox[t]{2in}{$\phi(x, \mu, \sigma) / \\ (\Phi(u, \mu, \sigma) - \Phi(l, \mu, \sigma))$, \\ where $\Phi(x,\mu,\sigma) = \int_{-\infty}^x \phi(u,\mu,\sigma) du$} \\ \Rfunction{hmmMETNorm} & Normal with truncation and measurement error & \Rfunarg{mean, sd, lower, upper, sderr, meanerr} & \parbox[t]{1in} {$\mu_0,\sigma_0,l,u$, \\ $\sigma_\epsilon,\mu_\epsilon$} & $\mu_\epsilon$ (identity) & \parbox[t]{2in}{$( \Phi(u, \mu_2, \sigma_3) - \Phi(l, \mu_2, \sigma_3)) / $ \\ $(\Phi(u, \mu_0, \sigma_0) - \Phi(l, \mu_0, \sigma_0)) $ \\ $\times \phi(x, \mu_0 + \mu_\epsilon, \sigma_2)$, \\ $\sigma_2^2 = \sigma_0^2 + \sigma_\epsilon^2$, \\ $\sigma_3 = \sigma_0 \sigma_\epsilon / \sigma_2$, \\ $\mu_2 = (x - \mu_\epsilon) \sigma_0^2 + \mu_0 \sigma_\epsilon^2$} \\ \Rfunction{hmmMEUnif} & Uniform with measurement error & \Rfunarg{lower, upper, sderr, meanerr} & $l,u,\mu_\epsilon,\sigma_\epsilon$ & $\mu_\epsilon$ (identity) & \parbox[t]{2in}{$(\Phi(x, \mu_\epsilon+l, \sigma_\epsilon) - \Phi(x, \mu_\epsilon+u, \sigma_\epsilon)) / \\ (u - l)$} \\ \hline \end{tabular} \caption{Hidden Markov model distributions in \Rpackage{msm}.} \label{tab:hmm:dists} \end{table} \paragraph{Covariates on hidden Markov model parameters} Most of the outcome distributions can be parameterised by covariates, using a link-transformed linear model. For example, an observation $y_{ij}$ may have distribution $f_1$ conditionally on underlying state 1. The link-transformed parameter $\theta_1$ is a linear function of the covariate vector $x_{ij}$ at the same observation time. \begin{eqnarray*} \label{eq:hmm:covs} y_{ij} | S_{ij} & \sim & f_1 (y | \theta_1, \gamma_1)\\ g(\theta_1) & = & \alpha + \beta^T x_{ij} \end{eqnarray*} Specifically, parameters named as the ``Location'' parameter in Table \ref{tab:hmm:dists} can be modelled in terms of covariates, with the given link function. The \Rfunarg{hcovariates} argument to \Rfunction{msm} specifies the model for covariates on the hidden Markov outcome distributions. This is a list of the same length as the number of underlying states, and the same length as the \Rfunarg{hmodel} list. Each element of the list is a formula, in standard R linear model notation, defining the covariates on the distribution for the corresponding state. If there are no covariates for a certain hidden state, then insert a \texttt{NULL} in the corresponding place in the list. For example, in the three-state normal-outcome example above, suppose that the normal means on states 1 and 2 are parameterised by a single covariate $x$. \[ \mu_1 = \alpha_1 + \beta_1 x_{ij}, \qquad \mu_2 = \alpha_2 + \beta_2 x_{ij}. \] The equivalent call to \Rfunction{msm} would be \begin{Scode} msm( state ~ time, subject=ptnum, data = example.df, qmatrix = rbind( c(0, 0.25, 0), c(0, 0, 0.2), c(0, 0, 0)), hmodel = list (hmmNorm(mean=90, sd=8), hmmNorm(mean=70, sd=8), hmmIdent(-9)), hcovariates = list ( ~ x, ~ x, NULL) ). \end{Scode} \paragraph{Constraints on hidden Markov model parameters} Sometimes it is realistic that parameters are shared between some of the state-specific outcome distributions. For example, the Normally-distributed outcome in the previous example could have a common variance $\sigma^2_1 = \sigma^2_2 = \sigma^2$ between states 1 and 2, but differing means. It would also be realistic for any covariates on the mean to have a common effect $\beta_1 = \beta_2 = \beta$ on the state 1 and 2 outcome distributions. The argument \Rfunarg{hconstraint} to \Rfunction{msm} specifies which hidden Markov model parameters are constrained to be equal. This is a named list. Each element is a vector of constraints on the named hidden Markov model parameter. The vector has length equal to the number of times that class of parameter appears in the whole model. As for the other constraint arguments such as \Rfunarg{qconstraint}, identical values of this vector indicate parameters constrained to be equal. For example, consider the three-state hidden Markov model described above, with normally-distributed outcomes for states 1 and 2. To constrain the outcome variance to be equal for states 1 and 2, and to also constrain the effect of \Robject{x} on the outcome mean to be equal for states 1 and 2, specify \begin{Scode} hconstraint = list(sd = c(1,1), x=c(1,1)) \end{Scode} Parameters of the outcome distributions may also be constrained within specific ranges. If chosen carefully, this may improve identifiability of hidden Markov states. For example to constrain the mean for state 1 to be between 80 and 110, and the mean for state 2 to be between 50 and 80, specify \begin{Scode} hranges = list(mean=list(lower=c(80,50), upper=c(110,80))) \end{Scode} Maximum likelihood estimation is then performed on the appropriate log or logit-transformed scale so that these constraints are satisfied. See the \Rfunction{msm} help page for further details. Note that initial values should be strictly within the ranges, and not on the range boundary. \paragraph{FEV$_1$ after lung transplants} Now we give an example of fitting a hidden Markov model to a real dataset. The data on FEV$_1$ measurements from lung transplant recipients, described in \ref{sec:hmm:example:fev}, are provided with the \Rpackage{msm} package in a dataset called \Robject{fev}. We fit models Models 1 and 2, each with three states and common $Q$ matrix. <<>>= three.q <- rbind(c(0, exp(-6), exp(-9)), c(0, 0, exp(-6)), c(0, 0, 0)) @ The simpler Model 1 is specified as follows. Under this model the FEV$_1$ outcome is Normal with unknown mean and variance, and the mean and variance are different between BOS state 1 and state 2. \Rfunarg{hcovariates} specifies that the mean of the Normal outcome depends linearly on acute events. Specifically, this covariate is an indicator for the occurrence of an acute event within 14 days of the observation, denoted \texttt{acute} in the data. As an initial guess, we suppose the mean FEV$_1$ is 100\% baseline in state 1, and 54\% baseline in state 2, with corresponding standard deviations 16 and 18, and FEV$_1$ observations coinciding with acute events are on average 8\% baseline lower. \Rfunarg{hconstraint} specifies that the acute event effect is equal between state 1 and state 2. Days of death are coded as 999 in the \texttt{fev} outcome variable. <<>>= hmodel1 <- list(hmmNorm(mean=100, sd=16), hmmNorm(mean=54, sd=18), hmmIdent(999)) fev1.msm <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel1, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, NULL), hconstraint = list(acute = c(1,1))) fev1.msm sojourn.msm(fev1.msm) @ Printing the \Rclass{msm} object \Rfunarg{fev1.msm} shows estimates and confidence intervals for the transition intensities and the hidden Markov model parameters. The estimated within-state means of FEV$_1$ are around 98\% and 52\% baseline respectively. From the estimated transition intensities, individuals spend around 1421 days (3.9 years) before getting BOS, after which they live for an average of 1248 days (3.4 years). FEV$_1$ is lower by an average of 8\% baseline within 14 days of acute events. Model 2, where the outcome distribution is a more complex two-level model, is specified as follows. We use the distribution defined by equations \ref{eq:fev:level1}--\ref{eq:fev:level2}. The \Rfunction{hmmMETNorm} constructor defines the truncated normal outcome with an additional normal measurement error. The explicit probability density for this distribution is given in Table \ref{tab:hmm:dists}. Our initial values are 90 and 54 for the means of the within-state distribution of \emph{underlying} FEV$_1$, and 16 and 18 for the standard errors. This time, underlying FEV$_1$ is truncated normal. The truncation limits \Rfunarg{lower} and \Rfunarg{upper} are not estimated. We take an initial measurement error standard deviation of \Rfunarg{sderr=8}. The extra shift \Rfunarg{meanerr} in the measurement error model is fixed to zero and not estimated. The \Rfunarg{hconstraint} specifies that the measurement error variance $\sigma^2_\epsilon$ is equal between responses in states 1 and 2, as is the effect of short-term acute events on the FEV$_1$ response. The convergence of maximum likelihood estimation in this example is particularly sensitive to the optimisation method and options, initial values, the unit of the time variable and whether covariates are centered, probably because the likelihood surface is irregular near to the true maximum. \begin{Scode} hmodel2 <- list(hmmMETNorm(mean=90, sd=16, sderr=8, lower=80, upper=Inf, meanerr=0), hmmMETNorm(mean=54, sd=18, sderr=8, lower=0, upper=80, meanerr=0), hmmIdent(999)) fev2.msm <- msm(fev ~ days, subject=ptnum, data=fev, qmatrix=three.q, deathexact=3, hmodel=hmodel2, hcovariates=list(~acute, ~acute, NULL), hcovinits = list(-8, -8, NULL), hconstraint = list(sderr = c(1,1), acute = c(1,1)), control=list(maxit=10000), center=TRUE) \end{Scode} Under this model the standard deviation of FEV$_1$ measurements caused by measurement error (more realistically, natural short-term fluctuation) is around 9\% baseline. The estimated effect of acute events on FEV$_1$ and sojourn times in the BOS-free state and in BOS before death are similar to Model 1. The following code will create a plot that illustrates a trajectory of declining FEV$_1$ from the first lung transplant recipient in this dataset. The Viterbi algorithm is used to locate the most likely point at which this individual moved from BOS state 1 to BOS state 2, according to the fitted Model 2. This is illustrated by a vertical dotted line. This is the point at which the individual's lung function started to remain consistently below 80\% baseline FEV$_1$. \begin{Scode} keep <- fev$ptnum==1 & fev$fev<999 plot(fev$days[keep], fev$fev[keep], type="l", ylab=expression(paste("% baseline ", FEV[1])), xlab="Days after transplant") vit <- viterbi.msm(fev2.msm)[keep,] (max1 <- max(vit$time[vit$fitted==1])) (min2 <- min(vit$time[vit$fitted==2])) abline(v = mean(max1,min2), lty=2) text(max1 - 500, 50, "STATE 1") text(min2 + 500, 50, "STATE 2") \end{Scode} \includegraphics{figures/fev_viterbi} \paragraph{An alternative way of specifying a misclassification model} This general framework for specifying hidden Markov models can also be used to specify multi-state models with misclassification. A misclassification model is a hidden Markov model with a categorical outcome distribution. So instead of an \Rfunarg{ematrix} argument to \Rfunction{msm}, we can use a \Rfunarg{hmodel} argument with \Rfunction{hmmCat} constructor functions. \Rfunction{hmmCat} takes at least one argument \Rfunarg{prob}, a vector of probabilities of observing outcomes of $1, 2, \ldots, n$ respectively, where $n$ is the length of \Rfunarg{prob}. All outcome probabilities with an initial value of zero are assumed to be fixed at zero. \Rfunarg{prob} is scaled if necessary to sum to one. The model in section \ref{sec:fitting:hmm:misc} specifies that an individual occupying underlying state 1 can be observed as states 2 (and 1), underlying state 2 can be observed as states 1, 2 or 3, and state 3 can be observed as states 2 or 3, and underlying state 4 (death) cannot be misclassified. Initial values of 0.1 are given for the 1-2, 2-1, 2-3 and 3-2 misclassification probabilities. This is equivalent to the model below, specified using a \Rfunarg{hmodel} argument to \Rfunction{msm}. The maximum likelihood estimates should be the same as before (Model 5). \begin{Scode} Qm <- rbind(c(0, 0.148, 0, 0.0171), c(0, 0, 0.202, 0.081), c(0, 0, 0, 0.126), c(0, 0, 0, 0)) cavmisc.msm <- msm(state ~ years, subject = PTNUM, data = cav, hmodel = list (hmmCat(c(0.9, 0.1, 0, 0)), hmmCat(c(0.1, 0.8, 0.1, 0)), hmmCat(c(0, 0.1, 0.9, 0)), hmmIdent(4)), qmatrix = Qm, obstrue=firstobs, deathexact = 4) cavmisc.msm \end{Scode} \subsubsection{Hidden Markov models with multivariate outcomes} Since version 1.5.2, \Rpackage{msm} can fit models where at each time point, there are multiple outcomes generated conditionally on a single hidden Markov state. The outcomes must be independent conditionally on the hidden state, but they may be generated from the same or different univariate distributions. See \Rfunction{help(hmmMV)} for detailed documentation and a worked example. \subsubsection{Defining a new hidden Markov model distribution} Suppose the hidden Markov model outcome distributions supplied with \Rpackage{msm} (Table \ref{tab:hmm:dists}) are insufficient. We want to define our own univariate distribution, called \Rfunction{hmmNewDist}, taking two parameters \Robject{location} and \Robject{scale}. Download the source package, for example \texttt{msm-0.7.2.tar.gz} for version 0.7.2, from CRAN and edit the files in there, as follows. \begin{enumerate} \item Add an element to \Robject{.msm.HMODELPARS} in the file \texttt{R/constants.R}, naming the parameters of the distribution. For example \begin{Scode} newdist = c('location', 'scale') \end{Scode} \item Add a corresponding element to the C variable \texttt{HMODELS} in the file \texttt{src/lik.c}. This MUST be in the same position as in the \Robject{.msm.HMODELPARS} list. For example, \begin{Scode} hmmfn HMODELS[] = { ..., hmmNewDist };. \end{Scode} \item The new distribution is allowed to have one parameter which can be modelled in terms of covariates. Add the name of this parameter to the named vector \Robject{.msm.LOCPARS} in \texttt{R/constants.R}. For example \texttt{newdist = 'location'}. Specify \texttt{newdist = NA} if there is no such parameter. \item Supposed we have specified a parameter with a non-standard name, that is, one which doesn't already appear in \Robject{.msm.HMODELPARS}. Standard names include, for example, \texttt{'mean'}, \texttt{'sd'}, \texttt{'shape'} or \texttt{'scale'}. Then we should add the allowed range of the parameter to \Robject{.msm.PARRANGES}. In this example, we add \texttt{meanpars = c(-Inf, Inf)} to \Robject{.msm.PARRANGES}. This ensures that the optimisation to estimate the parameter takes place on a suitable scale, for example, a log scale for a parameter constrained to be positive. If the parameter should be fixed during maximum likelihood estimation (for example, the denominator of a binomial distribution) then add its name to \Robject{.msm.AUXPARS}. \item Add an R constructor function for the distribution to \texttt{R/hmm-dists.R}. For a simple univariate distribution, this is of the form \begin{Scode} hmmNewDist <- function(location, scale) { hmmDIST(label = "newdist", link = "identity", r = function(n) rnewdist(n, location, scale), match.call()) } \end{Scode} \begin{itemize} \item The \texttt{'label'} must be the same as the name you supplied for the new element of \Robject{.msm.HMODELPARS} \item \texttt{link} is the link function for modelling the location parameter of the distribution as a linear function of covariates. This should be the quoted name of an R function. A log link is \texttt{'log'} and a logit link is \texttt{'qlogis'}. If using a new link function other than \texttt{'identity'}, \texttt{'log'}, or \texttt{'qlogis'}, you should add its name to the vector \Robject{.msm.LINKFNS} in \texttt{R/constants.R}, and add the name of the corresponding inverse link to \Robject{.msm.INVLINK}. You should also add the names of these functions to the C array \texttt{LINKFNS} in \texttt{src/lik.c}, and write the functions if they do not already exist. \item \texttt{r} is an R function, of the above format, returning a vector of \texttt{n} random values from the distribution. You should write this if it doesn't already exist. \end{itemize} \item Add the name of the new constructor function to the NAMESPACE in the top-level directory of the source package. \item Write a C function to compute the probability density of the distribution, and put this in \texttt{src/hmm.c}, with a declaration in \texttt{src/hmm.h}. This must be of the form \begin{Scode} double hmmNewDist(double x, double *pars) \end{Scode} where \texttt{*pars} is a vector of the parameters of the distribution, and the density is evaluated at \texttt{x}. \item (Optionally) Write a C function to compute the derivatives of the probability density with respect to the parameters, and put this in \texttt{src/hmmderiv.c}, with a declaration in \texttt{src/hmm.h}. Then add the model to \texttt{DHMODELS} in \texttt{lik.c} (in the same position as in \texttt{HMODELS}) and \texttt{.msm.HMODELS.DERIV} in \texttt{R/constants.R}. This will generally double the speed of maximum likelihood estimation, but analytic derivatives will not be available for all distributions. \item Update the documentation (\texttt{man/hmm-dists.Rd}) and the distribution table in\\ \texttt{inst/doc/msm-manual.Rnw}) if you like. \item Recompile the package (see the ``Writing R Extensions'' manual) \end{enumerate} Your new distribution will be available to use in the \Rfunarg{hmodel} argument to \Rfunction{msm}, as, for example \begin{Scode} hmodel = list(..., hmmNewDist(location = 0, scale = 1), ...) \end{Scode} If your distribution may be of interest to others, ask me (\texttt{chris.jackson@mrc-bsu.cam.ac.uk}) to include it in a future release. \clearpage \section{\Rpackage{msm} reference guide} The R help page for \Rfunction{msm} gives details of all the allowed arguments and options to the \Rfunction{msm} function. To view this online in R, type: <>= help(msm) @ Similarly all the other functions in the package have help pages, which should always be consulted in case of doubt about how to call them. The web-browser based help interface may often be convenient - type <>= help.start() @ and navigate to \textsf{Packages} $\ldots$ \textsf{msm}, which brings up a list of all the functions in the package with links to their documentation, and a link to this manual in PDF format. \appendix \section{Changes in the msm package} For a detailed list of the changes in recent versions of \Rpackage{msm}, see the \texttt{NEWS} file in the top-level directory of the installed package. The \texttt{Changelog} file in the top-level directory of the source package contains more technical detail about these changes. Development versions of \Rpackage{msm} are to be found on R-Forge, \url{http://msm.r-forge.r-project.org/}. These are often more recent than the version released on CRAN, so if you think you have found a bug, then please check first to see whether it has been fixed on the R-Forge version. \section{Get in touch} If you use \Rpackage{msm} in your work, whatever your field of application, please let me know, for my own interest! Suggestions for improvement are welcome. \clearpage \bibliography{msm} \end{document} msm/vignettes/Sweave-local.sty0000755000176200001440000000102512250051204016131 0ustar liggesusers\RequirePackage[T1]{fontenc} %%Check if we are compiling under latex or pdflatex \ifx\pdftexversion\undefined \RequirePackage[dvips]{graphicx} \else \RequirePackage[pdftex]{graphicx} \RequirePackage{epstopdf} \fi \RequirePackage{ae,fancyvrb} \IfFileExists{upquote.sty}{\RequirePackage{upquote}}{} \setkeys{Gin}{width=0.8\textwidth} \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontshape=sl} \newenvironment{Schunk}{}{} msm/vignettes/msm.bib0000755000176200001440000004613112250051214014330 0ustar liggesusers@Book{biolog:seq, author = {Durbin, R. and Eddy, S. and Krogh, A. and Mitchison, G.}, ALTeditor = {}, title = {{Biological Sequence Analysis: Probabilistic Models of Proteins and Nucleic Acids}}, publisher = {Cambridge University Press}, year = {1998}, OPTkey = {}, OPTvolume = {}, OPTnumber = {}, OPTseries = {}, OPTaddress = {}, OPTedition = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Book{cox:miller, author = {Cox, D. R. and Miller, H. D.}, ALTeditor = {}, title = {{The Theory of Stochastic Processes}}, publisher = {Chapman and Hall}, year = {1965}, OPTkey = {}, OPTvolume = {}, OPTnumber = {}, OPTseries = {}, address = {London}, OPTedition = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{klotz:est, author = {Klotz, J. H. and Sharples, L. D.}, title = {Estimation for a {M}arkov heart transplant model}, journal = {The Statistician}, year = 1994, volume = 43, number = 3, pages = {431--436} } @Article{sharp:gibbs, author = {Sharples, L. D.}, title = {Use of the {G}ibbs Sampler to estimate transition rates between grades of coronary disease following cardiac transplantation}, journal = {Statistics in Medicine}, year = 1993, volume = 12, pages = {1155--1169} } @Article{kay:mark, author = {Kay,R.}, title = {A {M}arkov model for analysing cancer markers and disease states in survival studies}, journal = {Biometrics}, year = 1986, volume = 42, pages = {855--865} } @Article{gruger:valid, author = {Gr\"uger, J. and Kay, R. and Schumacher, M.}, title = {The validity of inferences based on incomplete observations in disease state models}, journal = {Biometrics}, year = {1991}, OPTkey = {}, volume = {47}, OPTnumber = {}, pages = {595--605}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{long1, author = {Longini, I. M. and Clark, W. S. and Byers, R. H. and Ward, J. W. and Darrow, W. W. and Lemp, G. F. and Hethcote, H. W.}, title = {Statistical analysis of the stages of {HIV} infection using a {M}arkov model}, journal = {Statistics in Medicine}, year = {1989}, OPTkey = {}, volume = {8}, OPTnumber = {}, pages = {851--843}, OPTmonth = {}, OPTnote = {}, annote = {Original HIV Markov paper, four states} } @Article{long2, author = {Longini, I. M. and Clark, W. S. and Gardner, L. I. and Brundage, J. F.}, title = {The dynamics of {CD4}+ {T}-lymphocyte decline in {HIV}-infected individuals: a {M}arkov modelling approach}, journal = {Journal of Acquired Immune Deficiency Syndromes}, year = {1991}, OPTkey = {}, volume = {4}, OPTnumber = {4}, pages = {1141--1147}, OPTmonth = {}, OPTnote = {}, annote = {original paper defining CD4 ranges as disease states} } @Article{sattlong, author = {Satten, G. A. and Longini, I. M.}, title = {Markov chains with measurement error: {E}stimating the `true' course of a marker of the progression of human immunodeficiency virus disease}, journal = {Applied Statistics - Journal of the Royal Statistical Society Series C}, year = {1996}, OPTkey = {}, volume = {45}, number = {3}, pages = {275--295}, month = {}, OPTnote = {}, OPTannote = {} } @Article{retino2, author = {Marshall, G. and Jones, R. H.}, title = {Multi-state {M}arkov models and diabetic retinopathy}, journal = {Statistics in Medicine}, year = {1995}, OPTkey = {}, volume = {14}, OPTnumber = {}, OPTpages = {}, OPTmonth = {}, OPTnote = {}, annote = {This is the paper that includes covariates in multistate models.} } @Article{duffy95, author = {Duffy, S. W. and Chen, H. H.}, title = {Estimation of mean sojourn time in breast cancer screening using a {M}arkov chain model of entry to and exit from preclinical detectable phase}, journal = {Statistics in Medicine}, year = {1995}, OPTkey = {}, volume = {14}, OPTnumber = {}, pages = {1531--1543}, OPTmonth = {}, OPTnote = {}, annote = {3 states, no death or recovery. Fitted with NLIN} } @Article{duffy96, author = {Chen, H. H. and Duffy, S. W. and Tabar, L.}, title = {A {M}arkov chain method to estimate the tumour progression rate from preclinical to clinical phase, sensitivity and positive predictive value for mammography in breast cancer screening}, journal = {The Statistician}, year = {1996}, OPTkey = {}, volume = {45}, number = {3}, pages = {307--317}, OPTmonth = {}, OPTnote = {}, annote = {Measurement error introduction} } @Article{duffy:mover, author = {Chen, H. H. and Duffy, S. W. and Tabar, L.}, title = {A mover-stayer mixture of {M}arkov chain models for the assessment of dedifferentiation and tumour progression in breast cancer}, journal = {Journal of Applied Statistics}, year = {1997}, OPTkey = {}, volume = {24}, number = {3}, pages = {265--278}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @InCollection{kirby:spiegelhalter, author = {Kirby, A. J. and Spiegelhalter, D. J.}, title = {Statistical modelling for the precursors of cervical cancer}, booktitle = {Case Studies in Biometry}, OPTcrossref = {}, OPTkey = {}, OPTpages = {}, publisher = {Wiley}, year = {1994}, OPTeditor = {}, OPTvolume = {}, OPTnumber = {}, OPTseries = {}, OPTtype = {}, OPTchapter = {}, address = {New York}, OPTedition = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{ander:proth, author = {Andersen, P. K. and Hansen, L. S. and Keiding, N.}, title = {Assessing the influence of reversible disease indicators on survival}, journal = {Statistics in Medicine}, year = {1991}, OPTkey = {}, volume = {10}, OPTnumber = {}, pages = {1061--1067}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{kalb:agg, author = {Kalbfleisch, J. D. and Lawless, J. F. and Vollmer, W. M.}, title = {Estimation in {M}arkov models from aggregate data}, journal = {Biometrics}, year = {1983}, OPTkey = {}, volume = {39}, OPTnumber = {}, pages = {907--919}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{klein:marker, author = {Klein, J. P. and Klotz, J. H. and Grever, M. R.}, title = {A biological marker model for predicting disease transitions}, journal = {Biometrics}, year = {1984}, OPTkey = {}, volume = {40}, OPTnumber = {}, pages = {927--936}, OPTmonth = {}, OPTnote = {}, annote = {Only transitions 1->2->3, with covariates included as in a Cox model} } @Article{gail, author = {Gail, M. H.}, title = {Evaluating serial cancer marker studies in patients at risk of recurrent disease}, journal = {Biometrics}, year = {1981}, OPTkey = {}, volume = {37}, OPTnumber = {}, pages = {67--78}, OPTmonth = {}, OPTnote = {}, annote = {Interpolation to reduce to common monitoring times} } @Article{gentlaw, author = {Gentleman, R. C. and Lawless, J. F. and Lindsey, J. C. and Yan, P.}, title = {Multi-state {M}arkov models for analysing incomplete disease history data with illustrations for {HIV} disease}, journal = {Statistics in Medicine}, year = {1994}, key = {}, volume = {13}, number = {3}, pages = {805--821}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{rich, author = {Guihenneuc-Jouyaux, C. and Richardson, S. and Longini, I. M.}, title = {Modelling markers of disease progression by a hidden {M}arkov process: Application to characterising {CD4} cell decline}, journal = {Biometrics}, year = {2000}, OPTkey = {}, volume = {56}, OPTnumber = {}, pages = {733--741}, OPTmonth = {September}, OPTnote = {}, OPTannote = {} } @Book{andersen, author = {Andersen, P. K. and Borgan, O. and Gill, R. D. and Keiding, N.}, ALTeditor = {}, title = {Statistical Models based on Counting Processes}, publisher = {Springer}, year = {1993}, OPTkey = {}, OPTvolume = {}, OPTnumber = {}, OPTseries = {}, address = {New York}, OPTedition = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Book{macdonald:zucchini, author = {Macdonald, I. L. and Zucchini, W.}, ALTeditor = {}, title = {Hidden Markov and Other Models for Discrete-Valued Time Series}, publisher = {Chapman and Hall}, year = {1997}, OPTkey = {}, OPTvolume = {}, OPTnumber = {}, OPTseries = {}, address = {London}, OPTedition = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Book{guttorp, author = {Guttorp, P.}, ALTeditor = {}, title = {Stochastic Modeling of Scientific Data}, publisher = {Chapman and Hall}, year = {1995}, OPTkey = {}, OPTvolume = {}, OPTnumber = {}, OPTseries = {}, address = {London}, OPTedition = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{juang:rabiner, author = {Juang, B. H. and Rabiner, L. R.}, title = {Hidden {M}arkov models for speech recognition}, journal = {Technometrics}, year = {1991}, OPTkey = {}, volume = {33}, OPTnumber = {}, pages = {251--272}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{baum:petrie66, author = {Baum, L. E. and Petrie, T.}, title = {Statistical inference for probabilistic functions of finite state {M}arkov chains}, journal = {Annals of Mathematical Statistics}, year = {1966}, OPTkey = {}, volume = {37}, OPTnumber = {}, pages = {1554--1563}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{baum:petrie70, author = {Baum, L. E. and Petrie, T. and Soules, G. and Weiss, N.}, title = {A maximisation technique occurring in the statistical analysis of probabilistic functions of {M}arkov chains}, journal = {Annals of Mathematical Statistics}, year = {1970}, OPTkey = {}, volume = {41}, OPTnumber = {}, pages = {164--171}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{rabiner, author = {Rabiner, L. R.}, title = {A tutorial on hidden {M}arkov models and selected applications in speech recognition}, journal = {Proceedings of the {IEEE}}, year = {1989}, OPTkey = {}, volume = {77}, OPTnumber = {}, pages = {257--286}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Book{rabiner:juang, author = {Rabiner, L. R. and Juang, B. H.}, ALTeditor = {}, title = {Fundamentals of speech recognition}, publisher = {Prentice-Hall}, year = {1993}, OPTkey = {}, OPTvolume = {}, OPTnumber = {}, OPTseries = {}, OPTaddress = {}, OPTedition = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{albert99, author = {Albert, P. S.}, title = {A mover-stayer model for longitudinal marker data}, journal = {Biometrics}, year = {1999}, OPTkey = {}, volume = {55}, number = {4}, pages = {1252--1257}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{albert:wac, author = {Albert, P. S. and Waclawiw, M. A.}, title = {A two-state {M}arkov chain for heterogeneous transitional data: A quasi-likelihood approach}, journal = {Statistics in Medicine}, year = {1998}, OPTkey = {}, volume = {17}, number = {13}, pages = {1481--1493}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{albert94, author = {Albert, P. S.}, title = {A {Ma}rkov model for sequences of ordinal data from a relapsing-remitting disease}, journal = {Biometrics}, year = {1994}, OPTkey = {}, volume = {50}, number = {1}, pages = {51--60}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{viterbi, author = {Viterbi, J.}, title = {Error bounds for convolutional codes and an asymptotically optimal decoding algorithm}, journal = {IEEE Transactions on Information Theory}, year = {1967}, OPTkey = {}, volume = {13}, OPTnumber = {}, pages = {260--269}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{albert:2000, author = {Albert, P. S.}, title = {A transitional model for longitudinal binary data subject to nonignorable missing data}, journal = {Biometrics}, year = {2000}, OPTkey = {}, volume = {56}, number = {2}, pages = {602--608}, month = {June}, OPTnote = {}, OPTannote = {} } @Article{aalen:deangelis, author = {Aalen, O. O. and Farewell, V. T. and DeAngelis, D. and Day, N. E. and Gill, O. N.}, title = {A {M}arkov model for {HIV} disease progression including the effect of {HIV} diagnosis and treatment: Application to {AIDS} prediction}, journal = {Statistics in Medicine}, year = {1997}, OPTkey = {}, volume = {16}, number = {19}, pages = {2191--2210}, OPTmonth = {October}, OPTnote = {}, OPTannote = {} } @Article{destavola, author = {de Stavola, B. L.}, title = {Testing departures from homogeneity in multistate {M}arkov processes}, journal = {Applied Statistics - Journal of the Royal Statistical Society, Series C}, year = {1988}, OPTkey = {}, volume = {37}, OPTnumber = {}, pages = {242--250}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{andersen88, author = {Andersen, P. K.}, title = {Multistate models in survival analysis: a study of nephropathy and mortality in diabetes}, journal = {Statistics in Medicine}, year = {1988}, OPTkey = {}, volume = {7}, number = {6}, pages = {661--670}, OPTmonth = {June}, OPTnote = {}, OPTannote = {} } @Article{leroux:consist, author = {Leroux, B. G.}, title = {Maximum-likelihood estimation for hidden {M}arkov models}, journal = {Stochastic Processes and their Applications}, year = {1992}, OPTkey = {}, volume = {40}, OPTnumber = {}, pages = {127--143}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{bickel:ritov:ryden, author = {Bickel, P. J. and Ritov, Y. and Ryd\'en, T.}, title = {Asymptotic normality of the maximum likelihood estimator for general hidden {M}arkov models}, journal = {Annals of Statistics}, year = {1998}, OPTkey = {}, volume = {26}, OPTnumber = {}, pages = {1614--1635}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{perez, author = {P\'erez-Oc\'on, R. and Ruiz-Castro, J. E. and G\'amiz-P\'erez, M.Luz}, title = {Non-homogeneous {M}arkov models in the analysis of survival after breast cancer}, journal = {Applied Statistics - Journal of the Royal Statistical Society, Series C}, year = {2001}, OPTkey = {}, volume = {50}, number = {1}, pages = {111--124}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @ARTICLE{bureau:hughes:shiboski:00, author = {Bureau, A. and Hughes, J. P. and Shiboski, S. C.}, title = {An {S-Plus} implementation of hidden {M}arkov models in continuous time}, journal = {Journal of Computational and Graphical Statistics}, year = {2000}, volume = {9}, pages = {621--632}, abstract = {} } @Article{oehlert, author = {Oehlert, G. W.}, title = {A note on the delta method}, journal = {American Statistician}, year = 1992, volume = 46, number = 1, month = {February} } @Book{lindsey:rm, author = {Lindsey, J. K.}, ALTeditor = {}, title = {Models for Repeated Measurements}, publisher = {Oxford University Press}, year = {1999}, OPTkey = {}, OPTvolume = {}, OPTnumber = {}, series = {Oxford Statistical Science Series}, OPTaddress = {}, edition = {second}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{jackson:sharples:2002, author = {Jackson, C. H. and Sharples,L. D.}, title = {Hidden {M}arkov models for the onset and progression of bronchiolitis obliterans syndrome in lung transplant recipients}, journal = {Statistics in Medicine}, year = {2002}, OPTkey = {}, volume = {21}, OPTnumber = {1}, pages = {113--128}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{jackson:sharples:2003, author = {Jackson, C. H. and Sharples, L. D. and Thompson, S. G. and Duffy, S. W. and Couto, E.}, title = {Multistate {M}arkov models for disease progression with classification error}, journal = {Journal of the Royal Statistical Society, Series D - The Statistician}, year = {2003}, OPTkey = {}, volume = {52}, number = {2}, pages = {193--209}, month = {July}, note = {}, OPTannote = {} } @PhdThesis{my:phd, author = {Jackson, C. H.}, title = {Statistical models for the latent progression of chronic diseases using serial biomarkers}, school = {University of Cambridge}, year = {2002}, OPTkey = {}, OPTtype = {}, OPTaddress = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{kalbfleisch:lawless, author = {Kalbfleisch, J.D. and Lawless, J.F.}, title = {The analysis of panel data under a {M}arkov assumption}, journal = {Journal of the American Statistical Association}, year = {1985}, OPTkey = {}, volume = {80}, number = {392}, pages = {863--871}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{my:cav, author = {Sharples, L.D. and Jackson, C.H. and Parameshwar, J. and Wallwork, J. and Large, S.R.}, title = {Diagnostic accuracy of coronary angiography and risk factors for post-heart-transplant cardiac allograft vasculopathy}, journal = {Transplantation}, year = {2003}, OPTkey = {}, volume = {76}, number = {4}, pages = {679--682}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{matrixexp, author = {Moler , C. and van Loan, C.}, title = {Nineteen Dubious Ways to Compute the Exponential of a Matrix, Twenty-Five Years Later}, journal = {SIAM Review}, year = {2003}, OPTkey = {}, volume = {45}, number = {1}, pages = {3--49}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{ahf, author = {Aguirre-Hernandez, R. and Farewell, V.}, title = {{A Pearson-type goodness-of-fit test for stationary and time-continuous Markov regression models}}, journal = {Statistics in Medicine}, year = {2002}, OPTkey = {}, volume = {21}, OPTnumber = {}, pages = {1899-1911}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{titman:sharples, author = {Titman, A. and Sharples, L. D.}, title = {{A general goodness-of-fit test for Markov and hidden Markov models}}, journal = {Statistics in Medicine}, year = {2008}, OPTkey = {}, volume = {27}, number = {12}, pages = {2177--95}, OPTmonth = {}, OPTannote = {} } @PhdThesis{titman:phd, author = {Titman, A.}, title = {Model diagnostics in multi-state models of biological systems}, school = {University of Cambridge}, year = {2008}, OPTkey = {}, OPTtype = {}, OPTaddress = {}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @article{titman:asympnull, title={Computation of the asymptotic null distribution of goodness-of-fit tests for multi-state models}, author={Titman, A.C.}, journal={Lifetime Data Analysis}, volume={15}, number={4}, pages={519--533}, year={2009}, } @Article{putter:mstate, author = {Putter, H. and Fiocco, M. and Geskus, R. B.}, title = {{Tutorial in biostatistics: competing risks and multi-state models}}, journal = {Statistics in Medicine}, year = {2007}, OPTkey = {}, volume = {26}, OPTnumber = {}, pages = {2389--2430}, OPTmonth = {}, OPTnote = {}, OPTannote = {} } @Article{sweeting:inform:msm, author = {Sweeting, M. J. and Farewell, V. and De Angelis, D.}, title = {{Multi-State Markov Models for Disease Progression in the Presence of Informative Examination Times: an Application to Hepatitis C}}, journal = {Statistics in Medicine}, year = {2010}, OPTkey = {}, volume = {29}, number = {11}, pages = {1161-1174}, OPTmonth = {}, OPTannote = {} } msm/MD50000644000176200001440000002500012774720660011366 0ustar liggesusers23410405649b503cc61b32be6149e9c5 *ChangeLog e10ba2db3fdf321a4050f39ddcd4965a *DESCRIPTION 03d50885cd1792f686cd0ddcfaf244a4 *NAMESPACE c3e8bb90abd277f56413e4c508a6833c *R/boot.R 8b7f8323654de2c622caf77cc6e68151 *R/constants.R f5e33bf85c8a1568221f12280409a6e8 *R/draic.R 40288b7bca9c27eb11c27b0044e86fe9 *R/hmm-dists.R e93c2c209a43a319f921459736dfc8f3 *R/hmm.R aee88a4241d904699e42a23ca115a60a *R/msm.R 7c4fa51638caa9fd7819e73e206b60f2 *R/mstate.R a0d0b4080044ca84d7555a56c6a3bd2e *R/olddata.R fc42a0fca95c8674f23b79337ee55e8b *R/optim.R f16122da7e4b28ec6f0fcd088fde0ae3 *R/outputs.R 69a32cd83f3dbdab556bba9b21d9f4dd *R/pearson.R 92eab74d4d79c795257ca76cb676149a *R/phase.R c3f3898979b11b85f088e3f4c9c11780 *R/simul.R 58755f6bc0203bf594ddcb5300eeb603 *R/utils.R 2d0aefedc2ea8e9373eb8cc84ec50f3c *build/vignette.rds 2e83efb31c764734aa67ed4e686c7fc1 *data/bos3.rda 21080bd2b47eb8885142701c92c14c73 *data/bos4.rda 35ea8ffa25baf02ee38f4ccb5fdc0446 *data/msmdata.rda f8474ef9e0f949bccbb4e244a4ac472c *inst/CITATION c80440569dfa68d5899f698843f8c56d *inst/NEWS 0b1759f978535dee8a6afd274ed502cc *inst/doc/msm-manual.R 0023a6417f7b96b1d02d92286d0f4410 *inst/doc/msm-manual.pdf 5532de7924656013378440947427a286 *man/2phase.Rd 518a82b78d7edb57ea15f91a0d5d914b *man/MatrixExp.Rd c39fbb4debea235b9582d01b68522d6e *man/aneur.Rd 54fddc17c3786a5787295a0a23c1bc4c *man/boot.msm.Rd bf137a1a550f7ac0ca4bf0fa914ef282 *man/bos.Rd 684bf479f28350bc315456e67078c8b6 *man/cav.Rd cb79a30165424c4185f77aa048ba84c9 *man/cmodel.object.Rd 8cecf9f6ad73f40d0ebd63f5db8987e4 *man/coef.msm.Rd 575e59560acdc438de7cd9bf68859180 *man/crudeinits.msm.Rd 8af5f22e6e8ef3239098d8a1fb58e0c3 *man/deltamethod.Rd 641536a1f57782cc2ef8e4189e1c9ca0 *man/draic.msm.Rd d92890b198df7df2524be56892e98d4e *man/ecmodel.object.Rd 39ba8581aa3759d26b46c8fef59c5247 *man/efpt.msm.Rd d108481820830a65ae93ed540ba7d2c0 *man/ematrix.msm.Rd 9944f8cbf7fc7b23859f11bf96a3142c *man/emodel.object.Rd ad01dc753187f7e9836e5461df1cd7a0 *man/fev.Rd c7d808d38d3fd0724aa70a4a2d9820ea *man/hazard.msm.Rd 80added92f36aa32da2d7fbb682ac9a2 *man/hmm-dists.Rd 231c7f8b91d5bb99fab471bcacd9a77a *man/hmmMV.Rd 3e21a988b19ef3c8e757d85c281c4dba *man/hmodel.object.Rd c1709e080e8251957047bb0b3c4ead8e *man/logLik.msm.Rd 7674dab997e73c744d34637a20500a62 *man/lrtest.msm.Rd 35b371252349975ce086ce85277ebbe8 *man/medists.Rd 8eafefa8f9c9d37041f0dfcb8a9a726d *man/model.frame.msm.Rd 05c9177a88543a6e452aac3ec39d6dd3 *man/msm.Rd 883ea5ae45736e561d3887cec651d4e5 *man/msm.form.qoutput.Rd e5ac01b9806653ecc1ffd733ea330916 *man/msm.object.Rd 97f89034e054247b7458d3241b859441 *man/msm2Surv.Rd d9f40e76e98dad52c17d3cc6f7bf2589 *man/odds.msm.Rd b5f0d003ab82d673c7b8423e03bdcdbf *man/paramdata.object.Rd 4aed625ad858804f6264c5bb71d3cc18 *man/pearson.msm.Rd 61c7a557593508adf8531e8f2436106d *man/pexp.Rd e28d9f3150505961071275fd7122feaf *man/phasemeans.msm.Rd 5dbea8e868f943e06e97699438da0c9a *man/plot.msm.Rd 6379a03198d665ca39b64291e0687547 *man/plot.prevalence.msm.Rd f1ec92467ce98470294d0d894f871379 *man/plot.survfit.msm.Rd 9002c80c8c56fe6e4eb7be04f9cdd2d5 *man/plotprog.msm.Rd 265c8748e30a39cc9bd6d5959b60a4a3 *man/pmatrix.msm.Rd 023a20a802ef324b83ef5fbc9f1ee115 *man/pmatrix.piecewise.msm.Rd 711bec59674e13629e212c2eb809fd7f *man/pnext.msm.Rd 643594155a70189c5b1073cebd7a3318 *man/ppass.msm.Rd a052d370e5434c7a9b8a5450e925b28c *man/prevalence.msm.Rd 3ef2bcca419edc4ad8a66f9a6fdf79df *man/print.msm.Rd dec4bb785a5bec882c1de325799becb0 *man/printold.msm.Rd 198a9717e5c86131c445c6a0f9edbe6a *man/psor.Rd c4b581aeca5b8dc0dab5e0429524ea9f *man/qcmodel.object.Rd c5e4603b3dd9fb236401842107c28733 *man/qgeneric.Rd 5e54bfe5cd967b06ae414f5da052630f *man/qmatrix.msm.Rd 06f71db82799f70165c6934f36128e52 *man/qmodel.object.Rd 0c6a14f2048e4fe657f4783dd2cd8c25 *man/qratio.msm.Rd 2eb16a4f436fc56840b9d2c0d22b5f73 *man/recreate.olddata.Rd 5ec6b1d19e5c57ba5df03ba24a01af24 *man/scoreresid.msm.Rd 0f946baaeb361ae656073caa1f51ad6d *man/sim.msm.Rd 9573f3ac73dfb088d42cfa1d7957d50d *man/simfitted.msm.Rd 49effa9c3fc798b12bef0bb5a8f57101 *man/simmulti.msm.Rd 0f94da6c01de61b9d1f6234d4b12db65 *man/sojourn.msm.Rd f9578a0bc47c44fbaf45d5213fde69ce *man/statetable.msm.Rd 237d677ff187a3b23455bda36ed6ae71 *man/summary.msm.Rd c0175efc556d13db03ee3d3a61739784 *man/surface.msm.Rd 5441acdc455c634adb94bfcd5023f399 *man/tnorm.Rd 200203598d23f2c174ddacf94ed22bdf *man/totlos.msm.Rd ba71e20c9fa56b3e1f4c571c613c65eb *man/transient.msm.Rd b8c573b797c66312ba46fa37c01e88c6 *man/viterbi.msm.Rd 619d13ce6900fca2139e2139408d39ad *src/Makevars 2020d37aefd54da007f8eedc9c958fe0 *src/analyticp.c a75b5dc8161768aa323eb071bcbaee57 *src/hmm.c e4a9fe89d526a0892e18cec78c422faa *src/hmm.h bb7bac5595e06b42ebc854645da8565b *src/hmmderiv.c 89ec7d12afb86787c60b14283381e650 *src/lik.c dfab432a8cbcfe876ffa0cc8ebeab705 *src/msm.h 387527989c4743003456924f96baea67 *src/pijt.c 7a2c53c3ce4c4dd37a62ef4dfcc35ce3 *tests/test_base.R 2ce526a6ed7c0e9fd4e9c5cdb3886111 *tests/testthat/helper.r 2c29e599c4974ef47222a7f154b47a54 *tests/testthat/test_analyticp.r 04f8c782394158413e836b845d4479a2 *tests/testthat/test_datasumm.r d0d0d949325c3085fe5171bfc216740b *tests/testthat/test_deriv.r 85475fa6346af2bc9e432ac43a857ef1 *tests/testthat/test_models.r 6b81a41d2360192710a56341478a6531 *tests/testthat/test_models_hmm.r d8570e3a5ab2f90bcebfbf81b27c513c *tests/testthat/test_models_hmmmulti.r c2a7b1691ea26225315a8fae07934218 *tests/testthat/test_models_misc.r b65dd4edcec804d3b9c7a4954bfc1244 *tests/testthat/test_utils.r 8206c9091e718652d132378ade48f125 *vignettes/Sweave-local.sty e0052e8fc1fae86b46fd0aba280c5692 *vignettes/figures/dags/p2q1.odg 6f316449798c364e529b327f94f3e28f *vignettes/figures/dags/p2q1.pdf b619de360357790509173da7871d1e30 *vignettes/figures/dags/p2q1.ps cd238727969774b0647a895c0211494f *vignettes/figures/dags/p2q12.odg 99d920032a621204386887c3633714b3 *vignettes/figures/dags/p2q12.pdf f799a7f881cddb15a1fac1d81e7df27f *vignettes/figures/dags/p2q12.ps eae87a29049543ec1a3ec2801ef3eae3 *vignettes/figures/dags/p3q12.odg a66ba5ec09755d664674a71e263d1175 *vignettes/figures/dags/p3q12.pdf 9cd31ffbe3e36dc1b5dad47016184d33 *vignettes/figures/dags/p3q12.ps 6404bd1b7d0408c1b1ec45551000f43e *vignettes/figures/dags/p3q124.odg a4d012a17281f0ccedd3467b9cd470ed *vignettes/figures/dags/p3q124.pdf 45a39084be266b6bed4baa238a6eabe2 *vignettes/figures/dags/p3q124.ps f2159d3a9aa130e284abd09ff480bab4 *vignettes/figures/dags/p3q1246.odg b73b4e87467382e9ff339027847e9325 *vignettes/figures/dags/p3q1246.pdf 52ba7ff2130a5cdac7d86f3801306e62 *vignettes/figures/dags/p3q1246.ps f5ea2548e172d6d93ef7bd3cdbbeb7d7 *vignettes/figures/dags/p3q135.odg f0f7efaae9b19f153bd6bb6f08b2dbd1 *vignettes/figures/dags/p3q135.pdf 10a1c797a5fded74a4ee6d4d4e562a37 *vignettes/figures/dags/p3q135.ps fba3e0895db0bd7f169a890ad03287b6 *vignettes/figures/dags/p3q14.odg 50dee61bda0c6b1d8514fda04f64e9e2 *vignettes/figures/dags/p3q14.pdf 6aca4260776d07c638ad47531c45612d *vignettes/figures/dags/p3q14.ps 240b6e76d6d8f46eb940fb3a37133849 *vignettes/figures/dags/p3q16.odg e1e57ad78e297d74968968bc77cff8fa *vignettes/figures/dags/p3q16.pdf 1cb3685cfb34eab51471dfe6e5aad7af *vignettes/figures/dags/p3q16.ps 58e91c96d35338e07a026d0c63ea2dea *vignettes/figures/dags/p4q13569.odg 93d11351873b96458bd32af02ee81b98 *vignettes/figures/dags/p4q13569.pdf d831a5d6e56970a053ae7754e177c2af *vignettes/figures/dags/p4q13569.ps 39afd3f1bee833a8cbb491014a844386 *vignettes/figures/dags/p4q159.odg 7e8e8019849d1d5b0618206da5b62138 *vignettes/figures/dags/p4q159.pdf 178402d8cc4b43275dfd9e9d54c4b432 *vignettes/figures/dags/p4q159.ps 8310504068e4a60514cdc55155f2089e *vignettes/figures/dags/p5q1_4_6_8_11_12_16.odg f56ba00423a56c860f50fd744102b66b *vignettes/figures/dags/p5q1_4_6_8_11_12_16.pdf 51382032d16a08f786b944a57a93d826 *vignettes/figures/dags/p5q1_4_6_8_11_12_16.ps 79269e8048c339d5b68b4d04f77502a6 *vignettes/figures/dags/p5q1_6_11_16.odg 1f46c751b525d843cbcac57e25e104a6 *vignettes/figures/dags/p5q1_6_11_16.pdf 5ffa0fc6816d49b08ff4e33cd0ac6156 *vignettes/figures/dags/p5q1_6_11_16.ps f51e573e1ee0416774241ab15065ba25 *vignettes/figures/dags/p5q1_6_7_11_12.odg 4b90822210633b471edcadc410258f99 *vignettes/figures/dags/p5q1_6_7_11_12.pdf a7d6e059e2d07f2d84aeadb9f5f90539 *vignettes/figures/dags/p5q1_6_7_11_12.ps 3f41f9a36481dd33390cfaf81ee2ca5c *vignettes/figures/fev_viterbi.pdf 719b8f8def499016bdb41073ed722c17 *vignettes/figures/general.eps e3889cf40ff59689f1a6cfac011c7115 *vignettes/figures/general.pdf 06f4bff6b071901d1120c7431193c59d *vignettes/figures/hidden.pdf 5451feeab645e33d8c7bef5d0aa8a98d *vignettes/figures/hidden.ps 4771735ed2a09648b7aeb2f8799ff6d2 *vignettes/figures/illdeath.eps af3adf546c0c77610b76919d15607a18 *vignettes/figures/illdeath.pdf 1f195733d41f501f1ac2bff1480c11ad *vignettes/figures/multistate.eps 2d8ca6ab876fe50cf7bfee4724fdcbc3 *vignettes/figures/multistate.pdf ff63d25eaeeb6d96ddd84aa1c465d8cf *vignettes/figures/p2q1.eps 8ec73693aa663c3a367f7bd5ea663c7c *vignettes/figures/p2q1.pdf 6b0d054b238fd57970dabe8c75a8f550 *vignettes/figures/p2q12.eps 7f89c5f85f787b2b41c623cbf366d042 *vignettes/figures/p2q12.pdf 4ee4efe72c12f85d6f2952fda938c102 *vignettes/figures/p3q12.eps 04f638273c713543f6dad7c71778df07 *vignettes/figures/p3q12.pdf 39996765b7e31d8519525e255268bf02 *vignettes/figures/p3q124.eps 98c0baea7a7468465b6d5fba30a62cfa *vignettes/figures/p3q124.pdf d4b9ec1e789f253a174a61ae620cf4f3 *vignettes/figures/p3q1246.eps 634cc49ae5959dbfaab98007521e3150 *vignettes/figures/p3q1246.pdf f6c5867da460082a661577cafd0c2453 *vignettes/figures/p3q135.eps 0ae4b74fa9984b26cdaf3a37ef0ec733 *vignettes/figures/p3q135.pdf 498b51d5b724ca0a5567e45cfbed657e *vignettes/figures/p3q14.eps 5178056951a81e36e697d91d6f655348 *vignettes/figures/p3q14.pdf 3d48200263d7177c8d5e718b4cfc84c1 *vignettes/figures/p3q16.eps 1d88c1377297306389a460a8a5598ff2 *vignettes/figures/p3q16.pdf 54953991c646d50f67b24b71f52389eb *vignettes/figures/p4q13569.eps a54418b47ce58e6fa28c500af30d5566 *vignettes/figures/p4q13569.pdf 33bdcd26391ca342b3d58c8a983af053 *vignettes/figures/p4q159.eps 0bbc74d48ecbcee9199ebea6811bf377 *vignettes/figures/p4q159.pdf de21e325db27e722d5cad8676cd51954 *vignettes/figures/p5q1_4_6_8_11_12_16.eps 684cf4d5299dab735d4ddf4fdaedcca4 *vignettes/figures/p5q1_4_6_8_11_12_16.pdf 869f3b870a7334b80f580eef0d590ff2 *vignettes/figures/p5q1_6_11_16.eps 3fa510d2be43accb7ce3cbbe125c93a5 *vignettes/figures/p5q1_6_11_16.pdf 657f1f575ca40ea0131b41b829c103f1 *vignettes/figures/p5q1_6_7_11_12.eps 2de6c2326f3031d048c31b507d6a2f20 *vignettes/figures/p5q1_6_7_11_12.pdf 2ea085b4ec235c4882c6a0958c9362a5 *vignettes/figures/sampling.pdf fd11fcc667a86de205755f383ea1fc21 *vignettes/figures/sampling.ps 4a162e5dee570625baf3ba464602f681 *vignettes/msm-manual.Rnw be6c66fe663712eea54faf33c2861c3b *vignettes/msm.bib msm/build/0000755000176200001440000000000012774212430012147 5ustar liggesusersmsm/build/vignette.rds0000644000176200001440000000034112774212430014504 0ustar liggesusers}Q0  'jLxS/^  Ao>X cv}0!RS`ϹJruB.t