msm/0000755000175100001440000000000012623033544011066 5ustar hornikusersmsm/inst/0000755000175100001440000000000012622641761012050 5ustar hornikusersmsm/inst/CITATION0000644000175100001440000000122712505076165013207 0ustar hornikuserscitHeader("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/NEWS0000644000175100001440000011452712622613470012555 0ustar hornikusers-*- text -*- USER-VISIBLE CHANGES (for detailed changes see ChangeLog in the source package) -------------------- 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/0000755000175100001440000000000012622641761012615 5ustar hornikusersmsm/inst/doc/msm-manual.R0000644000175100001440000002350012622641761015007 0ustar hornikusers### R code from vignette source 'msm-manual.Rnw' ################################################### ### code chunk number 1: msm-manual.Rnw:23-25 ################################################### version <- gsub("Version: +", "", packageDescription("msm", lib.loc=c("../..",.libPaths()))$Version) ################################################### ### code chunk number 2: msm-manual.Rnw:30-31 ################################################### cat(version) ################################################### ### code chunk number 3: msm-manual.Rnw:34-35 ################################################### cat(format(Sys.time(), "%d %B, %Y")) ################################################### ### code chunk number 4: msm-manual.Rnw:843-844 ################################################### options(width = 60) ################################################### ### code chunk number 5: msm-manual.Rnw:879-880 ################################################### library(msm) ################################################### ### code chunk number 6: msm-manual.Rnw:939-940 ################################################### cav[1:21,] ################################################### ### code chunk number 7: msm-manual.Rnw:950-951 ################################################### statetable.msm(state, PTNUM, data=cav) ################################################### ### code chunk number 8: msm-manual.Rnw:1002-1006 ################################################### 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:1040-1042 ################################################### Q.crude <- crudeinits.msm(state ~ years, PTNUM, data=cav, qmatrix=Q) ################################################### ### code chunk number 10: msm-manual.Rnw:1066-1068 ################################################### cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4) ################################################### ### code chunk number 11: msm-manual.Rnw:1096-1097 (eval = FALSE) ################################################### ## help(optim) ################################################### ### code chunk number 12: msm-manual.Rnw:1120-1121 ################################################### cav.msm ################################################### ### code chunk number 13: msm-manual.Rnw:1160-1162 ################################################### cavsex.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = Q, deathexact = 4, covariates = ~ sex) ################################################### ### code chunk number 14: msm-manual.Rnw:1170-1171 ################################################### cavsex.msm ################################################### ### code chunk number 15: msm-manual.Rnw:1187-1189 ################################################### 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:1201-1204 (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:1215-1219 (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:1255-1259 (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:1298-1299 ################################################### pmatrix.msm(cav.msm, t=10) ################################################### ### code chunk number 20: msm-manual.Rnw:1328-1329 ################################################### sojourn.msm(cav.msm) ################################################### ### code chunk number 21: msm-manual.Rnw:1341-1342 ################################################### pnext.msm(cav.msm) ################################################### ### code chunk number 22: msm-manual.Rnw:1367-1368 ################################################### totlos.msm(cav.msm) ################################################### ### code chunk number 23: msm-manual.Rnw:1390-1391 ################################################### qratio.msm(cav.msm, ind1=c(2,1), ind2=c(1,2)) ################################################### ### code chunk number 24: msm-manual.Rnw:1399-1400 ################################################### hazard.msm(cavsex.msm) ################################################### ### code chunk number 25: msm-manual.Rnw:1409-1410 (eval = FALSE) ################################################### ## qmatrix.msm(cav.msm) ################################################### ### code chunk number 26: msm-manual.Rnw:1419-1420 (eval = FALSE) ################################################### ## qmatrix.msm(cavsex.msm, covariates = 0) ################################################### ### code chunk number 27: msm-manual.Rnw:1425-1426 (eval = FALSE) ################################################### ## qmatrix.msm(cavsex.msm, covariates = list(sex = 1)) ################################################### ### code chunk number 28: msm-manual.Rnw:1452-1453 ################################################### plot(cav.msm, legend.pos=c(8, 1)) ################################################### ### code chunk number 29: msm-manual.Rnw:1695-1697 ################################################### options(digits=3) prevalence.msm(cav.msm, times=seq(0,20,2)) ################################################### ### code chunk number 30: msm-manual.Rnw:1699-1700 ################################################### plot.prevalence.msm(cav.msm, mintime=0, maxtime=20) ################################################### ### code chunk number 31: msm-manual.Rnw:1834-1837 ################################################### 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:1962-1974 ################################################### 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:2002-2006 ################################################### 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:2008-2009 ################################################### cavmiscsex.msm ################################################### ### code chunk number 35: msm-manual.Rnw:2029-2031 ################################################### ematrix.msm(cavmiscsex.msm, covariates=list(sex=0)) ematrix.msm(cavmiscsex.msm, covariates=list(sex=1)) ################################################### ### code chunk number 36: msm-manual.Rnw:2078-2080 ################################################### 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:2126-2128 ################################################### vit <- viterbi.msm(cavmisc.msm) vit[vit$subject==100103,] ################################################### ### code chunk number 38: msm-manual.Rnw:2326-2327 ################################################### 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:2345-2357 ################################################### 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:2624-2625 (eval = FALSE) ################################################### ## help(msm) ################################################### ### code chunk number 41: msm-manual.Rnw:2633-2634 (eval = FALSE) ################################################### ## help.start() msm/inst/doc/msm-manual.pdf0000644000175100001440000150002412622641761015361 0ustar hornikusers%PDF-1.4 % 3 0 obj << /Length 2273 /Filter /FlateDecode >> stream xڭɖ۸Бzo&ӹ/%EE)R!At>  B=|JUd Pd:UqmSnt3]?ݑ_kx=1>}ɚz'&d$X<ĩhA:WhD4q^XD]T8y߷Z ;F ZѵI:g[cN{3l0PL@Dgt\s[30<Ѵ!WIQ">~Ȉ?e m=2:ڨUfZ6>V`G#l): 5r~ex~T]TU雐7D(8SQ2 Ufe,;J|3rSS„X ߶: DꌄfS;Xh'Yzm+<Xv&yk3 - ֍uLv{Vt$!b+qtla4 CFpn'O˞ ˕CςKE~am{xtfRJڌYs0u={Y<9sX2hht]%q)gg:Fpqw?U FU*GyP { =/b?Lqb~CXvAWE BXTѣV@Nua>)Hys Am828;lM5dejW8odFq ||ǂtx\hfݝ35f }t-et/_82+b}H<⻸XObECߓ25qc/19[a޸C#-/PH"JaH EDž['XfA hU&pY=_`8ʹK ͨ5[/qJ;Si[z\:CN ҕ׶: UdsC3ޱ"^,1y$R:oM _aO&\YMCH'׹gKz-UϵÝ Є39WDew|儉wõ։f@s6T{FVy]NxT`TtUE =: ])tUBP0GɕƳ4WI,rJsnrXLRE'WdS endstream endobj 2 0 obj << /Type /Page /Contents 3 0 R /Resources 1 0 R /MediaBox [0 0 612 792] /Parent 11 0 R >> endobj 1 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F47 6 0 R /F49 7 0 R /F11 8 0 R /F8 9 0 R /F10 10 0 R >> /ProcSet [ /PDF /Text ] >> endobj 17 0 obj << /Length 3674 /Filter /FlateDecode >> 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 16 0 obj << /Type /Page /Contents 17 0 R /Resources 15 0 R /MediaBox [0 0 612 792] /Parent 11 0 R >> endobj 15 0 obj << /Font << /F43 4 0 R /F11 8 0 R /F8 9 0 R /F10 10 0 R /F13 18 0 R /F7 19 0 R /F14 20 0 R /F1 21 0 R /F49 7 0 R /F47 6 0 R >> /ProcSet [ /PDF /Text ] >> endobj 24 0 obj << /Length 786 /Filter /FlateDecode >> stream xVMo0 W̊> ڭv+۰CEYNi|AS4IG/ CҠ1cQE,] HPhD^X"As jaTr}Zϧ2?LBym~?__Eqlru=u(LA,T2'P<AyʲCTAr^ڂ(}z1\P^^~ͽvPA%wVRtlV`r'Un+6ZoI)K; 0.{n> endobj 12 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/multistate.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 25 0 R /BBox [0 0 263 254] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 26 0 R >>/Font << /R8 27 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 25 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174558) /ModDate (D:20060622174558) /Title (multistate.fig) /Creator (fig2dev Version 3.2 Patchlevel 4) /Author (chris@bumblebee \(Chris Jackson,,,\)) >> endobj 26 0 obj << /Type /ExtGState /OPM 1 >> endobj 27 0 obj << /BaseFont /Helvetica-Bold /Type /Font /Subtype /Type1 >> endobj 13 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/general.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 28 0 R /BBox [0 0 650 218] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 29 0 R >>/Font << /R8 30 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> endobj 29 0 obj << /Type /ExtGState /OPM 1 >> endobj 30 0 obj << /BaseFont /Helvetica-Bold /Type /Font /Encoding 31 0 R /Subtype /Type1 >> endobj 31 0 obj << /Type /Encoding /Differences [ 45/minus] >> endobj 22 0 obj << /Font << /F11 8 0 R /F8 9 0 R /F1 21 0 R /F7 19 0 R /F43 4 0 R /F10 10 0 R >> /XObject << /Im1 12 0 R /Im2 13 0 R >> /ProcSet [ /PDF /Text ] >> endobj 35 0 obj << /Length 3038 /Filter /FlateDecode >> 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" > endobj 33 0 obj << /Font << /F43 4 0 R /F47 6 0 R /F49 7 0 R /F11 8 0 R /F10 10 0 R /F8 9 0 R >> /ProcSet [ /PDF /Text ] >> endobj 38 0 obj << /Length 306 /Filter /FlateDecode >> stream xuMo0 4NB;Nk6۴"A߿,"l?A`n!pӜ)H\(;bTz{^4G}9z ς;^ljz.A p x&WRK*PCQ{|hO`Sd.fImXMG5(f9J#0( W\[? 4"d@&Ŷ^6K,Z2Nd ׋s[9K҆h?G3\LcS%h<=txxa7]t}KRA endstream endobj 37 0 obj << /Type /Page /Contents 38 0 R /Resources 36 0 R /MediaBox [0 0 612 792] /Parent 11 0 R >> endobj 14 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/illdeath.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 39 0 R /BBox [0 0 110 103] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 40 0 R >>/Font << /R8 41 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 39 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174557) /ModDate (D:20060622174557) /Title (illdeath.eps) /Creator (fig2dev Version 3.2.3 Patchlevel ) /Author (chris@blankenburg \(Chris Jackson\)) >> endobj 40 0 obj << /Type /ExtGState /OPM 1 >> endobj 41 0 obj << /BaseFont /Helvetica-Bold /Type /Font /Subtype /Type1 >> endobj 32 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/sampling.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 42 0 R /BBox [0 0 360 720] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R6 43 0 R >>/Font << /R14 44 0 R/R13 45 0 R/R12 46 0 R/R11 47 0 R/R10 48 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+> endobj 43 0 obj << /Type /ExtGState /Name /R6 /TR /Identity /BG 49 0 R /UCR 50 0 R /OPM 1 /SM 0.02 >> endobj 44 0 obj << /BaseFont /Helvetica /Type /Font /Name /R14 /Subtype /Type1 >> endobj 45 0 obj << /BaseFont /Helvetica-Bold /Type /Font /Name /R13 /Subtype /Type1 >> endobj 46 0 obj << /BaseFont /Helvetica-Oblique /Type /Font /Name /R12 /Subtype /Type1 >> endobj 47 0 obj << /BaseFont /Helvetica-BoldOblique /Type /Font /Name /R11 /Subtype /Type1 >> endobj 48 0 obj << /BaseFont /Symbol /Type /Font /Name /R10 /Subtype /Type1 >> endobj 49 0 obj << /Filter /FlateDecode /FunctionType 0 /Domain [ 0 1] /Range [ 0 1] /BitsPerSample 8 /Size [ 256] /Length 12 >> stream xc` endstream endobj 50 0 obj << /Filter /FlateDecode /FunctionType 0 /Domain [ 0 1] /Range [ -1 1] /BitsPerSample 8 /Size [ 256] /Length 12 >> stream xkhD endstream endobj 36 0 obj << /Font << /F43 4 0 R >> /XObject << /Im3 14 0 R /Im4 32 0 R >> /ProcSet [ /PDF /Text ] >> endobj 66 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> endobj 64 0 obj << /Font << /F43 4 0 R /F11 8 0 R /F8 9 0 R /F7 19 0 R /F10 10 0 R /F1 21 0 R /F14 20 0 R /F13 18 0 R /F6 67 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 70 0 obj << /Length 638 /Filter /FlateDecode >> stream xVMo@WpRS+qkz 6NNm%8 9Dv o߾}.-R$:7 : ZD#eif_&L8`*WόtFON/Jf? ,`f#л Js|qcB6QQ縬rqRy m|nYw,ehOf.Ŕ}`m>Zu^,H#E;0`lHv,"a/9B8PZOڞݨ^`zش94Lh 5@B:7uٔ[/ɶO2յ}s:@5A[dH(Ƣvێ~lBa]> endobj 51 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p2q1.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 72 0 R /BBox [0 0 171 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 73 0 R >>>> /Length 135 /Filter /FlateDecode >> stream xMA 0  {h%; ΡPJ KvGK|b}Nn/LAېWWE܉\#K &,@LKӐD"ATC7?- endstream endobj 72 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174558) /ModDate (D:20060622174558) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 73 0 obj << /Type /ExtGState /OPM 1 >> endobj 52 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p2q12.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 74 0 R /BBox [0 0 171 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 75 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 74 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174558) /ModDate (D:20060622174558) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 75 0 obj << /Type /ExtGState /OPM 1 >> endobj 53 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p3q12.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 76 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 77 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 76 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174558) /ModDate (D:20060622174558) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 77 0 obj << /Type /ExtGState /OPM 1 >> endobj 54 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p3q14.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 78 0 R /BBox [0 0 284 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 79 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 78 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174600) /ModDate (D:20060622174600) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 79 0 obj << /Type /ExtGState /OPM 1 >> endobj 55 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p3q16.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 80 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 81 0 R >>>> /Length 176 /Filter /FlateDecode >> stream xeK 1 @9E.4/ \G: `v> endobj 81 0 obj << /Type /ExtGState /OPM 1 >> endobj 56 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p3q124.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 82 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 83 0 R >>>> /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 82 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174559) /ModDate (D:20060622174559) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 83 0 obj << /Type /ExtGState /OPM 1 >> endobj 57 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p3q135.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 84 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 85 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 84 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174559) /ModDate (D:20060622174559) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 85 0 obj << /Type /ExtGState /OPM 1 >> endobj 58 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p3q1246.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 86 0 R /BBox [0 0 171 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 87 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 86 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174559) /ModDate (D:20060622174559) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 87 0 obj << /Type /ExtGState /OPM 1 >> endobj 68 0 obj << /Font << /F43 4 0 R /F11 8 0 R /F8 9 0 R /F49 7 0 R >> /XObject << /Im5 51 0 R /Im6 52 0 R /Im7 53 0 R /Im8 54 0 R /Im9 55 0 R /Im10 56 0 R /Im11 57 0 R /Im12 58 0 R >> /ProcSet [ /PDF /Text ] >> endobj 90 0 obj << /Length 582 /Filter /FlateDecode >> stream x͔O0| A*{wz\VʭmB*` ԕ*Ux~yX% 2D@ֱՆ}O'Ec%J %\7τ" ·b>7khO|fcJ#4Řϳ1wT1m>)kS b.r2\j.3ϐ+aӦݔ!h8Ǯ+7P^ZG_, \(,e_?>c" B8{ yS 5)}.㱪]D ԧ͌pG BZ>6uٔX'L>SuxZcktcD:vק> endobj 59 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p4q159.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 91 0 R /BBox [0 0 398 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 92 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 91 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174601) /ModDate (D:20060622174601) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 92 0 obj << /Type /ExtGState /OPM 1 >> endobj 60 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p4q13569.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 93 0 R /BBox [0 0 398 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 94 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 93 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174600) /ModDate (D:20060622174600) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 94 0 obj << /Type /ExtGState /OPM 1 >> endobj 61 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p5q1_6_11_16.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 95 0 R /BBox [0 0 511 57] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 96 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 95 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174601) /ModDate (D:20060622174601) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 96 0 obj << /Type /ExtGState /OPM 1 >> endobj 62 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p5q1_4_6_8_11_12_16.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 97 0 R /BBox [0 0 511 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 98 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 97 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174601) /ModDate (D:20060622174601) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 98 0 obj << /Type /ExtGState /OPM 1 >> endobj 63 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/p5q1_6_7_11_12.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 99 0 R /BBox [0 0 284 171] /Resources << /ProcSet [ /PDF ] /ExtGState << /R7 100 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 99 0 obj << /Producer (GPL Ghostscript 8.50) /CreationDate (D:20060622174601) /ModDate (D:20060622174601) /Creator (GPL Ghostscript 850 \(epswrite\)) >> endobj 100 0 obj << /Type /ExtGState /OPM 1 >> endobj 88 0 obj << /Font << /F43 4 0 R /F11 8 0 R /F8 9 0 R /F49 7 0 R >> /XObject << /Im13 59 0 R /Im14 60 0 R /Im15 61 0 R /Im16 62 0 R /Im17 63 0 R >> /ProcSet [ /PDF /Text ] >> endobj 103 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> > endobj 101 0 obj << /Font << /F47 6 0 R /F43 4 0 R /F11 8 0 R /F8 9 0 R /F10 10 0 R /F7 19 0 R /F9 104 0 R /F6 67 0 R /F14 20 0 R /F1 21 0 R /F13 18 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 107 0 obj << /Length 3710 /Filter /FlateDecode >> 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 106 0 obj << /Type /Page /Contents 107 0 R /Resources 105 0 R /MediaBox [0 0 612 792] /Parent 71 0 R >> endobj 105 0 obj << /Font << /F43 4 0 R /F49 7 0 R /F8 9 0 R /F11 8 0 R /F10 10 0 R /F7 19 0 R /F9 104 0 R /F1 21 0 R /F13 18 0 R /F6 67 0 R /F14 20 0 R /F12 108 0 R /F57 109 0 R /F47 6 0 R >> /ProcSet [ /PDF /Text ] >> endobj 113 0 obj << /Length 1597 /Filter /FlateDecode >> stream xuWێ8 }:@%-EVDNm=)ǹ%")^dQef$\"֡JŦ^| l\%Qhv0z0S{3  qt=^f<` [,ؙj=k_1u;6&Xg}O7=K7,*2wD Ib^&E^UY\8̗8᏶he4ATOa. ?F-FCGZ|te*+Z@,('cݷR x_~#HJquڵ+[X#4m%gYs=|tDn1!ch17A{1q@nmE|޽öTwVtЄ |JT|jڹ/ɝJ`XxVoСqKX`ZF Nj,qWbވr?M4C`PQXpyƥ_X-(}o_7u@;G\>52LbF7@ 02MgnGx{F"ziE> endobj 110 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/hidden.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 114 0 R /BBox [0 0 360 720] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R6 115 0 R >>/Font << /R14 116 0 R/R13 117 0 R/R12 118 0 R/R11 119 0 R/R10 120 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> endobj 115 0 obj << /Type /ExtGState /Name /R6 /TR /Identity /BG 121 0 R /UCR 122 0 R /OPM 1 /SM 0.02 >> endobj 116 0 obj << /BaseFont /Helvetica /Type /Font /Name /R14 /Subtype /Type1 >> endobj 117 0 obj << /BaseFont /Helvetica-Bold /Type /Font /Name /R13 /Subtype /Type1 >> endobj 118 0 obj << /BaseFont /Helvetica-Oblique /Type /Font /Name /R12 /Subtype /Type1 >> endobj 119 0 obj << /BaseFont /Helvetica-BoldOblique /Type /Font /Name /R11 /Subtype /Type1 >> endobj 120 0 obj << /BaseFont /Symbol /Type /Font /Name /R10 /Subtype /Type1 >> endobj 121 0 obj << /Filter /FlateDecode /FunctionType 0 /Domain [ 0 1] /Range [ 0 1] /BitsPerSample 8 /Size [ 256] /Length 12 >> stream xc` endstream endobj 122 0 obj << /Filter /FlateDecode /FunctionType 0 /Domain [ 0 1] /Range [ -1 1] /BitsPerSample 8 /Size [ 256] /Length 12 >> stream xkhD endstream endobj 111 0 obj << /Font << /F43 4 0 R /F47 6 0 R /F49 7 0 R /F11 8 0 R >> /XObject << /Im18 110 0 R >> /ProcSet [ /PDF /Text ] >> endobj 125 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 124 0 obj << /Type /Page /Contents 125 0 R /Resources 123 0 R /MediaBox [0 0 612 792] /Parent 71 0 R >> endobj 123 0 obj << /Font << /F47 6 0 R /F43 4 0 R /F11 8 0 R /F10 10 0 R /F8 9 0 R /F14 20 0 R /F49 7 0 R /F6 67 0 R /F7 19 0 R >> /ProcSet [ /PDF /Text ] >> endobj 128 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 127 0 obj << /Type /Page /Contents 128 0 R /Resources 126 0 R /MediaBox [0 0 612 792] /Parent 129 0 R >> endobj 126 0 obj << /Font << /F43 4 0 R /F49 7 0 R /F11 8 0 R /F10 10 0 R /F8 9 0 R /F7 19 0 R /F9 104 0 R /F1 21 0 R /F14 20 0 R /F13 18 0 R /F6 67 0 R /F12 108 0 R /F57 109 0 R /F47 6 0 R >> /ProcSet [ /PDF /Text ] >> endobj 132 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 131 0 obj << /Type /Page /Contents 132 0 R /Resources 130 0 R /MediaBox [0 0 612 792] /Parent 129 0 R >> endobj 130 0 obj << /Font << /F43 4 0 R /F7 19 0 R /F47 6 0 R /F11 8 0 R /F10 10 0 R /F14 20 0 R /F8 9 0 R /F1 21 0 R /F13 18 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 135 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> endobj 133 0 obj << /Font << /F47 6 0 R /F44 5 0 R /F49 7 0 R /F43 4 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 139 0 obj << /Length 1833 /Filter /FlateDecode >> 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 138 0 obj << /Type /Page /Contents 139 0 R /Resources 137 0 R /MediaBox [0 0 612 792] /Parent 129 0 R >> endobj 137 0 obj << /Font << /F43 4 0 R /F49 7 0 R /F44 5 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 142 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> endobj 140 0 obj << /Font << /F44 5 0 R /F43 4 0 R /F11 8 0 R /F67 136 0 R /F47 6 0 R /F8 9 0 R /F1 21 0 R /F14 20 0 R /F7 19 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 145 0 obj << /Length 3250 /Filter /FlateDecode >> 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 144 0 obj << /Type /Page /Contents 145 0 R /Resources 143 0 R /MediaBox [0 0 612 792] /Parent 129 0 R >> endobj 143 0 obj << /Font << /F43 4 0 R /F11 8 0 R /F7 19 0 R /F8 9 0 R /F44 5 0 R /F67 136 0 R /F47 6 0 R /F10 10 0 R /F14 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 148 0 obj << /Length 2742 /Filter /FlateDecode >> stream xڭYKܸϯKn%R  fmOz5gZY=ڒ䷧^ԣG9,d*woMZeֆ"& #=l~ن:sӔ{(d}L&d*y´שEvvMMiu{p+l'"i囙,! Tjsnl^Sמ2t&Pi:Nz"XǞleQU. 9M_t72T6@+|Yyuvt n?!yWn( &Pn0`;Z9 T9F%TYS6-VK?uK4ݕ̑uJK%8p 7M? ρ d7\ޡi|/XϷ?Ga+Ru1Bd"&4Ks9·vtmTguށFi Uܚy59Ohsg'ۼ"\v?* C3Px{x}Djx~8J׏{aK)8vmSpzٻ's7.̞<ײ=Hsm'rP=K๎xn~ku,cm6џ\Q?8Z{5XI2ǮD:=8aÇc>tOB+kW^okl0%dj{׻Qyg6̪4֢Jq:o@6whҡYJd1?p#و#cj'* 1˟G׉q)chcn~Y]8 b*^ͣaotD !`v{1'\nӞ+z2(Ti`_01ռ׀KG&f%6r=\ xmނ1Pö.d!Ӄozv]M~sL%I|TBUض|4 V|R;{ak7ۂw t <Zc`k >p> endobj 146 0 obj << /Font << /F47 6 0 R /F75 149 0 R /F43 4 0 R /F44 5 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 153 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 152 0 obj << /Type /Page /Contents 153 0 R /Resources 151 0 R /MediaBox [0 0 612 792] /Parent 150 0 R >> endobj 151 0 obj << /Font << /F44 5 0 R /F43 4 0 R /F47 6 0 R /F11 8 0 R /F8 9 0 R /F10 10 0 R /F7 19 0 R /F13 18 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 156 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 155 0 obj << /Type /Page /Contents 156 0 R /Resources 154 0 R /MediaBox [0 0 612 792] /Parent 150 0 R >> endobj 154 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F49 7 0 R /F8 9 0 R /F11 8 0 R /F10 10 0 R /F67 136 0 R /F7 19 0 R >> /ProcSet [ /PDF /Text ] >> endobj 159 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 158 0 obj << /Type /Page /Contents 159 0 R /Resources 157 0 R /MediaBox [0 0 612 792] /Parent 150 0 R >> endobj 157 0 obj << /Font << /F67 136 0 R /F44 5 0 R /F43 4 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 162 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 161 0 obj << /Type /Page /Contents 162 0 R /Resources 160 0 R /MediaBox [0 0 612 792] /Parent 150 0 R >> endobj 160 0 obj << /Font << /F43 4 0 R /F47 6 0 R /F67 136 0 R /F44 5 0 R /F11 8 0 R /F7 19 0 R >> /ProcSet [ /PDF /Text ] >> endobj 165 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 164 0 obj << /Type /Page /Contents 165 0 R /Resources 163 0 R /MediaBox [0 0 612 792] /Parent 150 0 R >> endobj 163 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F47 6 0 R /F49 7 0 R /F11 8 0 R /F8 9 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 168 0 obj << /Length 2338 /Filter /FlateDecode >> stream xڵYKϯQ ߤl `$jn+%G}͞LdT,U}U~nSJy8nRY1[sN^?[~?KfpTp ۝8ޚP }_˔P.%݂v?Ɇh硫C z!OS\F'Z'6;QrfJC E5}!c` Sd.͜61jűp OVSehh0\{羍ӟ`њ$[v{WgˑJ0%9(嗻eNQDdCr^+0I5#`aIÿIo,+ K=N{ؒ,DO )m7z3g^LWs:_uI`8C]=Mu_ &pn4b!Eu]7C9HvgfeirNy i/wnD":c^H8*A?O }vypNvNHx-KL)Ja4ÍK%ijK7jґ.t4R8W4+,΋r Zv7%i̗$-w0cXN@Ҍ k˜)א z =68>]quƝT·F ;3Yf>3.d2k\i~!C iqn8NT!t& K șQ :͗)ꦛ Jhhp NwX5NS{ lu@n5Y\:DbRN2&f#5ѳkZ0$4Tv gAV]u pu_Q} usko.?Wݿdrpe3&bDYtUFW#&̙#tu1@7܅CK.ݓUGc"F:vh7*YRV'3'c鉳Ҳep_rX 3 Ϩ92AxЖ>nm yb K|~'?H N( ]oPGI͛xQ Gd),EZ[_ewPҼF}1T7&lXeVYV i (ח8@Rb|%=lKYHϡyKؾkp āTKKC]hD/VrJN]DW@)3%B򃘇K]u:d81BR݇O5#6}X^@zJ0i+/8@¹!Rigt^p9ba ->}(}p")Tgؑ)^wj'>T}8|DB rp$Didq [*4 wn3.겸0-8:;JH}ur_"i8EkxRi~Éo0L DN/90<@ xҏ 3ܛxmdI݂(f5gY/X<])!ժ2Kn])qwT%ޖMz[qx*=◇pLu; 1R2| a+F]Vǫ7M:룃)H^lj'KQ#"2<1n) t3ѵ#xIX$U3-H}z"U֧ydsPj/q2t2>nԾ3XL읁5[!U+e e{+K$ ="/`2QlύY:(松$~5cz!2;C ?y_!W[/)ձ{:%s=e(HeFxMR sv spT$i) F5cB|ڹICon~cxN,tc6|RO:#:E!Ee=#.}$ <8nw'HGdXd3%"JL #o'MMySɚt)Z,4l߶Cd 2pFlj},y>D`ӂ K}ϑJ^I.ǫO~KL㺷ae.v VC=> endobj 166 0 obj << /Font << /F47 6 0 R /F43 4 0 R /F44 5 0 R /F11 8 0 R /F14 20 0 R /F8 9 0 R /F10 10 0 R /F67 136 0 R /F7 19 0 R /F1 21 0 R /F6 67 0 R >> /ProcSet [ /PDF /Text ] >> endobj 172 0 obj << /Length 2067 /Filter /FlateDecode >> stream xڥXKϯ! H!`A.=evm!HrbQ/[= RՃ3o6jfXTfsO/Y3 $oIꖤs3̻|y, 1)}>s\ow ?:;F$v' Ͼp.ۮŹ)Т/OKB T# /åeSO3io/ܳSwZ=sr@pSG{:ga+L6@U]꾬;>tYrKGNPeC< "=[ig<7Dqڴ܅$9x;XhUy_Tj$~EJu,DͶ;e9ʾ1Tg㝡fd%j^C_UË{v /0HB;q|.;j*05]|4](!P7֭4}ܚ33%gF%Hz>n#&Ż<7%JG&]y*%VxA"v/*U~4x#_d \! `M!' s|$($~.ۢu Q o䐜o 0LW5xV1aײPВ8U>$"$2 i`d (3z6+m= Z^$\,ѿ@7E[܃D.1HBuD ͎75&PTMbְ1/2b]N`U7ljjcI/ъ:t$V}A<"s\Q%~@)jL\ӣeJ*I7ۃRB-)B ('X(*iQQi3cjZYP,PtaifeXM vHAȄ][2e>r@NHgJ63&,F:@ D$H׬:šDZ*0 HC?d%eU;ϪZF-ݔԾp3Nh_Hw1%ŝD:V'_5v _ie-"hЎB :ZU%4c[Ѧ"Rz"WD c{*UP$Vl1p?=3\Pe͢Ncyt9lpM"lv|g2dMs(7>eĄ^OcJ,SARP'fHwpEs)A\!RCfSH t(Jg҇gΩ뒠4K&UO.;0%)ɿha"8cez+0Lؚxկ*2Xw@Clge6ޭvPfڸ*ueIll 8XhǢ/e^57S_T)E@;ocCf7 _P Vdq iKկk&#(o>ťQ[GeoeR\dIHI٫GKӜŧuC U :ecNedr m$ݑ(+Kr\d7?^}Ko"<'b?$ endstream endobj 171 0 obj << /Type /Page /Contents 172 0 R /Resources 170 0 R /MediaBox [0 0 612 792] /Parent 169 0 R >> endobj 170 0 obj << /Font << /F44 5 0 R /F47 6 0 R /F43 4 0 R /F11 8 0 R /F7 19 0 R /F67 136 0 R /F8 9 0 R >> /ProcSet [ /PDF /Text ] >> endobj 176 0 obj << /Length 1116 /Filter /FlateDecode >> stream xڥVKo6W(6#RC tv lz%&f+I×"{bH7~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 Mvg?B7{I 4ҁۣ#obև9;LJڣ%0m3kyx#FֵNt?/,%K$Ͼ 6V,%NФ7-[J rjQyh ER:Q1x%_/DZեWΩXKhғdE?r,|)Te "1\\I|q ,4/.gǡaaq NJ9P8njQh\#<0&`݌8DžZ&|T˟Aoh{\Rs2$ƶ] ɼxfΆ(<@2ƒV)`у0 y(2Uгg6v$mkvʛgs`M#> endobj 173 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./msm-manual-028.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 177 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 178 0 R>> /ExtGState << >>/ColorSpace << /sRGB 179 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 177 0 obj << /CreationDate (D:20151117151213) /ModDate (D:20151117151213) /Title (R Graphics Output) /Producer (R 3.2.2) /Creator (R) >> endobj 178 0 obj << /Type /Font /Subtype /Type1 /Name /F2 /BaseFont /Helvetica /Encoding 180 0 R >> endobj 179 0 obj [/ICCBased 181 0 R] endobj 180 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 181 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 174 0 obj << /Font << /F67 136 0 R /F43 4 0 R /F44 5 0 R /F47 6 0 R /F11 8 0 R /F8 9 0 R >> /XObject << /Im19 173 0 R >> /ProcSet [ /PDF /Text ] >> endobj 184 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 183 0 obj << /Type /Page /Contents 184 0 R /Resources 182 0 R /MediaBox [0 0 612 792] /Parent 169 0 R >> endobj 182 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F47 6 0 R /F49 7 0 R /F67 136 0 R /F14 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 187 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 186 0 obj << /Type /Page /Contents 187 0 R /Resources 185 0 R /MediaBox [0 0 612 792] /Parent 169 0 R >> endobj 185 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F47 6 0 R /F11 8 0 R /F7 19 0 R /F49 7 0 R /F10 10 0 R /F14 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 190 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 189 0 obj << /Type /Page /Contents 190 0 R /Resources 188 0 R /MediaBox [0 0 612 792] /Parent 169 0 R >> endobj 188 0 obj << /Font << /F43 4 0 R /F14 20 0 R /F44 5 0 R /F47 6 0 R /F49 7 0 R /F75 149 0 R /F11 8 0 R >> /ProcSet [ /PDF /Text ] >> endobj 193 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 192 0 obj << /Type /Page /Contents 193 0 R /Resources 191 0 R /MediaBox [0 0 612 792] /Parent 194 0 R >> endobj 191 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F11 8 0 R /F8 9 0 R /F7 19 0 R /F10 10 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 198 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 197 0 obj << /Type /Page /Contents 198 0 R /Resources 196 0 R /MediaBox [0 0 612 792] /Parent 194 0 R >> endobj 196 0 obj << /Font << /F44 5 0 R /F67 136 0 R /F43 4 0 R >> /ProcSet [ /PDF /Text ] >> endobj 201 0 obj << /Length 1629 /Filter /FlateDecode >> stream xڅWK6 ϯmvۢ[(AJNHe"(tr!ҦnwӶjvt]6e^œw2ǩv?ػepw?bwLuQλl&/vB1+v䃝fyNA!$ϫD$'B?(YD( DE.;2yRS**JzOhN'=%yz*z=z_Tݯr|,VD|ʪoD9+="K/z&(8=nd{5yvv"J#}%>Er'=J7>fO 64W{Q8%G?2 ݈)u}.^9IXTKMϓ`-\]`]Qel;Znl{o&k:ΩYNЬؓtxhN\BL~3f4k(E14^A5r`QO˾o{&^8ibkEfBr>jc(޽Y3;)16d/hHo`oE,dBI $Rso̗% ,%J=Ϊ .b=;^]VmA0ɢGSF5nFM܇m0KN|=Ћ}>#_U!N- "cyf7UڈUcxi8aTPdYND1kVB'ա`,tB<P[ cM6wzìEVm@FmNN,-u4iCAEZ6ŭ:HbjFhb \ ;9n+T3|&/P!7tR;^+#o@(r_=^yx A `Ity{%AHN)X)"=PS>.D\2X5@ۗtc=eW՘PAՀ& Kn Ձ-u]& #. Nݲ0OYV,̕=-u8;qu]x rȓރKir0[ً +Cj z5+h6^Bb,?srsw[ciK񱃐U>r9#j.pX{)*NB/4x,?ui](: h{mfhI < nT$*P {}ރS0@u\)hY٫>;tv}h"i5Z>~i|E6r]])*2^ 7QHdmp) g4O<.#E.Rϳ"YN/I)YQr7 [_RK<94i$[6|KM{'ABtJ՗cMvǴno"OҊ҄$J.M|B{6,MV@ТӲfW 1^W[9b{y.R:-^ Hy'W ^-oܑhBw{ӟmsBG'Z φr ^ 3|Bw^ϬԶ ZG-o[g+񌄝rzCҢ',z(?M endstream endobj 200 0 obj << /Type /Page /Contents 201 0 R /Resources 199 0 R /MediaBox [0 0 612 792] /Parent 194 0 R >> endobj 195 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./msm-manual-030.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 202 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 203 0 R/F3 204 0 R>> /ExtGState << >>/ColorSpace << /sRGB 205 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 202 0 obj << /CreationDate (D:20151117151213) /ModDate (D:20151117151213) /Title (R Graphics Output) /Producer (R 3.2.2) /Creator (R) >> endobj 203 0 obj << /Type /Font /Subtype /Type1 /Name /F2 /BaseFont /Helvetica /Encoding 206 0 R >> endobj 204 0 obj << /Type /Font /Subtype /Type1 /Name /F3 /BaseFont /Helvetica-Bold /Encoding 206 0 R >> endobj 205 0 obj [/ICCBased 207 0 R] endobj 206 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 207 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 199 0 obj << /Font << /F43 4 0 R /F49 7 0 R /F44 5 0 R >> /XObject << /Im20 195 0 R >> /ProcSet [ /PDF /Text ] >> endobj 210 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> endobj 208 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F49 7 0 R /F47 6 0 R /F11 8 0 R /F7 19 0 R /F10 10 0 R /F9 104 0 R /F8 9 0 R /F1 21 0 R /F14 20 0 R /F13 18 0 R >> /ProcSet [ /PDF /Text ] >> endobj 213 0 obj << /Length 2143 /Filter /FlateDecode >> stream xڝˎ_чV#l› męzfbjGFT,ͪbT ViOL~0:cRC}xvO`c"jdGi Nr:[Llky .^df\,Y%gq*fUyi*ք}ˍz W2ʑĀ҃bF"_Cb ,m%S0A Rj%/4]D iڑP';}6@!d7׍LwKo1Ҁк_z.oZG.y2,+["{wSVIטj)i{:+ /tߵo<-Lja x3~ҡCҌ|4M7zQ|U-6-:`SxU\VhR qU./]Vm9}q}ol;?dzz f,:ZE߽_dZLdۜQKŁ`]aב`_mt4 <!2`ye~ot!m19SPWDo<ӷ!a2%}\G?A rW^t(mp &`,Z#e;Ztd$Th<_ vĪ?,Å*qyjgWH/Wt=tsJ0`uB)5+L 5wSntYxqCSvg7, ؉bLf T Lp(psStwE ӖmʅIA`U~yT)kh*Dq8d`w 4Z- 7f(!eʤ5Of,'#-hVeBS}WmNE4Ω$EPt @KcMZ6e_MمRfᆄ,F .<;](`I#"pZ"nԒqL/Uo|. f Z|Lwh*#m CC]1RK+i_s$ϸO|w@Bɵ-AgUVX^Uؿ'VH= yGBwcb`A[^74~Ǹ|MiSA{LzLoP!Xicgq'8j4;>Pz j2k&zB! ۻxߗm5`aE\ydt< y'7> endobj 211 0 obj << /Font << /F43 4 0 R /F11 8 0 R /F7 19 0 R /F10 10 0 R /F13 18 0 R /F49 7 0 R /F44 5 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 216 0 obj << /Length 1932 /Filter /FlateDecode >> stream xڭXKoWX~?YdHmfD[$R!uߧIj("Cͪb=*燿uXVϯP9+kTO{ivcʀDV I<r{;6 V| N4]^. Ƶv|p,E̓f5V6[3a=3ڷ4fsC,`79crjd[kv]uDpټy׵}kݣ0o+^ֽ 0AىS{d5Wj痦h2i^*jUAoƾnxځ=n_!!VOn,ZLLd~C=&ߺdvdƟCwjK5<0L*x=#χG7@_ R-@T;_Or"M3;E h#ݡ_OI}ƬA.+v"`taoB Luם疐FۦxZBǻ9TJoz#ۄ-|#Ѵ<2\~DZBp Kaxl`850j/ }?\ma8ʞ}q1aY*m0,0'$a#Ft(*9R#B4PaY|=VB9x&qț35/*e/5/Ө9~G#P.\Toؼç<pWR6)O/E;?|ʫ=%ǟޓrBz)SjY7N.]ȌuQ7Y xG;y mtt" COqSvSy[CSF3gZ/RπzezU] 8E&fGнIvP=!HxߚU?1,* 18aCKL/sO6[ Tx\442g^AE=\f%B0Ƕ<4ȧqz@yȋ3r$M?Gp)>2| SbG>@4o8$6V`M;,%oF12ӄ滉T.7jd}sBq> endobj 214 0 obj << /Font << /F44 5 0 R /F43 4 0 R /F7 19 0 R /F10 10 0 R /F9 104 0 R /F13 18 0 R /F6 67 0 R /F11 8 0 R /F14 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 219 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 218 0 obj << /Type /Page /Contents 219 0 R /Resources 217 0 R /MediaBox [0 0 612 792] /Parent 221 0 R >> endobj 217 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F11 8 0 R /F7 19 0 R /F47 6 0 R /F84 220 0 R /F49 7 0 R /F8 9 0 R /F1 21 0 R /F14 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 224 0 obj << /Length 1701 /Filter /FlateDecode >> stream xڵWK6WTF*)>$M)m ,9I.P+op3͋~|s)fyDϖ"Nu6*fhS3//"U2cķk |{eg D6v]o}ؙж݅ \g9WŵEcQ;ms4xLE˝ws"sWv(;znq XV6pTs"G% }gPOk5mSTPU8M[mhh13x.s3 Uϭi*/"uvuEڽuރpQyS7'$YSE-Slo]_>/ysvZHH 5r5&V-Ƽp)~xC}^XW xi J8~\pdV")܎xUQzo؍,9!&,CV=4,dqcV) i+Џ.HYJAnTRd"j̡1LlHdzj̀+[<CU@A`Z,Vsl>0H%*)0EpG B@"H1- ӽ$VU0EE\`B I*XPhq* #GQuܯ|vb}9vGmM$rg( {EwTFv{qA~H^z1SmBKPߏ БG/D6neWI8 ݄Do8I=$a pA< ;Ꮷ<}(h@b}§s9"}j>Z8) az ho, S4mW*VMMTc)u}K@L!8=hxօ1Dp=LQR)ٙ۟Jǐw#N|l *|lL[A<2:- >z<âkpyzutM+C#LqƢYA/Cîb.n1rj|7_9&,&ї\ӛ/[QV&Rp>zKK+7|L32CEB:#Z>qACqM˯Wo^s37:ug!I0K^hBS@Q,$V ӂ&@oU H)AO]Md;`Ah!|xhG?D,;S]]o0H'ym ]7FHǠ?KLS,{9-:&&LF)<%jJVl ݫbLx{ I!Lg D?˲ > endobj 222 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F47 6 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 227 0 obj << /Length 1736 /Filter /FlateDecode >> stream xڵXK6WLDh @2٪8yT]%(֖{MJ(y]@jWizWąnK3RUy&fK#D}o{GdBom(R9~ZJ.Qe2 kտ2IBG4!2c4!(M$Yi7u4jĹDR4eLbFiPΥiiLߤ4LjbIYdAKF+iwiLA4nCݤ)L1d0&UNI [ʰdGvFlnw˺}ۖ.DEBtڮꟉ2=DGpPC[.7|(HǪZ3 9pP܀ƵG_?/*Rh`& :v#=>0BfDR'ѱshR)X:S fb}Tj9ޤR]`v`Wt!.Ћ49<3ãyLq:9H2d8~Dn!uv@%Qhs%#xC\ZHbdMIt51r c 6Da.S>-1eL( xҶ-QCyatumhc৮=> =$bA}`J}6}$HB 8 o*@,EQ[FFKG}b;Z >6WV*E}g_1؀BJZCeMͩ3hryM1rG!@Ѡ Da(r+^ۑ'OPszl X16ͦ>^hf4#GLHp1$sT]5UnR1C4 aƊfO+Xyf5ٹ 1`ql}wtg!:ޭP|b+:\AQ c>gOO v3}q]5@}S}|.ʳ4RE9OetbhLB14~=@xJ=p=r!`z0A6E,Zط(Y [ g4|׼_N6AmD_xqtwlm5t4d/|E%Va2wv2oНs=XOmW,P7}ć=3j u˟7O~g_s 7C e ` ?X;|Z;2vz,E6s,ן#-B)u~3Lju:N4~ɍ%)TG@ TRs$QKI$BՋ_UXw endstream endobj 226 0 obj << /Type /Page /Contents 227 0 R /Resources 225 0 R /MediaBox [0 0 612 792] /Parent 221 0 R >> endobj 225 0 obj << /Font << /F44 5 0 R /F43 4 0 R /F47 6 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 230 0 obj << /Length 1356 /Filter /FlateDecode >> stream xڭXK6W=ɭ(  9toI%Bei!ѻY?Ce^96>~{{!6vA9ϴ2 %uƸ\O_.w2U$ R SL$ gRY{HTrǂ,RJ3+_×)e 8glɨF)3G ps@B# ȿaat$'LsG. ư TS@3K)~M}6Ow:_Wu媲Gcj":$m2DMwW#SN3Io󾬫9Y(smd *HJ+g998]8B| GQ)#ֱSNPHpܲJUúϜ)oaRXǿ FqL4E3 &w'?nb Hai5 21#OpЗ_oW,?!W0tF(d(SJV0/!BӂS&L ]1v6'ڨLPtf-[e[2OqABGHɒ(9Y;?MuKo-~c[!18̘s=?ٺ2:vyY[DwTC>S~!'7,o/ѨNB'u-IvSk>ŠD[vK&F0,S8T=) 6!0k1Llww=n sQ IQ? qۣ%[Qmy[@Eas]DzveS]U3=풂ܺ.^Ò$2_]$x]]~R$[c3k_AMW=ΒQuۻ mS3pf*S3,&φ2UdUp{H}u]qmTt{l6>@|jR?ݻ䱬k\呂`f",Ћtպ,3~rS>XfqއE0 zA IĶk܀whWWB6x9?-v cx_nzw !&Bzx5|R/.w]u& bIxdND} 94xwӤD7B@TeW B2',h6,Smbٴ ;&> glG_IP&yن^Pw{61&ՙ5glgB!: h"=j&مKu͗i1T9FEo5ݏMୃK.a71\.Khsg7tcpi?{X)?f_>3(wĄX{Bn$ݽE\l endstream endobj 229 0 obj << /Type /Page /Contents 230 0 R /Resources 228 0 R /MediaBox [0 0 612 792] /Parent 221 0 R >> endobj 228 0 obj << /Font << /F44 5 0 R /F43 4 0 R /F47 6 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 233 0 obj << /Length 1689 /Filter /FlateDecode >> stream xXM6W( ?@r(P@|kz%P[2$y7;CRdki/!#jY{Iʅ#NsX=,8D:.bU.ȾyҌ/\XέX2*W(LPṉH߄\1JZ PpcTFhkeP2A zn[) &B#vWpE3q;+_xZ*q-')"`pFM_ۼoodm Ea.sVeaSu=ځ{C$;N"qC9OGC3ק"̞@: M+&AD)tC20p̌$9L]O$V9H`ԔPnτPKBaB!@($s%AnQ$ѸU9  Dƨh#pCmX= ufXVսo\eFMjr9,͚c&RUUi٦My#kNg8p;E}4Ws|w$4{.1TFe@[xI$(x *@z&L2´C u1zeJ  5}[Al #YM7xKqĥ!ɲ E5\3`#7hw.1_OqT4iL~A`Co6|]m*K-r1l Q>;^C,y\w`i8n.!"iBXB oZH k -`q >Vx]FMXݾKz#$MS[+ CՏRSUA`+gd(moirMn <9w]8v] qQ:ʼ^2ߚ}CZbl Bia r cJ"MͰ Jm!/R$'Lj_׻KuF?|PIaƷ>[U=}}=A@e "5l>dRȸo׾r`Q̪rX #O.M\^`0Tjz/Te5g Ur"d@nX]\Dfq>E"+8ِj3'B09H7Aahq)K5IIIC-ω%ΈIE+ -1Dbc8]!Ѕm8/Ƃ.H\[P)}9V!,rc8BxAWپWp>a=?,I_=Qs Z=^C*ϲ8N(.3c]#dWR~Yvd |RvS=R ^X֡'qdznx%{ 3`X.1 ModnJbHC[epջh endstream endobj 232 0 obj << /Type /Page /Contents 233 0 R /Resources 231 0 R /MediaBox [0 0 612 792] /Parent 221 0 R >> endobj 231 0 obj << /Font << /F44 5 0 R /F67 136 0 R /F43 4 0 R /F47 6 0 R /F49 7 0 R /F11 8 0 R /F10 10 0 R /F8 9 0 R >> /ProcSet [ /PDF /Text ] >> endobj 236 0 obj << /Length 1491 /Filter /FlateDecode >> stream xڥWK6 ȡ@V8l-mvG1ہtKJc'ζ"@LQ4)~$?%?}s6%+3mvrtΤқ~6QGv+tVoYѩ[/eM?qnVs/-h?ta4[qq+.`'2tW2ϻ_7|JRj=VK nΣ_4P!2cݵ1l楳fvo{;ucFQw{C Դƻѡ,՚d/[0%: skXu(FMc4ݣy/K 8 F/d1dAwH@6ۓȖQ|C0%H 0G㋜sa4Gy(e0_g4^Ai<0zIȏ Nl_'?`c+ =n|ܽMl>|9?xN~X34x%U R<.coyix/d&y-B_"XYE\xɹO}<gw9 O27\aDq[;OXⱷ0 &qoG.pU±2 5]~}sEMX^K]3{GW"$H P%H$9ZD ?0xB$)INnr J[ J&טX#Ј)<),A'eyДA6j=-VN;)A#@`3)U,ȁ ;}8B6{PAaөfo)}kzk4\"K|4i(C%N)V!䢑U"bL}zR{OzYYHo8wMQP2~? `W2G?lfs:_΄Pt$ *Ψ\C?SDO/\;,FDh)kuCdMu_K9F8yO J M&o:`Iݢ+89ᒢ0?6K[v1Ŝc]V"hb2n.MxGOTALw-tJ^LEzU* %QUdrI P)2V鉜C7hɊuzao endstream endobj 235 0 obj << /Type /Page /Contents 236 0 R /Resources 234 0 R /MediaBox [0 0 612 792] /Parent 221 0 R >> endobj 234 0 obj << /Font << /F43 4 0 R /F47 6 0 R /F67 136 0 R /F44 5 0 R >> /ProcSet [ /PDF /Text ] >> endobj 239 0 obj << /Length 2648 /Filter /FlateDecode >> stream xZ[oܸ~ϯ;ybvbuT!i ir=Ɯ6Pѹ;G?F#-\m(Tb#@\Wo1ߛu7B#&'HqVj-M ~sB":`8Ml9Hrv#IF,x@ .'7#bܽeƄFDEx`aU( n@шwaBCADơq _ ^dVhP YJGr*H"~ɢY!cljB. Py`/a[Rd /p6q?M9t&Nmes|m['P[ 2,+.,mWl)r&}3,J8Hsb*`YY (DX7D:1թ7~ӕv[o\:'"g!*;9޴agb0QSs Z nSRh6lR6U[Ż~jPguU69Pw[Y`~YHAs`ҵSw ;y* ~l}j]X*̖k΂7HHs/) y֘bLу&,$7ؔїHsrO~G,vZM[') )̞L"Ƈ,DQOFJ;!3¸g¾ >`RTMV6T-nw:Na a#Vpa*ix̎IQTҲӓk."/p u%culW6Ss7OM XͥDK8_L,DI(ٹjaBnlC˅8taėspQO }R"8M0\E$O7S;3t7qq$4rS(W ~S^.pJ (=cS7E="9UA(mP%yN%+R8n`<0%k=$ڳ\K pp߅'tH`2{_0EuYc}gr$!zn߳`t6y YA!cT̊IuR^:&Sox|@cIc lSPK lD|w;w NP;tLmeYv cɄ!3\;;1)bMBpFb֗"%c|*:pF>t>Զy39h¢JlB/VcI]mIzwcBD˵'JpjF?5kAP[dL<37v[;cpa;x,/`L 8 3S`Q]8 PUi _|sԆHr3MEidC{@c\e8 s0a F?;H.|Pc7 oI('A2 \тd0t~cX=^`4B6<-'>}wvƄq7Bad䣅m;=$ NxFQSw=`ҎKgQȄ-%,|J䮖xu?*=q: endstream endobj 238 0 obj << /Type /Page /Contents 239 0 R /Resources 237 0 R /MediaBox [0 0 612 792] /Parent 240 0 R >> endobj 237 0 obj << /Font << /F44 5 0 R /F47 6 0 R /F43 4 0 R /F49 7 0 R /F11 8 0 R /F8 9 0 R /F10 10 0 R /F7 19 0 R /F9 104 0 R /F13 18 0 R /F14 20 0 R >> /ProcSet [ /PDF /Text ] >> endobj 243 0 obj << /Length 1717 /Filter /FlateDecode >> stream xڥn7С 2|--n(CQ$D[HZevrf_1Pƒ_ԯ7o?hXfYB)f[2zDr7m+LY|ׄmpx]ǥbĈtyݖծ8{+@췍!7{-OuSQ[: _6_$B,%}YxJd0[7 rSa%SP(O Vhzر¹*7&%‹z{̹;}ؑ7@lə!?%= hʎ3O6i+ 0P?0wsE,RL@t9 vwEts &&;9٩(oұKJ\6U] ~7f7G^ÙJ~' kds|tO#Ϙtj7XAH섏!>I{}QW,L3zV+d\# |c_L]M9>|8OȲLy>z&>#y%I3sfʑWKH5)ik^J:s).Kv1%J+ /?@ɋM){U~;R"36C55D-?cۗIP8|56S%ʡ!@댳A "p)læ-:ŗaº3"тNON^?0>6kO%ƃ+;Q(I2W+yl0fGHTP]_:2HX6(&`,4jV!=.GM )6\q"b4ȧ]oOl*_XɈl;\o4efD|V'L:Qȋۡ 'euf?a1; &9 pU5&?i#Oc";L4( B苘~ ʁ6BU*c vb8J_Cow6.c;}& 4MhIP]u)n**]cwXZfv5~>(hxP6@kVˮ=EIF @1P'ͧct_$L).IaDzIiSȤ6i:!!]Yb`cԈ$j1BBf6xuI։ 4 w*띘 A_;& [b.Ln^?It['7L<({ endstream endobj 242 0 obj << /Type /Page /Contents 243 0 R /Resources 241 0 R /MediaBox [0 0 612 792] /Parent 240 0 R >> endobj 241 0 obj << /Font << /F43 4 0 R /F67 136 0 R /F44 5 0 R /F47 6 0 R /F84 220 0 R /F49 7 0 R /F11 8 0 R /F8 9 0 R /F1 21 0 R /F14 20 0 R /F7 19 0 R >> /ProcSet [ /PDF /Text ] >> endobj 246 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х> endobj 244 0 obj << /Font << /F43 4 0 R /F8 9 0 R /F11 8 0 R /F7 19 0 R /F44 5 0 R /F67 136 0 R /F10 10 0 R /F6 67 0 R /F9 104 0 R /F13 18 0 R /F12 108 0 R /F1 21 0 R /F49 7 0 R /F47 6 0 R >> /ProcSet [ /PDF /Text ] >> endobj 249 0 obj << /Length 2829 /Filter /FlateDecode >> 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 248 0 obj << /Type /Page /Contents 249 0 R /Resources 247 0 R /MediaBox [0 0 612 792] /Parent 240 0 R >> endobj 247 0 obj << /Font << /F43 4 0 R /F11 8 0 R /F7 19 0 R /F10 10 0 R /F14 20 0 R /F8 9 0 R /F44 5 0 R /F67 136 0 R /F47 6 0 R >> /ProcSet [ /PDF /Text ] >> endobj 252 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 251 0 obj << /Type /Page /Contents 252 0 R /Resources 250 0 R /MediaBox [0 0 612 792] /Parent 240 0 R >> endobj 250 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F47 6 0 R /F7 19 0 R /F49 7 0 R /F11 8 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 255 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 254 0 obj << /Type /Page /Contents 255 0 R /Resources 253 0 R /MediaBox [0 0 612 792] /Parent 240 0 R >> endobj 253 0 obj << /Font << /F44 5 0 R /F67 136 0 R /F43 4 0 R /F49 7 0 R /F7 19 0 R /F11 8 0 R /F10 10 0 R >> /ProcSet [ /PDF /Text ] >> endobj 259 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 258 0 obj << /Type /Page /Contents 259 0 R /Resources 257 0 R /MediaBox [0 0 612 792] /Parent 260 0 R >> endobj 257 0 obj << /Font << /F67 136 0 R /F43 4 0 R /F7 19 0 R >> /ProcSet [ /PDF /Text ] >> endobj 263 0 obj << /Length 1371 /Filter /FlateDecode >> stream xڍWK6 ﯘX+zX~4l_@ dnM[cc'~l%Ec:`LQ$'q;,ri+/w_8K֙Yݦ'=ͻߺ6^p$He;vB)NIT2iFZ3{'gqSD_3Iu'g[֧}IRecĹ,AQ_6KjԚ%9\r8?!\^+̩WĨ{Кy몲-Є Os~.4hNpxxh_Zg}-G*|}*YJN.n{sB!Fރc%i,;Ha^h$>vޗ6޺0ZK3H,a/l}($a:H.9 vÑotlY)քC,DҢ"琮 G2?)*zh2qE1Bp9u ۦ/GVx(fB<М 迶heze]w~& 61f#e ˘p=ةí-0yf@2 ( ؙX ! O kexHB2=PK0Fh³ 3n+*ȺWܕMN" R󻣟 ~NKC:~-|⚛ 0ҧhxW8n.<{vfaPYxoͧdX,P4+Sͦ7giU֌gIK& [1D,z{Ӊm}>,"ixm}=.P%͗Xg/$byO+y|T,i= rjau2y?-݈|lJGS\6 ݒVHh\vp5HQ&c̷GƠW0q}gS <$q5t 8!ɣ]d*F;wSSx@(*:$mMuiwSҴ endstream endobj 262 0 obj << /Type /Page /Contents 263 0 R /Resources 261 0 R /MediaBox [0 0 612 792] /Parent 260 0 R >> endobj 256 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figures/fev_viterbi.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 264 0 R /BBox [0 0 504 504] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 265 0 R>> /ExtGState << >>/ColorSpace << /sRGB 266 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,> endobj 265 0 obj << /Type /Font /Subtype /Type1 /Name /F2 /BaseFont /Helvetica /Encoding 267 0 R >> endobj 266 0 obj [/ICCBased 268 0 R] endobj 267 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 268 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 261 0 obj << /Font << /F47 6 0 R /F43 4 0 R /F44 5 0 R /F8 9 0 R /F11 8 0 R /F67 136 0 R >> /XObject << /Im21 256 0 R >> /ProcSet [ /PDF /Text ] >> endobj 271 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 270 0 obj << /Type /Page /Contents 271 0 R /Resources 269 0 R /MediaBox [0 0 612 792] /Parent 260 0 R >> endobj 269 0 obj << /Font << /F67 136 0 R /F47 6 0 R /F43 4 0 R /F49 7 0 R /F44 5 0 R >> /ProcSet [ /PDF /Text ] >> endobj 274 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> endobj 272 0 obj << /Font << /F43 4 0 R /F44 5 0 R /F67 136 0 R >> /ProcSet [ /PDF /Text ] >> endobj 277 0 obj << /Length 242 /Filter /FlateDecode >> 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 276 0 obj << /Type /Page /Contents 277 0 R /Resources 275 0 R /MediaBox [0 0 612 792] /Parent 260 0 R >> endobj 275 0 obj << /Font << /F43 4 0 R /F44 5 0 R >> /ProcSet [ /PDF /Text ] >> endobj 280 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 279 0 obj << /Type /Page /Contents 280 0 R /Resources 278 0 R /MediaBox [0 0 612 792] /Parent 260 0 R >> endobj 278 0 obj << /Font << /F47 6 0 R /F84 220 0 R /F43 4 0 R /F44 5 0 R /F67 136 0 R /F90 281 0 R /F11 8 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 284 0 obj << /Length 2410 /Filter /FlateDecode >> stream xڭXߏ۸~_oI沷mren,}iY I3gủW)Ixd:*eBo'b"[[tUr-4JXLhMk~/*K!42$lHPV|E/G_R3vZ[:M=M*Z/ .5;!x3𷤔l7]N[SU辩WM7 L]-9gV\3,f[jt2}OVBڴv^ilE7Be*SiPo`naMoݟ>#= !hӬlQi*;k:tѶmI+*q, mJ3w񚡭MEkTّB ,@@~&g|l;?wf!&4Z8:Iz0nAW?N./YEdѴkkz!AayDiW)h0ӅԐe~Y·ȇcN|:sn#7zW3_);U@\ĕG!PS(ŵԜ^i9ksf2qQx-=teihRƕ>c"1Iўԣ9>RujM?Jzng%d;H ¶'f* \> 3Z. }E~Xv6]w%DE+ɸN-*dL!!!U NyCfސ7l(qR%nG  UX@ӦrZ'ݷ,#LɴN`yWޢGHwa? F 0Bc=5L.֦t;Q ܭ"{!:S'a`r0@wc!:OBk:C~N6XT@l|* WgHl>r@@<ՇdvJex ƴ*O{U8i19=<=c3Q|EꢒǨ$4,#c0k[v(wͰ3׾ +_2Me^(W^ endstream endobj 283 0 obj << /Type /Page /Contents 284 0 R /Resources 282 0 R /MediaBox [0 0 612 792] /Parent 285 0 R >> endobj 282 0 obj << /Font << /F47 6 0 R /F43 4 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 288 0 obj << /Length 2503 /Filter /FlateDecode >> stream xڭXr8+b6 /8iWL4X(K8\\hٓE8o_^Ƀ",R\? 4?H,29'( dzpv(8dڛjwEp6z'^.eYi\eoT׭^.M}˯ߛ7{֭kڎ_FUYWC]8L0"qgXN]l: 1/o~5Fwbj~1Jf( U"F!/:SXhH/nKyՁTpjsZ1&6i4hus[TQ(G߿"_Bm`(, %jڤ8ߪDH-W7:wGmvD{?$ƜPOY9N`B67尢=Ex!!+tIWg՟AJ]=nǰi 0qI(^?נ}E ClL[qfE_$"8I9I*Gtd:GNuHvYP]+o2fq*Z+ $D9) $şfe:inpRO@Fs5@s2춍@KmZFhhhϔ{zVGp5u;?Eiާd$,r5Mд)S%2h)rJ=n{YE}+A3T<.%N< }˦5tq ,6,,HQE",4"| d7"@/lsufhu9P2t]Xg*j4MZ3xMq/BQlS2t.B},,`61.jzV Dk={Rno!ĹGxTulEJd>̓ V@"bBq S)<" E"w H/?詌)D^2+ɕ_CL_PћfSNqY9 $nt;IƯ)*?AxM XD W^t~Փ(+_ߍᴴ,s y3B9‚ _Z#B(MEnWAm;MvuT_(;[ԨxگHB> endobj 286 0 obj << /Font << /F43 4 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 291 0 obj << /Length 1064 /Filter /FlateDecode >> stream xڭVMs(W(UXr&I%Uw0LELy|·{ً4 4nu5P͗3\UaG"?ev.P^gw+n6eK(+xZ%z1͸kaWr\ev;o9~.hfw[:6k² 8m_Ffƨ*/|:F+nA*GDpf}2eᴱɡM46Nܸfʥ%RG2=SG.fh|p׽஢uef&`2NjֽU<2k}I~)k{BkI$eY ER N-0lH`a+a(=ښfsL =:_b :'ȪpA^ k ,˒ŀlz$8@\bj6 LSA0 da hqᦙ@yͦdFr!8RKQ6oX"]`w!2DaH=gܗUՀ\*I^\7ۤn%nq:Vj8X=ȇQ@fdvtjĊR^r)( Ъ:MZD1{[tOyj4mɾWPipUpr+'^/]ɾhG,| }Uv=&{Uv¾&oώa,#\M@%;6:uI46'C AQ=䂧]:>@hblnWq!T$(S?iczyy!y?H:Izz*zj~Jhx~SËCRVz]'_ǚ\jQƕs'ő endstream endobj 290 0 obj << /Type /Page /Contents 291 0 R /Resources 289 0 R /MediaBox [0 0 612 792] /Parent 285 0 R >> endobj 289 0 obj << /Font << /F43 4 0 R /F49 7 0 R >> /ProcSet [ /PDF /Text ] >> endobj 293 0 obj [667 778 722 667 611 722 667 944 667 667 611 278 278 278 469 556 222 556 556 500 556 556 278 556 556 222 222 500 222 833 556 556 556 556 333 500] endobj 294 0 obj [778 556 500 500 500 389 389] endobj 295 0 obj [600 600 600 600 600 600 600 600 600 600 600 600] endobj 296 0 obj [600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600] endobj 297 0 obj [575] endobj 298 0 obj [1083.3 458.3 1083.3 736.1 1083.3 736.1 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1361.1 736.1 736.1 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1083.3 1361.1 1361.1 1083.3 1083.3 1361.1 1361.1 736.1 736.1 1361.1 1361.1 1361.1 1083.3 1361.1 1361.1 875 875 1361.1 1361.1 1361.1 1083.3 441 1361.1] endobj 299 0 obj [613.5 666.7 743.8 677.1 549.8 827.6 840.3 849.8 712 666.7 831.1 726 815.2 681.6 791.7 841.7 864.6 930.6 886.4 674.7 855.3 1144.8 726 578.1 918.1 1361.1 1361.1 1361.1 1361.1 458.3 458.3 736.1 736.1 736.1 736.1 736.1 736.1 736.1 736.1 736.1 736.1 736.1 736.1 458.3 458.3 1083.3 736.1 1083.3 736.1 749 1036.1 1037 996 1109.9 1007 867.4 1064 1110.4 626.7 772.9 1138.9 955.6 1284 1075.7 1047.5 875.4 1082.2 1030 856.3 832.3 943.9 827.8 1279.2 1112.9 824.3 943.1 597.2 597.2 597.2 1361.1 1361.1 597.2 774.4 633.3 649.4 739.7 677 684 700.6 827.6 533.6 588.2 758.1 480.3 1228 880.8 702.8 739.7 658.9 671.3 670.1 563.7 846.1 722.2 1009 791.7] endobj 300 0 obj [830.6 1097.2 1027.8 911.1 888.9 980.6 958.3 1027.8 958.3 1027.8 958.3 680.6 680.6 402.8 402.8 645.8 402.8 437.5 680.6 680.6 680.6 680.6 680.6 980.6 611.1 680.6 958.3 1027.8 680.6 1177.8 1316.7 1027.8 402.8 402.8 680.6 1097.2 680.6 1097.2 1027.8 402.8 541.7 541.7 680.6 1027.8 402.8 472.2 402.8 680.6 680.6 680.6 680.6 680.6 680.6 680.6 680.6 680.6 680.6 680.6 402.8 402.8 1027.8 1027.8] endobj 301 0 obj [458.3 458.3 416.7 416.7 472.2 472.2 472.2 472.2 583.3 583.3 472.2 472.2 333.3 555.6 577.8 577.8 597.2 597.2 736.1 736.1 527.8 527.8 583.3 583.3 583.3 583.3 750 750 750 750 1044.4 1044.4 791.7 791.7 583.3 583.3 638.9 638.9 638.9 638.9 805.6 805.6 805.6 805.6 1277.8 1277.8 811.1 811.1 875 875 666.7 666.7 666.7 666.7 666.7 666.7 888.9 888.9 888.9 888.9 888.9 888.9 888.9 666.7 875 875 875 875 611.1 611.1 833.3 1111.1 472.2 555.6 1111.1 1511.1 1111.1 1511.1 1111.1 1511.1 1055.6 944.5 472.2 833.3 833.3 833.3 833.3 833.3 1444.5 1277.8 555.6 1111.1 1111.1 1111.1 1111.1 1111.1 944.5 1277.8 555.6 1000 1444.5 555.6 1000 1444.5 472.2 472.2 527.8 527.8 527.8 527.8 666.7 666.7 1000] endobj 302 0 obj [777.8 277.8 777.8 500 777.8 500 777.8 777.8 777.8 777.8 777.8 777.8 777.8 1000 500 500 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 1000 1000 777.8 777.8 1000 1000 500 500 1000 1000 1000 777.8 1000 1000 611.1 611.1 1000 1000 1000 777.8 275 1000 666.7 666.7 888.9 888.9 0 0 555.6 555.6 666.7 500 722.2 722.2 777.8 777.8 611.1 798.5 656.8 526.5 771.4 527.8 718.7 594.9 844.5 544.5 677.8 762 689.7 1200.9 820.5 796.1 695.6 816.7 847.5 605.6 544.6 625.8 612.8 987.8 713.3 668.3 724.7 666.7 666.7 666.7 666.7 666.7 611.1 611.1 444.4 444.4 444.4 444.4 500 500 388.9 388.9 277.8] endobj 303 0 obj [706.4 938.5 877 781.8 754 843.3 815.5 877 815.5 877 815.5 677.6 646.8 646.8 970.2 970.2 323.4 354.2 569.5 569.5 569.5 569.5 569.5 843.3 507.9 569.5 815.5 877 569.5 1013.9 1136.9 877 323.4 323.4 569.5 938.5 569.5 938.5 877 323.4 446.4 446.4 569.5 877 323.4 384.9 323.4 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 323.4 323.4 323.4 877 538.7 538.7 877 843.3 798.6 815.5 860.1 767.9 737.1 883.9 843.3 412.7 583.3 874 706.4 1027.8 843.3 877 767.9 877 829.4 631 815.5 843.3 843.3 1150.8 843.3 843.3 692.5 323.4 569.5 323.4 569.5 323.4 323.4 569.5 631 507.9 631 507.9 354.2 569.5 631 323.4 354.2 600.2 323.4 938.5 631 569.5 631 600.2 446.4 452.6 446.4 631 600.2 815.5 600.2] endobj 304 0 obj [892.9 339.3 892.9 585.3 892.9 585.3 892.9 892.9 892.9 892.9 892.9 892.9 892.9 1138.9 585.3 585.3 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 1138.9 1138.9 892.9 892.9 1138.9 1138.9 585.3 585.3 1138.9 1138.9 1138.9 892.9 1138.9 1138.9 708.3 708.3 1138.9 1138.9 1138.9 892.9 329.4 1138.9 769.8 769.8 1015.9 1015.9 0 0 646.8 646.8 769.8 585.3 831.4 831.4 892.9 892.9 708.3 917.6 753.4 620.2 889.5 616.1 818.4 688.5 978.7 646.5 782.2 871.7 791.7 1342.7 935.6 905.8 809.2 935.9 981 702.2 647.8 717.8 719.9 1135.1 818.9 764.4 823.1 769.8 769.8 769.8 769.8 769.8 708.3 708.3 523.8 523.8 523.8 523.8 585.3 585.3 462.3 462.3 339.3 585.3 585.3 708.3 585.3 339.3 938.5] endobj 305 0 obj [519.3 476.1 519.8 588.6 544.1 422.8 668.8 677.6 694.6 572.8 519.8 668 592.7 662 526.8 632.9 686.9 713.8 756 719.7 539.7 689.9 950 592.7 439.2 751.4 1138.9 1138.9 1138.9 1138.9 339.3 339.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 339.3 339.3 892.9 585.3 892.9 585.3 610.1 859.1 863.2 819.4 934.1 838.7 724.5 889.4 935.6 506.3 632 959.9 783.7 1089.4 904.9 868.9 727.3 899.7 860.6 701.5 674.8 778.2 674.6 1074.4 936.9 671.5 778.4 462.3 462.3 462.3 1138.9 1138.9 478.2 619.7 502.4 510.5 594.7 542 557.1 557.3 668.8 404.2 472.7 607.3 361.3 1013.7 706.2 563.9 588.9 523.6 530.4 539.2 431.6 675.4 571.4 826.4 647.8] endobj 306 0 obj [500 750 444.4 500 722.2 777.8 500 902.8 1013.9 777.8 277.8 277.8 500 833.3 500 833.3 777.8 277.8 388.9 388.9 500 777.8 277.8 333.3 277.8 500 500 500 500 500 500 500 500 500 500 500 277.8 277.8 277.8 777.8 472.2 472.2 777.8 750 708.3 722.2 763.9 680.6 652.8 784.7 750 361.1 513.9 777.8 625 916.7 750 777.8 680.6 777.8 736.1 555.6 722.2 750 750 1027.8 750 750 611.1 277.8 500 277.8 500 277.8 277.8 500 555.6 444.4 555.6 444.4 305.6 500 555.6 277.8 305.6 527.8 277.8 833.3 555.6 500 555.6 527.8 391.7 394.4 388.9 555.6 527.8 722.2 527.8] endobj 307 0 obj [639.7 565.6 517.7 444.4 405.9 437.5 496.5 469.4 353.9 576.2 583.3 602.6 494 437.5 570 517 571.4 437.2 540.3 595.8 625.7 651.4 622.5 466.3 591.4 828.1 517 362.8 654.2 1000 1000 1000 1000 277.8 277.8 500 500 500 500 500 500 500 500 500 500 500 500 277.8 277.8 777.8 500 777.8 500 530.9 750 758.5 714.7 827.9 738.2 643.1 786.3 831.3 439.6 554.5 849.3 680.6 970.1 803.5 762.8 642 790.6 759.3 613.2 584.4 682.8 583.3 944.4 828.5 580.6 682.6 388.9 388.9 388.9 1000 1000 416.7 528.6 429.2 432.8 520.5 465.6 489.6 477 576.2 344.5 411.8 520.6 298.4 878 600.2 484.7 503.1 446.4 451.2 468.8 361.1 572.5 484.7 715.9 571.5 490.3 465.1] endobj 308 0 obj [500 500 167 333 556 278 333 333 0 333 675 0 556 389 333 278 0 0 0 0 0 0 0 0 0 0 0 0 333 214 250 333 420 500 500 833 778 333 333 333 500 675 250 333 250 278 500 500 500 500 500 500 500 500 500 500 333 333 675 675 675 500 920 611 611 667 722 611 611 722 722 333 444 667 556 833 667 722 611 722 611 500 556 722 611 833 611 556 556 389 278 389 422 500 333 500 500 444 500 444 278 500 500 278 278 444 278 722 500 500 500 500 389 389 278 500 444 667 444 444 389] endobj 309 0 obj [556 556 167 333 667 278 333 333 0 333 570 0 667 444 333 278 0 0 0 0 0 0 0 0 0 0 0 0 333 278 250 333 555 500 500 1000 833 333 333 333 500 570 250 333 250 278 500 500 500 500 500 500 500 500 500 500 333 333 570 570 570 500 930 722 667 722 722 667 611 778 778 389 500 778 667 944 722 778 611 778 722 556 667 722 722 1000 722 722 667 333 278 333 581 500 333 500 556 444 556 444 333 500 556 278 333 556 278 833 556 500 556 556 444 389 333 556 500 722 500 500 444] endobj 310 0 obj [600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 0 0 0 600 600 600 600 600 600 600 600 600 600 600 0 0 0 0 0 0 600 600] endobj 311 0 obj [556 556 167 333 611 278 333 333 0 333 564 0 611 444 333 278 0 0 0 0 0 0 0 0 0 0 0 0 333 180 250 333 408 500 500 833 778 333 333 333 500 564 250 333 250 278 500 500 500 500 500 500 500 500 500 500 278 278 564 564 564 444 921 722 667 667 722 611 556 722 722 333 389 722 611 889 722 722 556 722 667 556 611 722 722 944 722 722 611 333 278 333 469 500 333 444 500 444 500 444 333 500 500 278 278 500 278 778 500 500 500 500 333 389 278 500 500 722 500 500 444 480 200 480 541 0 0 0 333 500 444 1000 500 500 333 1000 556 333 889 0 0 0 0 0 0 444 444 350 500 1000 333 980 389 333 722 0 0 722 0 333 500 500 500 500 200 500 333 760 276 500 564 333 760 333 400 564 300 300 333 500 453 250 333 300 310 500 750 750 750 444 722 722 722 722 722 722 889 667 611 611 611 611 333 333 333 333 722 722 722 722 722 722 722 564 722 722 722 722 722 722 556 500 444 444 444 444 444 444 667 444 444 444 444 444 278 278 278 278 500 500 500 500 500 500 500 564 500 500 500 500 500] endobj 312 0 obj << /Length1 1393 /Length2 5949 /Length3 0 /Length 6889 /Filter /FlateDecode >> stream xڍt4]6FA7BtktØafkD aD= z-H!zI<>}kֺ眽`50WrB:@Ց XPS`,Laۉ8̠(4  l Dp@Ha0Xo % B|`ND@D*HOr$~JP W##aP?Rpɺb0҂"0 E@_}5"atBPPg4.Eꀱ.p s9п qtDzxB0 C;? A8Bh$.!8Cu%CcĠ0/Y ᤂ"0h_S{\wprESjLD@1 ^UWOo/3CP'pр?4 `PРtsG$$81 wvOke0'$o *iSC_Nee/& !!qQ@g[ ?Zg$  Mdp 7 HqnQ/:&?gn"_b<;$ O j6>$ZVІ S5KE c/D$<S&\)٣@38Y2t*g6.V1ܥ 5֌% `Rx~Ur7K)]oz;_5#VR;62!Iѕ d1^ r2y.>̹S6g2b;.g?K2ק_ 1OD?WuTqqD@?xj6V,a.L屼Z{2t d͒&olKARW`7k,8VqżPc Wb{&_IrGEPm4BThPg+zIy+3 #n!VW'U6_= 7zI/SxÀ=cE›_%7~]ʷr#!'Blv| I2< &NR!§!T 59_H$|b4dKL΍=p#{#=jV`ϺRmJ, v hRו +o~spoU"&_Z&g)anw!X8>90BLglJ&1ﴔv}a0 幆vq8 æi ߶tQ[7xEw˽E:T%z[\Lo}xtOvKTfFp\J=Ծ^uB ՝7).=³ ch$~yZ~]jC Z)#G+y0 4$<([kw}x1`%GU z0Ra!;n?㬒l|\8lb K+|-VygzK"f0U5.QoJN_ۖٽl~J6&ˆzxuN6_KvW2)BM@%!ZK9ZUR7D?E#ɬj]gSnw XfS _E̶CwG#I=_ƞY:^kٚ#iH#1.YG8ko=czKE3c:[Y fm-rz..uO=q5upEE F{kM!;)QDoF㪳5z' .Y?SFm*pT-ZqI$JЄ+pY:ʙ__]ŋF;|R l'LA~7+bgЦ`Kbyib Ҷ=B_(?Z)-֊"s';O7 bHޜ,Oh aV vf|"ǭ\+ueW)K^fJqyojKc}>R>q@Hr3fn-8tOe])7`vx+pZty>=+&fMGv{ ѶVPjr2iZhp`$z|4P0ymg,}v6"%Oé0be ")r,q>LWD>hetR^V,LTk?늻{2-#Irq\e$NhS#= +Oh׋:qQ,ǯ0`?l{$͈2䆎P٪m!ϚG)W9뮾 ㋜wuY #z؊51>.S<ӣQ{X9oO'^ q+/Xs3h, /so2|#Q<8jd]%myXd -ay|Rb;VÑIv q=2 $lFL<˲qbiYz̅HF)x+]o i+xj^^S)KN-f1AΤ$HV_-|FUbZcgϏO5z?xF4cT.䲮 (4A0DMWn'71KFf^I@i& 8v*vz`&BܜI':zE֋l-Tttŋ+7{}5ir_C.0_I'kEL6|\$i8WHI2u#ϾAtR)Nˑz=;68-+#nC~Fޤh[Vo_JmX0~ARQW}[TO{,}Zan}q0%/'a}T-_9sZxN@t+Gq 0C;īq\FJ)[=-Zژ:[<#IO?ZOet+AiQjДڍHKfI #If ltmOvb-HgN\/\%^VR}h7~![Z4^K0wKlq"Tk_# 4"`SlAQ8?fHZ#jvm,?vJ`䗢v8Sg?Oq3' |K4BG2*0nyIݭӧ'%* |(1T{3Cc_bzSG<_:R^7eZ")ވoYRLR _1֛|asT5Q|(_u+!+i-2#|2$!jY?8}B(v]k؄lVC*QP"2'ΨgS+=8^Gc@?;3J?C#jo<) outU .?"Z+q>'A<% N&CﹱEEsR/`4Xj(Ns*`f@'zh%u9 s$H \t/yQACcd~g6kuCCܿdZ⫬Ec`c >AW8NH?_,PZb;H#wlJ>lwtohܚ8vrɷ2cJҍ_ 4[n?؞*)A[XS4 og='\/B:-ٕjs{P/yr#b:oNʈ.h_}v8Usz|;hR -/v.%*haZ >l,`wzj< ٬;~;Mɓz:Z- L /6AVm :Ei{řRݘ＜R[ymN(BЧYY"9wK3nLCD__.Ru&]t9& md? ;'y=[OQRj9<;ckM6ς;^ seXsTDzd7^8V;QR*FMJML𹲸Ytlf8jZپ^G tgsJxEk3||vuk~n Ǩ֣Ŵ7x-;lb|} mj$k:5xd)ԽF "-̦*T,3]Z6Μ|='-Z vXѾROB[Ұ9Of>lчrMe>3::ޔec33Ѩ65mA+T53#Sg;6ޟY&arYhձk)}սo4BatVZJ7VU*SoQ"5nSu7uYyGO# _wkq谊X|}KEkc*G[:f"xe*TVJo'GK8W2z~DRJuMKn$0+ǎssBW~]ZphY%"me^^-aW OHe gZ̲soۍktw.܎ާM_A(6g.fWu^&#iČ5Iu8I&K׿;v0\*#̩򻪅.ۛL}{)C.<6D&?ƾB{G'9EWOɡU*-RB̝fĴG6g#Go]tVc_^ :yR|qj-z"[Z+ƞ0@RXvwޥ@1pf ~1I뻈 c!oH6Nt*ĵ_OzvYJ#ޤ`j(ȸaHo@z]7YcГ)'3[}[i-`t<;EOg61Eh¼/^4[6Lɲ}m\@t۟'/{G "j';O 9s*C+ ְN5עʓxQkiݡ:iɖq_+ji~(kSZ@&#oٞEy֣Ìv{c4L$0%VZ6.[5ux[iL40'E endstream endobj 313 0 obj << /Type /FontDescriptor /FontName /UAGOMC+CMBX10 /Flags 4 /FontBBox [-56 -250 1164 750] /Ascent 694 /CapHeight 686 /Descent -194 /ItalicAngle 0 /StemV 114 /XHeight 444 /CharSet (/one) /FontFile 312 0 R >> endobj 314 0 obj << /Length1 1929 /Length2 8985 /Length3 0 /Length 10123 /Filter /FlateDecode >> stream xڍTJwRҝ5  1C !RJ ! H HKKE׺wZ3~70irH 0([ .o bdԃX`7w *{CursxE6䀞:'@c1\| v<?X@!_igԁp{}F Ap`]D807; Vvn<6@goiX={_.t' uwڀjM0/c 'o _@@v[ P@'wؽ?qZ: +qsC~jPY3 w?9t_w߇yA^B6?expC!`e6ֿ]`o=z>._$O^C `{/`=8O+, X P`ۿr߷'A|5u\J*FFl%C~^An?@H@oP-  DRq_xn s o }C,7rkQ?wg@go:~Dkjk6e!9SHlꣿ> ւC~9nxߟ/ |?UM)l~ ?~Nm޿ ]07g* vf/L7[CyK~߇?͟E#ݷ( dqwq_98>.7C3:x~G0Gr??'؟yK9Rf߮)#?uO<A` $PFȓό~nm?XCΥ YΤhovߠG<~wmTgl(Y]>jL*=MWGf|Wa<߽z?FNmhoV b_s$ǛL0XLӣ91yO&tG +`/d7rwB׽ 951&?t~Kt.wz!pGlf2M-ϷaS*A=w0GƑXH7݇g6TȑLfz~ ΃V4yP>ӾB|}9dL2*`B좑[ϫn/HB*x \&HC?,Tl7d6T\ \tqD=>VX![T "]ba"zZJF]K?Tӗ߃i BM³D-)Om2#%#J"N\nByCӚW誸፦f)K @8l>j]zyBL+>П-5`RC /ZtWg2Ú2}]vφ9X#Z:w'߯Dm]uսk%ygB)fHALdk'B %kre*moҭCOM%]d}Ҙg〟Y+X,/ٖv<໸㗿F ;[a|"W4ZWAStiqRNOn¶%\Ȱ;Ounq= ,R9"y:;Q+ R]S/ْZ^7~̭rF78(ɪzfh`oϤsWI4кͼ&H=XdXdF>zl c,Ak]Nh ~U?#u`+^E^45P0IzQFyzպ@H3F̈jP*JtR2̃.=5{l2':0\ń!GJ"^cK+[:6Uؿ,??`b5&@=ĜZ*aR,DG ?E$$ύNkdWMIZ16F݆0sOL_9X¸JleILC)xGv)}{ r+%"LH(,j 6ZɚPT[!1%og1I^jt0:]5L 3Y=]Q6//c~t\N1JWx òtA5Gr;v<$+d .6ᓪU㜶P$JlO_k*#cڻDmw-{OAleVJ$ltvkNb#͸ /<1C2ΫFN xؒf@.wUg%)ZYؿaH] ٞɄَ=u"S->2桒u1?[-Zz9"[C<-̐ S/:#zb;VtcZ( BE.gB#5FY/zA[OhI`uRu2wcX{"D4~ QU/̽rϲdrӘ \]GRK<)9g304]{e;H }K2,(a[c>T5:̿ڊf$ YXä/k(5m :graOPy DH?C:&gDNm vJ`P h3c ƣ]jr?q&\[7qu7G:zaŢvh6:rSވ\K*%hoP9"شG^zu oA(Qh2dj5|蔬 -ϸ~81*^OO\nwfue%8Ś![ qd>d.͌pSGJ/ g.XμT.Z`4-"n4D<\@0kq#XS ,Z2p:@ pFSxsBǓ͎$ߧ ƕf}y^y[hIL-Vl~U͡E=2 [QԱKS_͙fZ-85/Q.:6 -V)ih$؍]o!i`/p"*L}=kr*趲%:Qanxf7Y֖]X}z1jDMa#ӎQ 3ߚ#?lXߤ;KJ3ײO|15Z>C5p͘F=8<]XF3#w<]p]ǿB|ugٔn;Lмt;*XCM"][0pv{ژ┈,'3Xc#g'd?N#EbO6TDt.n#g,ŗ]dFlY(SqԪ͌BS&gh 5VDRnI"d=7U fDO֌F](9eq XyS|c!}j"VjnNVZ&/\J:} Zڒh `T9 <3/`#8$@DxZ[h>s߿,X}7g ɩw|HEPZz!nUeKqse̪_p/ c {=-wPԒڭa c!r JFLo{|= úï, Z2{&1V%]f9iz|XxmÝƽZ1[Y17$+7VFOJ wwKKR h4M_cjMP3zgI /u>{ W<кbiKb{V; :y|#A,cp!4 d hϗshf|oc}3ƓcH0BYܯx}-YA?bQ:he])"\B s_ 6h樢_jpJHx-;i'L[[q ]O},$ %^SvތL_{^n)#5chPdiOH!Z5@p6] 1CR[a` 1d ;[6nCB$cL*W;GIL28Y-H#Bl^U߸c{iBfqظȢBbK[VEXmkV@L:H܊ެt -6 ˤ8zzI)^e'$v*Oz}kU):8Y; &\Xtȴn}%Sgaa內ܢO\Lse?40fbjt.M3͵0=(t=1qr|A 6a{OCܗ;)vy30#R95w3!†$\i8ΚZWt%#>PvejoY"P("-pջe: }L3G?MB,gA‡_lE5[q9#Gᦊ/=5C_z!TLF3|.5>3ZŸug2J0q|߳yeL~ԙw+hmGu.hl(W;X:( "teFq$.Zꤷ~gIP=>(z}c̷\$B^֍Tt‰8v"lJJ0/k}s cR'z3\ VX*%,(v ^:9VdR?Gqm0e4>cœWMN38ˀ'TKJ_J1p&Ee,:_=qkPsFL̸$PZlza ~LuuyCsGF]_y.wbؚ}v! b7O彉oz4ooU 9!lh ԨF^2br:ob&t.Q_.@Xjx+&[)((;~~>栱4ٷ Dz%SJ]ҕe r~_F=0B_+{(zCalEj}Ah1a&kh- uE!Kj/t$L %y#o^[Z!g},:nU,;;\!NKS`m˅ G l8%<' )7 \ΐ^]fT 'vr? Lpݺ,!tTŰkҧD1!H`fZRA gǮl+}&iObG7"b\ٹ/dbG7b TtZƱ-m lKwT/,9u20UEv(^k̵GZЦ:-S1?'ͱ*A/`y~m'3kKj[)v(UJaG 4 zJ&;YHޕmץ$߸+Oi#Yςo@X[gw ퟕ?ˣ}E7an3B#9}+q TH,fD1M)pu gw$s}>ъǴHMlu^d-$9U]RwBɼ "Ub4A%6݇ @~牃gGlwxmzcFj3f0: (Ӛaa1v=ypkZ/H|P0)BwSh9?^A"=Yڻ#Pǻ#V͎vbpP5%xM 9t~MD.;[~#1L\{V k|#r]_T&/imzhg:' (_qWu"VŢ97xF Q2ER &T 9 1rx&n9$oL&U(1[r>oUlID3/J)HbdU Z|˺1mkdW`] wL} KmWeZr?(9>X4F33ZιM 91S"ZeABdmAGA߶ana~R+E.rMn T 3jHv`baX{{kt{7H'ޜQ5 yG{hUA:S}iӀ@|cKu A*Svg2 8[)=szTȏ2O#J Oί^g x U)XX ݴI S&þ)`S6iR1$Ǽ[|KwL⅙9}2a+EcKz -|ݨyL3)Pn)o[C<5E>նSz.!)'LܼAur4[YpҖƤZzSň0L>SB*`߻F+ `eO0_)bZ5,JJ(m }f m endstream endobj 315 0 obj << /Type /FontDescriptor /FontName /YHJIXX+CMEX10 /Flags 4 /FontBBox [-24 -2960 1454 772] /Ascent 40 /CapHeight 0 /Descent -600 /ItalicAngle 0 /StemV 47 /XHeight 431 /CharSet (/braceex/braceleftbig/braceleftbigg/braceleftbt/braceleftmid/bracelefttp/bracerightbig/integraldisplay/integraltext/parenleftbig/parenleftbigg/parenleftbt/parenleftex/parenlefttp/parenrightbig/parenrightbigg/parenrightbt/parenrightex/parenrighttp/radicalbig/summationdisplay/summationtext) /FontFile 314 0 R >> endobj 316 0 obj << /Length1 2191 /Length2 16820 /Length3 0 /Length 18126 /Filter /FlateDecode >> stream xڌP[ӆ < !>Xpwwww`=@p!8_y:z{y(HTM@F ;gzf&43B?v SG'K@wQdb`f0s0s01Xr],M (=>ܜtoۚ:Z@g S@*BPY8;022m@tWKg /鿥1 P,, 2sv: 6ƦvN[ؙ:޳Tvr߇`f`o+ߛ [{9(!Lڙq-mFH+ ى/y?fq;Q_Y:;/j231K{Fu;K/by7!c37u3qqrLn%Ps7{/oO{=]O')񋩷 KKcg?ͦfwt|fzo?f_?a& ;bFe1E) K Igag03q8?xomUZ?"JۙKG˿[sC  6PLL￘?O[5_Q_V$u9m-m_߇C>"vU_-ojbJ;߇Dett35Qt6W36sXڙ*,zbb?kglpqz-MG35,#%މ>&n<`rD9EF (qKF=?`cC1%.&?> QzϮZ|ZAe[52u^}/|O{F?]?7{D?]~Va[mm,~lޅewo=PPW{ݎ{N~lNHe~|zyQuwyG>{#,-y:]w'X'g ~%fg-VH, 0K[u+8i$nrg'80'6[xKM@ "BS8D/hb>J1ѕLS&C,K[dKŹhDmSmlvnxB,_Bk-*aoKy38ljsnq$б`u}•ձ URaY!*Hc^^JN(1d˰@o'tK-Bk`Y/ҟ'_vNRtF@KAʢ>6 ,"^ d̕fѡ&P2F0lkuWCm]4zfWFQ93&(QW_w^nmA짛?b@<hp큰[*82C0V2cc }tG^nsAD%KTE?6[a6.tn__v'vP,1Vb>`*&Fuo޴FRϝ"u1pg߰]g#2 ~3z|!(x m$%>Ņi^t$㩃(MX\UJ ܊y^dj'#w63[!t3ueT ,K|{]ύ?S2Y%]4hqߛ#`YશPBzۿ-O 6lv*כ݄ѦB4^)ɚ -1"!1NytQF cmp@ı`6# hէGseYpͯ ,,p.7QRz2TF"|iwvik6\;Z 7R$WMIxM ՊQy]0ɌeciVxi=&?jEբ{|`)n 8v&dQ)M5]X>̒[ܭSؒ롦sob[|V&=10cs$=:;`BN=f)zzFGK6}XiR[fA%4m;G`o? $r:mE u[*l'rp4{AߛN RUJvFrjbJV؎Jу)0͘WU[.j eη_6b@w+2U1A<ZhOo uGd%hl&4}z"E&5>3@@x/!h>^DfC>A,kfWfanӖd3֐ƭ2p'w6 \P8a3c~?'}BWJvKfQ;+q!+ׁvob\R`Gaw$G9l әFķ(ؕqRp+kW3ׄu#-)!(7N o zLL#Lb*FμȇVEֈ; wlճ0l7oV43 T%cuԉD~qRJ|D(x~{(v8Mh7 E1S\.-;>ښ1LExz 9m 6L_ƭH{⺚S26jR#v3CCoNPY`V /=b@^GB e2^:FniiI $.?EFYHfny RR4+F։ fT4H]v؂92͸D0#Xfi~?ͤi>CȣcRSt\נ&:T4+RAwD#HQ8*}%Tf+U1f`F?ͯZʉFϓ@KNI0(h͞ݼeddaH4?4Ŏ"ɯfrHZ$"6F#Z_y |LSdɛSGqlU0~|I1[@Kh6`~,q ~;.'Pd C^p ؖotG y~vr߃[i+4C"QhNR'uh !"(zCe% ҀffTO֐{awהNZnv-19 Xb]Q[u%1PI^C"aC =#{2>,OÙ7v0ciBl9STqdU'?D EQ~t E4 *N"ŎXĨRV,W+&ˣ>/uDn=28A].zi9E>,LٍuF9ڜ!/@`i,ϙ`d菐pўHUŖQJux!Bf-g(ź7Y5u"O{?{tg{ULm>CVGD]\#h& p {,gAt)L'uotܥ~l,AKTʭžqo64aDi{{U/y]n7zEniU3tLkYnYS$S1<T/p:n϶ .@s==} JgD 6 ii:Yŗ_u4j\jsSFU+ F{`I՞@y ,Ei"H^/brPٵ̴!gp&yM>7m#7-ZaL@bں6h6^IM!>GwHNUj:ry JݣYRSaѢ53v.t|oʯW(KMpgMwS1&+RS•#zgEF;bd\HWMoNPGuMk?=`y ;}LRψ園1miyPDoa/q3iZ8oG,QnIMxƐf4L|~K2+Zbi.vШp@oLF]7/RwuXZubq={aX,m~Ukc @ -U(8C݄>0t땶, +Ks%xh?x:dYí!P z4.a>ˋ{&d7?C:4:=֧l=]:cir/3Q x3)JK%qN!sjBSP>OHPBG ʞԅm߰V>LJ:mmyX}`q$,hxn2L:a<2!dms^4F_T$WA&cܴafC5Zw)~AS#`=sKD+d̏hJ>oko{ᅎ,F1-سvoiW9B0sFNT;!<|/.5SUIgq Zj&v {(HVɅ+*'^u4;gK11_0Tf{za<4òE\QW6,bsb( wٵW ^>ܩg~ʖ 945Fs¦*  ~n՞8٥dң_dk7 By^2o7RP0tI3.b|~c)zE/Eg.%zZ2~Gepa1zյtr AC@;%,83zHmG % %ʩhO@n}ChkIZ$P//l)ƨv(Y.k)u4krKzajU">E1߭}:rb [" mj"n8N./w}:~7Juo=pV"\Abߢ >ܸ%-uj%ER\Ѥ 7Q-@/S'=L=)눰垻P)l# L0DO .y 1v\j^Iѯ-P qz=D1E*>ZӞs]eo" }KԳ$wvۙqM$=%ĥU\Fʶyd9?c=J7%ekF*|{thQvkI4-GBߝ,BqBMP>{Q<=tOi.OVS9E|{ӼPnԠr<|F B8犫%iuzrE7"[h(8+||Cf6m?67 vZ<PYE`{9G$22ٴ5phwfIOLC+xJ_ֿb)^l4DM| X*-kcdjZ^V5E t0U(*3*FwnhYsVT4 !`cPt#wKpGjͫ3璕48cj$_xh^Y hv^A6vt?/A;9UuYp8.]%RhjG t+ʙDBf~zb=SU/duX.N3bD1 jK;=0CPY>t엗uz).9#κLe$bf"mo-~Zbj^%Jf~d=̢KKRjTeCgl8ɍA0B8vIC*e6^ͷc{̖7 _؇QLOe?!:74 } 8$VpT Jes>K^h;=å/\ۛ}"\BIR,ckG~i:ml3EP$?iĜfi!a(c 1Of63tF~J2JZH2ꍢttGIlNGϬZoƒ2Y&m J:p #ͥF'1pҵ:޳h KQ'}cQ#(2MՊH?s4·z<2G SթI[Xi5ȹ_[̮ i{1| Oɐ1xL{8v֙ͩ 3#fg x%/-t&uNֽRoE/0Mj_;. _φpp:sZQcj{,9c:*8#XC5D/Qų%26\P4bpRqVvU,J9nV&*_}:GgSffFi_(ZEBFSjUe@k-U0T,u73?(zDD$im5̃!/%HP NXG"\%R?!h[ *GbZ/pp~7He+?,-ְQsn5G$RyoC˗hNH+*0 dZ?Qr-{qg'p3TkUV=Mp1rƢ,sf&B4.j>dz]T;?Qx%#B}+$\^aOpƽ(uMA]}e!&^Ʉo'S ?%i+\JA.6+T"$B$&Kii`|F~"%c^"괔뷈{PO! PNp{M|X0ѪN,bh>ڋff`w{H+8 Dq@Π9_*ѩ.D7 7h@|q_ {O.sSI,:!~F4?JGh: u?\RM(,ǝ-3jol72"6Ʋ'TIE H/@=U`x!H0&ĜK:< Z//=umjK M}X.::kwmɆF+:(nmx=,iE>"!*È'dy3x?, `V! 0!CМ!݀yAP)96UgTߧB Fjif@dTnD9vܚCm%"V!ґcϞ+ֽdRjكI`%g|̱8&qj|磷Jqtd_00fk5 M26oʔfXʕb?KXXRu-9g=`slcdJ>Dwl!+oCpy5>,3D'e6ȋCa=[m<qY9go eA! ~ o.@ ~YfLlёXB}aL} r 1JGDX. 5~ɓbI'R^KIAɖD0~aH<Ƃ4[]ZoX߱F,~3˺VLh.BΥLr ځ 7,zq 4JQ+a"e*adrA>//+⃝Fڭȉ7:̧̌O AVZqk /}M%t&"Kw=J^;FID0n05N: Ѯ{(½\Sm&^B/Ġr@\@] eSavTU v1^}zc7NrYi`m_ri2j.S ܼD7ݱ'oBY5xtԞ0 gI—,\;}&GTSD4K_Ip37S^_-'o;RĆ>V1nEJ]g|'}J-2xzI%چZ\ / 6}H V|%i\T|nŶ#<@a8@/ҏYOwr#67^l%8rGӁܐc~.T]IfMO@UͮAR @t:Q<*[yHbEhgIΡ_V) Fbn۞8F`e}f(P8-g/΂L8%Z %c߫+ѝ0/Ka1,ҁJBVKJMDl ~]%fB#Uyi/%.ׁ~uf)D$(TB,/l6,cC.S~nAOGʶz^Ë%76%&qV"7>;zo5TVA.Kkyb$Vu-?,jGfG;mT% rRKٿC>*C?:e7o]JI4ljLPyNJ((B) ccj ʕYC%[ݟ4:}t^as ]}υ!FEӇis|41\c16Ȣ"j?Qh'Mik`b%F$=޿'8?̽H|kŗiBĭ77Fj\GޔI-B;W3Et"BGot^%d'v`i`'eQnU2 *427rÍGLkT,ʢA:8'kkiNZ\qoAhI@EfIϒ bJm%¹TfUDEW'mMHP+ebƅY~Li~!^v|4fߚB<6H T=urݙpgXDsAF!'Y`K}r㸙 $f^z9FOs/70C+6a>9VIy ٢AP0@l=BVٔ!LGsUAnjNWn0@֫w>2F*6&d|cCjce\DWlǚ6@÷lTC*v׻|ЩtgB=`&5$wSj-m'{ip NT ~ f[a Q#8J k.8kO:s)hKK n$2UJSA䜨{z6UQ0F (a3щ7l|kOF]]/ 7}>/\Q~0jE SfMg umT_HΉX,4It垷\>kɭMmԏsFa9|m̠֐ 7( TܸE d6~$ UjtvϳN몹K[VEGAJȶsofuezרRH^8#b1!򟥐[lô:16Ke7wW2͂_/2}`J}|fLjF5q"Ux{|6f8D}L;5a9UuUlW%PǼPldA.7 ז֚s6ɩb8>X2}%Uz >Z{O20.R^~jN Q\ԇB$^e ǥ*bb) ;`܀MYO8lZfe/TsѰ "v_s7a,-$pܐXWQ6jaB"މ#̐N{ Wl ( & ~msBH= Rj.4R}}/,zY;]̆\#ǁ,Kݟi]&d$qg0&r,1"F 8omP=Ә򜋳Gv \(^yf!ɨ}qqY)4iƒݬ_yzZqR']#w3MMHkh <ېERz܄5ë #%8[V -cv:!}5_}̢Oixϛm2XOMHmkn]k cpy/|PuLXq*QɌ 5`S7]Kc LV +pMWilbL]wD{vCB&<@mcBO]$%̹-[;$tnmjnQ/ucA1T!鿹^ٝAvhܭ˻tIIuө% u&v_*3 g{2rDzO//Xj弄 lWa*badVgHTd_o>P7,\B9E{bO JcT4Wbxl2҂)N8v9I&ҤRa6C5>q.RD|{fw;[)}EJDƏڕSN!> k/F-JC ͐nl+IPO.W TlySŇq %"1#D66(6}S~Ǘ4 R4Ozm[1*A̷=tl7vcWDNjFߩ LVu~wTGGCKuJe~KA0 nS_:bm[}WL;$V?''p!,0yQ!0LaGѽ.7u3Ä 6K$˄IXEl`sGY6iU@BU^њ3:'}_`|f]6^ Qs5ӡ=K!%vNBEk215s;¸Y6"!7- 6.X̏|Lb,iv GEJsl.{uu|ptIx' -31sj!]Eg S+&HZ%lY:%]3I/1B"1e ?\a! 4O8[[J=]Ngܝ͔Q4 Â_η ~z(xbm#; ЦeDU7Ayo##ڸH+Uai>*֜0"}ia Y #9Hb$b=V ^ՠJ3f ;49}dX#2$+XQj-Kr W棠ಐL <ά3z;\MpK v42Ň-vS87|jL2mk< =MrAFy)d~u'-CWi*v'ad~* v^PQDV :ϢGӒeMɢhYi CGVN[t)޷S_zbXtj)p2Hƀg OMd<\tZ,uػ|`bnKSr1㸙p׽hS( K5[E(A|Kޢ^/yb ٰ̒f z&^T.}RB |TW@\unQ;k,xH]w,"_uΒY-vuy 2=9F/HmFJ=bi'؋ ^zhcw.ky_!=p*"F$YO |G%X7>2~"ch㤉>E. m@ˏ5 LJLhjs_7հ =PU_fVUqISEcNd,6̸'^њC $#۩NX\+ZK )N1ރr$ bdJz3T\f@_7 {q}ǔW"J .vL-n3[wzH7 O"^ݞ͚LP-}n&Ȃ-oP{u^jȰ[pkfk֑,{s9JW 6voiNe$d(RV#xZ:`UPpDSYeE~(nȰ?x`ՔgK$uj3ιkIۅ`$뤅mKI*d;[쇬f|t^ T='YKMh2Ix_88tB6i|~<íwAרYyL1Ə$J{Xi.HE<a1i4˵w5Pc]W= O:^"u%,=zL0mW STHؑە*<$_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> endobj 318 0 obj << /Length1 1690 /Length2 9425 /Length3 0 /Length 10518 /Filter /FlateDecode >> stream xڍP.E-P+$8w/PSܡ8tw2|gRMYl;@Y66N66T-/1* /IgI!P;e@ ```cpmvHl,,Flce @o`e nr1:k=49 6A<+5(wa;[00m d0@h3T˟rM% @v6 MДW:4VӀ Y/߁lp6VK;@UFa,~\Ph5r @F\6W{.6-=ei I=>)g9=Y;_w6N yL"dV  r<̭Ytd-vvXBX?.@7 *;;0Y8*YwA`ϓ1^`;/?;NB0spA>wwHՀ6O@yK0wnтaw 0 ?7bf3~?/.F-H5hocʮZ(𿦺?WYdajZyVP3sq)qY@̭$߳氳q]l~8P/6AVqNO?KuH;-~o#7 Dеyw+u@{XQ -XAV vn+`lVA. _j/_?fT'?/Uc bceO4h;˿er@y]3cSq@ s9`mMPM8;ix 2OzzfVw2^vN [u\W2{VfqsW3פTsXM0y%}0jd_QD-4i|jzi>*t|D@ʯsi6EDaeN(q^60SF>kl^?K5H5(su E97#l*U8ϱ#/#0vԆN"S_7G)fE+B*V /k^Jb6չR2ya/gW#؇\5].-!-6ɸ-ۡW_ղps#5bvA2iDYk S݊u=D8C( m2[~ T'4~})vJkM"#&jK|`m*֕ e'">Bvܾ(C6j%J;$2VIıŪfsz"aaJȺѽȨ{9.=:2juF6sGVd ~Bz~B"s,J(K@mb&Fx=I:ABF`$CsEɇ|K%3\*DMx SG C&nWJ'HR]需^Pa˛47֗r} RE7g'U@DWQQ/~s?͐!nWzor+[*U̇z)Dv1ƴvJg*OpRE( {&k<$b\ڐ|aĘZ,Pp8cc*XPlH>&4*X!ʯĎOv3#n֎9v-TH~W_Z,mnJJwKxMilBmk9en3jN/r0c(H; JcOD-JhTU9yə {Hg-%>l=LŴ9F1|Y,q_wcJm &k.;˧bg 79.{JuFXn SPG;%Ŗq9;u?ѻeGCy6Zktix$bIv'1f0➪.齋pݔ+N"d!RӔα IΨͫms/5wuU|/MǦG;0r ( кoSjuyy" ƒ-Ɇ@an弿Ye>~2 L?UeC kŧNwͦ)5:׮R?NK|/SR5ԃZEn 3 5ުcpq|).B#8^:i4SZ 4dђ`s YjJPAN%lNseƑ\3CFz&NI6ȧ9K{D_b-ҌGG}_$ݎ'o{@'K@%&EzZ͢KhSխ2I~/|w`Hkt⿥F#_7MDF>\4ͧ}:v9kP u3BEiJ%}Hb.}gOhUDPݸYs`{l7y$[Ya:'h~n7EU (2ޯ7 kZ)g^NR*MBRXӰ@v|k"ih>' FZF՜8sE5Z"#r5cv ZzA^@e2ҏ[0Ɵ0wPD>kQ~(#b`\u7 1 JwNM/?\cd| +1^=.Ozės],)eXۡ\>K2^J{^`xY0n&Dr#%).W${ \VIXޡ5ԱǶ %j4)fx?Ԅs1>ۯ0mY,~' *¦( oQ;-x:31yXZE(ӻ΍TרeBCtN xGL /xEG%Y56|KmҲ^^KG4$wyum^GSmOMZL,͉i0y倓 rnk7-}pa6^!rOh&ZZ4 yM#:ݪ&=谸!rxW!ahߨ;x"if̽ےP<޵\hsGohJߧ59wZR`@%lH=n})HGq2\JYq. U{/?(u/755zԌEsz1*BQw n}ܥ͍ |Y׬3e/rț:pDF #%7gDK/*e^ R7/Z7t)7#o>MSD. O, BA0#um>3̚=[3m5&ܴV=m}7 bC S4s d\9ރ{H*dIF3_^.Q6:?J%H,s3mBB$ Рң+`6)7LP8+(&>$i=!n ڵGk_Rb4̶&Wie%Q=C|E„)ܺo^,؛t=2[ 7dH{;-zR˸!5@(b #\: CZIO`uJfy9V[1g'30kŅ#(j3cG!UAnuro#NkqLU~o K5W{q7v\թ'X湰"-vN#ۼTnf\dl=M҂Jy;VK xZ&K3ӧ>!ud8~êԱ:c[ր/'Քk$Fq!Qxk*l' ܭ0!"{_K9zeN.Rd;_ߵS#d ];)6>UO Xa\7x`/0`e*3<I"s!S123_ʣ 㨺7Ec2^7uN8O+Bk8/~pz}|'oҮF/4cpyּ(}h\Wu)<ۗL *;2{hĂ'aw28̓ zt< V.wkW`ΰSMMmfEv5WC_#|_D$z@WMVWT^(vr|}k)i}yM@SCR,1d {3XS~wɐ5inmֻI+/ϣJ (c'fkuIgw|Q/B0MHXe9vgL:,rR6vt [ĤiS4%T.q US,웰~Di6Q×|Z/~J3֌Ǔxt%'[|Kafɜ4Hk?8 !K2B04gL^t;WlW$|\$Wz X;4 /0.,V; W H8/[x1>οkM9e>w($tXs}`GfSE#XZmp3G0f_B¬w)鱷 p_% -1ڲ I#:8Jp| kZRJf!d+2eBΑ[[><yWO[LMKpMq-Bo1zt%Cm mʜ' e6xNlx׽ - Qƀ`z{Ť 1y)zG\摳7p]յC 24ɮf%#)4TڇׄI).caO7}}Ѧ۹?50-Yhc׌׭&v%SOhȇ$y< BG2&qW/sR3{4rzxudqę~(K x}jcDN<v)ӎ)c2ԤC;Jxh3w?zZKڝ!NH*}̗hOa% 84Fsٴ6RM^ t{bOqM2-0YmV(#?jzY2``v v^4V=(umcO7M)Ak&`ejʨK%A*u<*̈Ety`ycҏC>?#>D'\5Jg0rIn J c SQ̄EA_ _Vpʝu !+m44Hb)tq| &3 ЉH. EUd%6 !)ePrٜv+1 I^p z@'I'x1ޯ]=tySp "%ƮF,&tsW4g=a^z~>ʤ9suIJ\є%#U?mELwHW'qn9aՏNU{MtjIWQEHԲ_Q}O"]UT3%^;XG #l㬴^0QRϓ:R_~pE{&qy7}u⻵M7 f}"P :bafVˎcyÙ%i[f @%YpEn}!ꡒnt'b3pW +7l?ߛ5y%ܒ\yZgsP5ѣV[!YLĉR):w$QA"rkz6A_mER.'+ǝl'Bq|48 ,fF4F0GDŽۍ"RfG*[x..zL%`9d2+Zik1hE'Gew 1Gw_ e99e X3t`0 )v/杝#P@zόQoz<;zG;D' 1ֆZN.?"Giy\5 Tٖ+5f/{~9/,+l[l|=7K ah:!gVp 2<ve盎JlhⰟGhޛޝMBJW!Xozpiv"jOZo4h; n}\/{~ 6%pd%*;h [㈼س7<(ٙҭ4y?*c%2RF#y]&/jܽZK zlw)6yf [W `~N ,}ű x`7-2ALfaaed)bϻUYҀ{84 B}@Ԇau4EE;݃QʲMq3QBh_^w;4ۃ/8w1"]p_oDy8bt=nWS{`zTrh{ǾYKE!j\9m* . Yzlyݨfq[C۱YQb;@YQn]I'a&uroAЁeloSywLsUc^%ҸZ ;f3sjzGw0GQƂQUjb+}WFhm:nױIm|uDA½?މ'7;?2SۑcK,O!m>~!YM#AˏR޴0=˓{{ZX.Ce1gư?[9 9;^ѳc>ff|DG9TӴaW9M0*?y@^ 2+'8%so{Kך<3C?a+slL#<Ut` V"*um6rr,Ei a| Ezϸ_ؔTz:3A^x|o r:4M9:Sw`C|scDƏ.~)^|\ߗ乲=>J;skaѤGF_9+i0 ZyR^ec&.6kn^]C|ކf2:/c}=a90 Ƚ1:wvO" Ã"_S1>]q`GGNTF҉1m5_lpH?a7=1˷G1Q rpced&%q Z6Kx!&܅cF'# endstream endobj 319 0 obj << /Type /FontDescriptor /FontName /GGCSTO+CMMI5 /Flags 4 /FontBBox [37 -250 1349 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 90 /XHeight 431 /CharSet (/a/b/c/epsilon1/g/h/i/j/k/l/lambda/n/pi/r/s/sigma/slash/t/x) /FontFile 318 0 R >> endobj 320 0 obj << /Length1 1984 /Length2 12931 /Length3 0 /Length 14155 /Filter /FlateDecode >> stream xڍt 'iĶm4mlcil5vcjl֗s>}k֚y׍g(HT M$lA @Ff4'BdmBΖ_&wN l <@Nff 33 yb.yF9=F4 77'aG #[=5@?!A {&&WWWF'F;G3zbdbb 0@/fp5s v WG*-P7X/z߽ ,lt6027u5ZX%An zNv.VnV=ȉLyﲸ- ,Mdl\m=Ʀ0vgRpp6]`gdb8L܌̙no= lo"8 `laY]lb~@}?>}^v9_&m%q M9W'"bdXؙ@ 'Q?*X]?mM@87?<\^ O)w@ffg6z>?]QV$lmOoUvq_SMNYjA!lk @6FfNn&J #?xamakdd݋ޯ>TN's`#:mFv;B#v'lMw`jǘ98LB\&"NV?]0)q[LjE AQ AQ@b266`2#w-_6ՙÑ2?&X r,Y S/dy/EWd/_?%nojߩ-rw*Nfj9{z'kuN/Y g17abfb8gg`Yv_%ʰ;u|0 $[" еPq\ܩ%sge mFl3v >yG@:(BSD +hl֧JEUӳJQ$)ئ𳳪(][xKl8~Ce94I!TwJ^®p_s 8 tJsVQ*$4M\QnZOp^s.o7ˣtՀ:Bdt}+kaۢ+Xυ2.ژ *{K[@Tybu(JfcT3-x=fqUaIfG^ՌiqBEf)M2/q}ԋhfVPi$0ͭf6[^.އҫ7t8!GWjX'01R C~z t:.eq׮M$)SStFOׇR~pTÄдUQ!NWᅸ+Pڕ5|N_kr "(+\Qp}x1 uzt]9Cy ݀G 7Bp̤Ddd14GWIgM0K1H-We ,', R3ESUB幝GioB۟ѢtolW`8{,K$3Ku&҉`#t xO1|D ;. |OC0!c0d^z݇Hճ_ax|rt0Qӽlx噖 bRx4]FVHji,"g]SILCyk$08j#m$?iq+@;s gj~!1)b:`aҨscX\Oܷ8yn1˪ yF:Rss8v|m`rAk 2UHdlGMs6(MN[#^TX ]dy)kUYHW&>MND_eJ% ,PCvm 40m£O%8S.ef^C e׽1ˇ%NYo5uaM&~4!dh;t6N{<%{̩ y- bƎ:Hk1ANMSʂ٢5T/Eav7+,C4iB!=~~ OdA%rjh|U5o?Պ+xf`xaUO W!gzOk(1J%hi7XqvUq=R5#~Kq٣e@aO _vLBGLO݆~b|NF[O>uLJ0bF++Ĭysָ2 6SiRJ0 6Fw/~%(u>5.R['q]E_w?/?W;⚱X)$Qbu&e,mg2Li^|$H"- Ž{1(?-sK2X?t鈩6cYY vo]g qڰR}f;`o5|)9uQO_5!YF?˟7xU.2mID;<#h<^_AWߎz3/I}(È7X) ???^KT, *Qm ,^4s&oJ`a^(K3N/eiw MEmĞ-_i5|To2'?MFGR2Ԙk]:It&H序 GZ)b>Dfmdtg79ܡ=Kǚn0ԽTX_!.gvs_hۇ]wFL=|@(OcCt Cd:jJ~5jTC3\7L h[%l\oX@RZQ1%'#DUhYqS/bT,h p9>|ҊcC$~ ֲ @]0ह]y:`䤝dKTi5HӜb`J!5 Xme rNw]Fg^ %IjH(K%)ZoR}YzP_$5Az̑:m CkڜDG:Yy >bgkHr?'ٗ47a 1%KPrpU4"׬yH8 b\sஞQJJZZ:1Uӎް8X-"+3a/Npa mCb?9fʆ7?At~i9cW⋚j \N%xTTGȄ=/!wCB.ٝ"z?BBa)5 ]g^zn5 Ԗ**`':asC>s{s)/%ܾR&)mQr}_ظ#EbJ 1kP^&%7WM=ϢӋo\WtSEvOBci!;2(YS#*kuC[~tjAb} Ŷ|-(3>J Brm)+8qvD.pK4T/1G纟KgǤ\\t/- Glw{߿Nn} /[fI>(b#Xx%?M Z2=yXwQi*hnΖ%ކĖYEuɜ }_DwkZ2k=DWM+,$U4x`V.JPq8wZR2 -Qs""jtCLoڷ+QR(i|VL{~?|2܃rPa^-Ck;HI99P/O b.(!yS.|5?+ҙbl2 TَƗ,4,}E*5jJ'w(7ipkKz!0@u{;uAU|~|w ̃Ugf'y4/B[őYqAz.40-Ě=<LeqJ]Udc~[s$%% 6ddar+%&eFWҌj^^[8/Fou{w@gLm=AҲ"\"}IE^}:!wzq02Z6%mؒo[f j:hZqb湠l z5ger-=3tSʬD bM-[TQJA]"y!.b"7$aY!Eɺm[y<\YԘkyB\_I_?Mg`wʒO^Y$%;9YK[Uh(n%h_SXKjuiZ|:F?apgѫ;q@d̙E{f;•7 tK?R/޹OP>A,X1jmDYrAC:U: NHRDffH&~DMXc@scʼn|l9d._=mW;r*ҩo@[ʚ$Q\db({͹EQ9`7H5٘N izߞX(3,zwfģ䣓b_=۶7tyNmT9 )+w}87߹6 }hu6ѩA 0jU]d,5va6l+T.mOh3zDGGmqӡj(=y s9I&L`;U"ӈXLBuld,CuDblƝU>pC8>;(: "{Hs+vS%}%!1o!?SD.JruAtyy6DϙZ/J 'V-陪'J}WU@lVVvΪz 6WqsdjA5 ŷe6oٮFZfcS,R1F:ʕv!goj;X*~Cm-ut4ߍx1I(ӄѫP;?6VDI9yp^}E]R`}sT?rCTIaV\/Mq+w+Qm:(b?a`foIњ'ZcY|!Wcl-X&8p25|:÷&SVƟ[L$<qA$y3sB(S[WGrM^LX/?B3eĽpu0$2uyjRq;AFK!^vMp.z'ߪpKLd4}z}{ɥ$.6c\LR#$M:p"8~_ 3#B!2Ն?A$UGhZj#Ah89Cn!Mؾl5)ŀ3mS*2Fma`Oi_gC+5pJrGjrQ5 yU$ a؆q2TQ{>%*VoZxA-+ }e6M是EuwgtZbyC^-J;hf)lV&~KޑiVm%g]ظ$kSaP!*˪k"8c|WPZtQO}`e&eLV{NБ93E\DnTLڱ?~Ѓ;)$EO)q-BJ$vk6 V^wի4StՉ!YF(WGPc{Ouլ>qwLne!v褍1 oz գ!gjcpd+䃕3BqdHV~;h J@ӿ,ϕoN `5Q!jC8.@{ݏOi%n+W(',k;;[牦I a_ eO' v1P3HZE\:]8'rtafo褃L w[~Kǹ;|X;Δi"O>|1LH}1\wŽ 8^*wS X6%o?NHyA%Ӆʁ`ORo Xu+#GnEϔJ91;:ݜ*{r =R*>|N6gIpNc0Al83[kRQB@v \d61sCÌG|D|l {4$@BL"/hmyBV`S}^ؚ@Ot;| oe}؝X.Lh,PAc !+deDH@+'dX<4iߕU-E|03ś:ӀJ"aZ@ҋmo0&HUg?٬/{zmh+iA81Xw7f@dnC"=#pӋY+X oVTlQb+UVLz=l? gƣrx=`#a4 WݬڹD>7w74(T>ajx@5$,sk|/pOͥ^:,y\euK4D_fJ,5'T֩ zcԱ̈.'z2PS>T/UOz.7?4٠%>$)LLSG.>@DJ:H2-KPzh%nV(ϝwj=@m)nqm>q*OmDTМql].sISrspfd/}*J|//慦 4>!z2b%A41a8l}h־Z^-v4RķpGo| uh\XB?5TKg /axtI2xXX`3!UHK^ۓR $Qh5Ӂ^LƳ`c8,2F}!$pK=ĵLdA_:0s@ <栏m'#hFEJSEͽ%pj :Dߋ4?]ۙ~ŋ" lZBip\rZPJw_W%Eh Zx_$ח3j:!͊r-t5pu3\4Ʒ(%gn|7G^xFuQ*( i>hſ$G8IZGSN#[z> 誜r|ͽfX& T=+ćי$ S2|k-cTnc@`v=W:Yq24͕ =trW>)2g6ldy"Pw{7UARPYc{WMIh>MLw&L*;F֦7 щqYl4\~sሬ^̬# ēdc~>ܮJ{}5)}(r$HRIgmq3LvkZvHݾL>b-؃:u%抌<`?DF M;%4Du/ɻ7x3ۡhphd^~l賙qq0,yXVVW1z2O-4t[A +q1b/=E!)ڴ5ݶ["/byu]}oF& 2/^nw ac@sY% 5H)j sӔ A3ՏBl)[ reA{r:j>c&gOv`[~m Ê{ t،j_exwEԶ6~S֠ZI@G5Ŝrf U+SkWo(A- zJBK y߶F1.wǐ<rVʪf>Elֹ@*}ǁPpM!SI^W؉?vUeJZaְv$&2t2o$SfȤDrx9d7]Opf; dkMP E%ARf#Q[?TΎtqûF?R{R0UG?nKħB^}:Ovԅkxqi@#'&3إavsT j!:m^j68ܚ;z^Zybg[Jk%@u8lnF'%^ /]I+R,/Q{FUAJ~Lrg7ҿOjh+EBË[6ׄ E4΅7X+0G+ւal&WbsBg͵aWdžTu2gDF vᅗi<(\' sw3f<;zHB/NG%Ď1yGVchͮDJuB hA̛[=,Ob oGL:`EÞ5k5C[0MB?ewegֽyMY%JhJܐUY|[Z{p&p#qcbl mۑ`rvç%]D!m)\)hQ&JқDnXD֪BKm0@щ[{O}CiAԎ=\dpYI>A.I׹񂢬L29"1S  mގ-';Q8@i=Mx[95E`Ҁaܮ%!hH’ wA)W:D k)*}{K$t:1b`hum*ߓ<=Cb1@ L9 lam۱i=rdѢF|Ğt;($HG͍{sиQ#!MG033zu&HcF%yZC?6NhCNsDV[)$Uwf {QEI$^t}/:2ۀ T}+E\GťRz2ղ΅P\_):9iQ @1Mx;c46M!)f(u5s*PsSG )Qn۸\QЂ[:d![ͭl! xS'Ґ[K GhΈ;s(e$\b+{G-9 ,`Y*R<9҈L}jڏ|c͟4ɠd$O$`/TL4p=)å䇴|3}&IY08]Y :Tw7|Iïdxe^%'A&V+'r endstream endobj 321 0 obj << /Type /FontDescriptor /FontName /YPEFWL+CMMI7 /Flags 4 /FontBBox [-1 -250 1171 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 81 /XHeight 431 /CharSet (/C/D/I/N/O/S/T/a/b/c/comma/d/delta/e/epsilon1/g/greater/h/i/j/k/l/lambda/m/mu/n/o/p/period/phi/q/r/s/sigma/slash/t/u/x) /FontFile 320 0 R >> endobj 322 0 obj << /Length1 1813 /Length2 12400 /Length3 0 /Length 13564 /Filter /FlateDecode >> stream xڍP .kqHpwNq  R(Pܡ[-'̽=; 5MqKs.T`ssh va ,@3+&eySv\\^A>Avv'; Rfn K2+@ tAtptY@^@oc ntYfkF 3;6 ; 3h]n@K*fl@.Vw3g Y.`K359@S^ e38X9o?:YX8;=A`kPQbx@f`? \^@vfVnW3"a^, t!.('rZݓ~;@`K?HX:iAN@yM^!0k ':6lt~ez%Y_P]܀+?-pp,A9F'+ K~3`{?>~2z]/K?ΗMOWIMM/IH8xY,<?"'f(ryZ}2 Π@?on|QoɸSQك<6x]eWY(;Mu2jZyyF hXCkx;e`y^ uV)'/uB-6yuX981Q^Пfrp{/u;ـ_ӲՔ!\_g/3#+b" "??׺ *Y8v__[19[~ __%h3nQ"Z?_kw^i%Al׌ |q~tK_+`Z#}ݏ@򂃅Pm]Hm[ww4{) ,ΝI AI#k;Wb+OG |M4Q"h<9~m@ʏs/Q?P:_ͫX6mXB{U譿{7^MDMOH {=>M-q@]R6*\He3nu_IнM-m5qTūn7r}vYIw\X~!Y̡x?48܄}ii-%v`1\[L'_b2%?› {'.`g'9[xҵ5hm̫by iF}ntODFPq.|Uԓ\6ү!BnyپŪH O;|SJx|u(a~kr c:w#ߵBr#4]TSeţ`nvͩN$(0tLt=3K.+(l$UGT qYשzK&s=&cʤsY3[M<*-řjoJbOt*]-N@;gȖ mwA8b';.cC e!1v+S<]aph;n=hM)pSI3iDjY(JPYiXw (B!YbE!A%QΥaŢzGWf_TRAy!֢PLMu/ͿMb+EYvK3ڧ%A]x` *괩_p&{Rp滥󍜐H55#D|G&9I]j nV0ЄxS[[|]9~p=iKB uӳמd ~d4Ngmmܪn&7my5gՏxQ웤 wzqn޼ o0N#i\Dn`?gj))aa&U6 ԗD!#\GT TeR+FMm㾢%`ˠh81u;DD8HIcټ8Q*rg?׆ԜsiEhh/_'K6E?[0}nxn -݉uޙAcb(ْ^0zMPӃ߉BrjÑ.[;'zrOnh+NiPַ 2yp=̕?A l@GZJD* ^ʠ*y4/iKYfkdnK~K?!hr߰ཫ @OUrǃ5uS*k֝$,_3a_Ng7M;BMLd˴Q$gДPb.?)߼ɴFj[zADﭱ _~D\_Aga.3IB' o@yNq$IL(-J&.O2 e)uX6o2vew唽 "U@%8] x5UsYF6~ ~agLlYZ&at-\{p,9hZj/Wn9w(QO+6-CM켉n7 &bV\rjfn^Dx&5deC1qLCaBeȁ\::BKhUY[ ~㾰Pw(eenrRtcz2Wg*c)Z ?ݙqsԌt [ \?XƦѽz+ Hb˜Q# ʂTe@ϴKox=?* ɨ6^+"MƊ%o4-6-OBLv*@ȠWd,^I~/ql.hO ukeYGoK,҂S 1 x:e*na޶,:ta"6IZkldoqO9L]Y/]Nw)/EΙFiPګ7s<`S\u9d<~X?'4zx^5`MgRQy~)vtA$ KH^(auIVJrC,ŨnJ>|RΙ9h(sOrY-S%&cG`QnNNKwpliΏ<Α~7!X0&]v.Bݧ=és_*}JATJe Lt^O?S|#U\pl3͵<)8/.I`MXw7.Wb HQHMgd`-sPkKjiɹtZ%aǯp-v8o|ZYG&vF6&kߥxmDY@Ar j#^\{{*P#Qkݒ(~ cR 3G&9zuTv ϳ.[;'c>"u>@UYQ_DM6MBWq?5e ŘL(J|87W'|>F\?֔yXx#IDƸJpPk+ף>X]vTh oU &t-,L,x]@$G~~@ݨ)/IMn|5>?2&*WBhHFj$6 "0҇oui,R.rKu5F@A\m4X^O;9hy9l"ECBcwFo48nTmX6aJ6ez,{A~Ϟf<e5=)!2#i=(P1O( "}#Rr0w\<֒QY{EVs}Rb/D\M%|VsgޕJ7mjۑӔM~t tCfԖq \USxzveͲ8O2ʗk39hhhR4Jequcs^c1j"\Y D,]SǺ m\@5*e2U:I@TM'_bif ,a?t/VMz޶\>v0nUmtv9O[{ WjޟSM:.~5l>MqSF|~bkGn4y] ðR _2 zvBp=g +8+4]Nߐ&Nm mkǘpkL"Ɠ&@Eka-{\O,\!7E9@oOZ4XүY&4wzǗ< ]-HWh4nu1MGm\(zEϡ>oŌolqGrTMD|ʬlIKΔLgZex ܇v坝Kă6@}g3zΘ?HbV,5 a7G,e̸ mfe#m6 ]_4?`k)uIlR 6؆z4 'OaɣT\&mcCM%7޽]/B_p[@׋F;e`!hS[1bcrÆA޷lYfEhՓ3]Y=fdoz.B}mGkF#|=0tS]bSv^QIQ"-',JӴg"ӆ^#.emncƆG[2vtmd9P",k#wxM_Z0ۍwməNyRV1s3l}-Ө7D.m"/}"͸gI P}rӧ)>cT9p|L[I8o0 a6Nȓ;/͘~\^8sw>JFUM>=j$C3U4RڙeC7L_[ۑW]%QikaEPV)}y,>=MFw}|w/C`#tW!\eR7r m=QqwOV"U {uNK>T^eֵ1UyYy:ёRwX9r`PkX|Պ &%g5_!HYft{DXRbXTTn) 499Luas!XrKrq2[sUB"hiF`/QM+BYvOQ],CA& m 4ҰVEGBnnyؒ *uZ v-NnVfU֥z-cMiP3jJ4ޔ$T= x`W9Wnj!JY;iIGOL0vOOCCd00yQ SC֮EGtL`FD}g )θWdX/^m2HLJc=jfܻ3T[D9 nYRV : ft8}BQۡQ_vпr Woĉ, *(:[8DG`PoټaVOVIroqBx0L?p~īꞮz&WpeV$Fh`!^.heUԂfD}MBG 6:,o?PGy*}#5 /2:q'W¹OϫP0[S@_[4Sd"71D" nZDx,]p?~=A̸Ҕ_A5ىޮKr¢QڰDv656/Nam}Xd;?ƏkV-ݧCH@HΉ`1_^Mwj&;'Zu-GB U']U2Vb_ōQ$h k lL-uW7u?)4me MR2^F ֬wM`7bUδ+Uoِ_خ0\ش(+Ś7[ğ%*&ڿˏ%ͮ\⬀g1d-?!ܨUL8}B\&]2w-7p[QAb Vk\(F]Td.JBw\tENo1:y CTWI @o##BxbKXhtlY|˩Fa/8B#@5n,oO3&7 i&@Sp;yNM J鋖%mq2?eK_,-;EUa6g.3S3Ғ;]?AOso ήu ͨ:^}{ Usbřut?U~-K<[YX;j#iqT5wɟrí 3!;<0V̚X0c)UJ:)QRu.L<0=4A\nna8?_1}< hg9oȢ2LlDƚ2utu9<=qbKGpedG5D5#%nK=Rm^O=^)X6tщj)8( h͛6OOONP.<˛oNcj<"Of=b\Ա)+\aIs;;K>Qn?I8X e\By&~a,Ώ7*`F "CH񷦅f+W%r#N. F0(B[[~ϏS6Au{F}3k0<=WB;uъ?FzRSK`M]#!JW$zғT[, hQ:Hq8.Z0A2i17 kܜdKRh2/u:0M}L}/|.ٯgpi3"?PFffw"xQmo9oo8wϙ˖CR="mKHɬN$`c҇33 #& 6ï&{~X9ƦrZy'iǓI1IY-[+#^=2 ?2 zj#)-Q }<jkNڥl_B6RbZTAuUR]VTt*J\S̍$>jmf(lbu-8Jk[:Q3&e,>Z+PCD.nMjrZ{{_oDg!,/Y9d`|z ?q^Oc3#W`iDD[m`/t;_S?\i1\83~f/kESWH' xa瓓pRCd͝g P…i5.j(ހPy9+ ,R/=#ӦsY$C[sPهB|F$RvohmseIjjI覢dUx\fwS֝K,~P *+qkp٥[!p Nݾ eq o89B˿%Ӟ]`^HRl[ Y9~R4Yzbŷw7[@TMumz8- .ERç,]ߥ6fRmӏ</.!e'0oiuŏ%m'e%<-7 |qVW?Z1Y_D|tLx |(=1;?qgYY%CryTU.E/B Ѭ0ީ[?~غ|WS,$mА2GVCXv P*:O6Jh/n/uΛ¿ih?/kUӅ&/d$oP2#3N%P'oo'N.Bv00&ϓ"F纓+-f<w-_Z97OJ1S79 Yjqb߇VfnbzGdQ/I* ŋ!9;GfwMF ȽũJy;xɒLs3hZקfn(/Qa*MC`gx3 ߲ ׆N`6CiQU+&ςoo }.cq9r8ԉ擬o/b`XG{CU;>^u) ILOf^>.[b:o}>pf?w2?D& 7Q>\.%Twt ~Ҥ J/<Yf]rNR<{r{* csF`#lL67/me߷1ɯ:[ twׇ0x"8A_SUu*NMwt"ZFm,c̵БAydNп4tTK ;RZH]Sإ` 0M`?Ty:91 'p?P+m4;{p YlDȯM ir3KiG~h&/Q80ۂ7(%[jߪksj %$T:[\$3:0vCtWoLnШgr97ͭxJsȕY N2wL]jW̶ MN ~] O?Yr@]sL\qSfwF~a'9sp ,ՓΙ_|-ur89h6 jYU,vqW*1`?{/ Z]VvcB+꟩:a~X%iұKTyk`+b]T!p.V.Vs Ҋ~9z&3z#d>85}^ZWZ5;eH=AIY.Jye|g4+TC_@sZ`1=cl!d18܂&l뽚)3bo:XgwHGw+iljM1oHw( $'JW91x\5*k2)wɦ\BF+EU{p$AzKgReh# RŜbd|gaٟe$BˏrmW*U[E=}H6bðZ!;n$&dx/%@SPK~ʻ1#55 )fIo\tbe:Mg1<""[3k4+C? lyMalx4d\o..lveNlЇOBQu1?_7,/#C!)W^kl~sR.?x5mJB⁝[~lDlkS"5|CYэjG|i5W ޮ/>oV),Բuo7֏Jc>X+ rz{>1ZD Xb-)?GTGP8c֮&Ă endstream endobj 323 0 obj << /Type /FontDescriptor /FontName /YWLPPL+CMR10 /Flags 4 /FontBBox [-40 -250 1009 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle 0 /StemV 69 /XHeight 431 /CharSet (/E/a/circumflex/e/eight/equal/exclam/five/g/i/l/m/macron/nine/o/one/p/parenleft/parenright/plus/seven/six/three/two/x/zero) /FontFile 322 0 R >> endobj 324 0 obj << /Length1 1527 /Length2 7001 /Length3 0 /Length 8026 /Filter /FlateDecode >> stream xڍvT\- 1H4HHtH03 t R ! !*!J }ufO}5wu a /, $x/ OaF 8_G )(7m I K  I(m p7A^ {/@7169  pہpT'@kt@?Z] @X@tEJ n@/p:*ZtP@/ hr}p @EAD솀  Jde#"Χ١nWw[]0oj RW9Q!!!q s ( F? p@Q@8 @xx?w{` rC ͎A{}B( ~}YYeFf&jF cRTEPZzG-3?:пա0 _k\xY1 c_[ ١;_Yxr2V bOj"a k#P:s` d F9=@wCA083@MlYsA=%pT~@QϒP;/*zx} PGD¨5@P CB(z~ U=Qmy DgQ1nW r@ i? v pEM 7D Y;OTo1n,ÝkΫe?rl_hDTeyTH&[R>_dk~ђzpe?J0?ApO Ps{q f3zGn>wO]_mUbWSF1!%mghYqLx(~NHE# p?Vl~ŌJ}x';-)$4 9Ңyf"\be~2_U_@{jF Ks1S~J)k`չSjQ#bAqB@iNޛ } 1q sq"3K%"lLHw7D0{W[^q *RB͏Ǘ^~GaH*6!aU̟Lȝ@mT7tVD{n/8-ЋKDt<s}رGz5u-iJV"/WdL~?X g^RQ{[D;SaG3Ȥ@ytΩ+^@Փ6ɹ7~<ָ%B~\lN?Mcs>Î)+s2w%Iagx&t Omˊd)SHS*b}7=M 8pt]}ӬGIˆiIdV1+dX%Ч:~%!Ӌ3+"uvLF>œ˞{# wo$/ǑyL gOU0ǶwB$.Ɠ9J{7hR#3X#҂fpTNu]jeO(XR? @`꭯=C!,t^>#*Z䳊к6Hk\G?uhcu:NqgJՐ=m1G dO5MaVߦI}s0q?D?bج &;]ǝiW%~P&["»st*Ūê5k]V썖_,F> %mBRΐZ4Z)@J]?+)$,1ݦn*> Yr. ~C8}ljcpXT9+7yV帤A!Bwh=+p UWXNlg.t?_TCT7Gɧ $~Qܠ,ZҷGybC!_bwVn~2deBڱ q  'ҕVJa!ioH=i< Y~P.5벋2;%N<uG4N۪gidGwHF+)Mچ:R :T +K^/ t[px~N1){nȲ$v%!1Ul%+/}<#hW̘eK)2]ͅ ˬ.Am!8vEsi J"..h"'0CUMˌN|SHˀ!9 דۡBTFؽxHwe[6 ط iHb\ hzߗ8ƒشUܴ{?$,X,a{o)m_\ZV 8ꢌ,fJl.*4;}|y")%Ol'7!DƠ!aqI cYʏa7Z;LSL&w"7: vaiO'#9u(%V0S7RM;Ƈf P1͑P 3zH[Y(Ϧ .l3{]!S/ p(JrN=G`PҦ%IGwX77T˦»n 8Xte6AQ!["=Ń>oj $;P3HCJE,a=_ "D[)KJ}1@U1 r{a{zj 9P9:K4> [NRh_φbE.x!Eg.:2l"[z>vrgIJM( ޞ%_s>Kiq֓v~Q%Ctn{6s)Ыe-|ilӿWx.Mt"Fvƒ>+JPxs<,H 5eY `?J2-y)!md[Rvz$k St.'܎hJA;#cS+`:E>:vVgn|*"0m2{ODr]f6Z]fTWI<=Z PqC"6f$zaaˠ=fp{3/zNI&420$߯vw?o/dYTUP֚6.J_cH.ҝC u`}> qPQa7[M:GŦ*vA65)wA쓬!UxMc50fL,M:GMӥ3ܐٸQ/#CmL"<=LܟM:_E J2} Ǟ9yi{Gx/`1c/pLa=i]F)> 1u7V]㝳8S6t?Mb2H W^zX[KYp"jڃ04)}FGUXrf #TzvqB7g :1 *S`R[G@=k~Nm+Zi4k\07&*ՅRvb}K\9Y7턁_GI{tZjS^)zQԴ (;Y ;Ɍ[-mRohdjU$2gwr1PtSl{EI}YKSh LYi>ʟ{Ψ4d{"pTxiOuvEHL7sIakgu@:mij7Q1v: HtL; ,L֟yT~bw4S_OjYbs*p꣄}jܭQ҃: ڗ;3#?T'60\8젙w^zgUf^#z,.*s9yރKR1En;a%>è{!'NbAVzc׊<>K `9BI|^Dq Qz >TQRSM$!Mu[VU #qlp&t'B(驠yQq39*m87}V8Rr44\v3.ysR#h {ݥX~jKv3ճSeQ:>D_h8n*RЊ9tM儧^-XpP2z,.mNShA 䩑'1ex5;ϦDVU?vD.-0SDOѼw~"TfiSYd]\Tﭪ0;-fVww"\s{>- b|rZ1;Q 'wzUU%`tj/)rNrF'BΪE;F~B)}3tb-< D8|Ȱ/ْKgDns|d Lsxm͂~*tW>&5iڊ*e-P2FmLr,j/u#*#"37s<7S䰁ݽxd!%|TxNmQ ^}pRigO0/G]R69ݵ5[6 ľ"\~%cxe\ɏK&w~j41Oxw>s0|yv6ζMOZt=T0{H #]2z}سKiz=Bk68~4Y[i'ǯB'^pJPlK0O0٣ 1c\X#C(=`0Ci%)ctF yf@^Ϥ|jD;]"Y φf6zw0)¾Fᒜ#;MrI.ҩ_n}gIudz|ܲ˥\ l$ejmUx0]Ky)%˰e%Ԉj;a*]X*wq.b cSQ al\8p%kf1޶UhU8Mu"Ok:c>|䁩Rsmg;ȏX*~vVi irG a=uH鲏 ںXv*Bk%mtͫր͖Ğ2F7 O&‡ENنDxyF~W]BАop'+=WGﰣ^&͚-Z??~M DCU9rcz0)Q/p!2{x2vd<-YT|^ccbmZ8,h\;_ٲDq@VʡI AU,:b& I|1|`WZ&;hhKhlqOwd 38-hⓆy0I%("'nA3or9Be U|N2x tUGuKLV'>]T3Y7edoUy9vH endstream endobj 325 0 obj << /Type /FontDescriptor /FontName /UZEWHU+CMR5 /Flags 4 /FontBBox [-10 -250 1304 750] /Ascent 694 /CapHeight 680 /Descent -194 /ItalicAngle 0 /StemV 89 /XHeight 431 /CharSet (/Gamma/equal/one/parenleft/parenright/plus/three/two/zero) /FontFile 324 0 R >> endobj 326 0 obj << /Length1 1743 /Length2 9528 /Length3 0 /Length 10655 /Filter /FlateDecode >> stream xڍT7N(1&!  JwwJ1`6KTJRJBF$[PBSRJg󜝳}}}8ۣ`*(?X$T6@  p<<(Կ0SxʹQH+, Iť@ $!C ($r;:yr|݁ A!^N0:# 4DA0/&%(+Ax <ep/' ԁ ` 8FNp?`C/Dp( vF<@Cu- |?O_(p HGUB !(?wء ~!h~zݼ<<ᮿ >de" !<S{SV$dzi1 SW a^@Q$. ܁0?FnJ/]p 耦 ;?@O  á^@;# ':9!;> d-{S606Mo/$`!!8!Qߨgm"#P@?(/>ן oza@$ oE֣[KBpW?)Bo6 550{7^f#]>D f:1@<΅ ?zנ.ݩ*zR E9!Q1 @7-崇kvP_U!@oQ @]`oOA":'"Kn_0B!ϿǿM%'$]EIKM }!D'Ey\=)M(^ӿe_ţ{SX .=?Mz{{^2tߢ0 GA=v~RuPzc97G91n*yԾvҙeec)p#/.m 6&^ot13ɭ] `+A-oSFӌ6]5ٰ((3k2Rpp4*;'9m) E+ v!~KGZLNś)G Di q_J^O0=BbV7KRmkVmr17 o{>ӶGz}F8 _!6{o)#&N, E7r ݿ~ `g*N3Ar#x$09jq]BŮ1xLO_*g?oќTkX'08#a]$(dZO]L׮^CmrFx!\{#-đ Ɋ>EֳODL*U֛>5(kU?R~X}^=Rl/mrQ߼d3ʉ΂ ./"|a?>4“4^NWq+cī-S 8 }G]ケ`5   K+_N9WlaZ|`= } {yDzc-]n-R{GwosgGX"Tv'zcR+Bb8M5]YLVfU. Q%=[Z|٬D1m5 MoU;ˌSO9eJW 4g(68|-F5o$ҥd{7V7 2QyrUg^JVg݊ G!ZS]d6V9_`F6Q6Ibw[<SOeVHXDvzXegjq| if:+z*$Bקsr+zi;q݅M0J8_r]QК`:!A㦝 gSWX],uQ $OғMS=Ϲk=Jo ,xZ:L]l-p1'zj<Jdew;^'viaتE>C`vNe _c8*0K$j[`#B2EKU}FZrzmR#pn/j׎,>)K;cĠ-Slw[*6Lfiy*'OEMHcMeFGtSnW>z|r7^$㹆;s 6\Xd}zS ŀj԰G,Bҭ g>DUmB.~ (t#{pYGG^?a9شXS7﵆![w-> Ef l?mS0TCݯ4g![Xq)x !}epYAF3ij,g2L?(_y >jƤ&jpBKc3a0G>ERP񿈝` J'::4P+'D:12U}m`FT_x/Y ,n[+0c3;6W?f4 7)dȮN#~ԠR.f}k!7*7rY'CU#dSPaϞsyg#R'7?Q+]6U=nE)_hF@n%ҁʖ;'+.x'>4 xdM4D WB)<˖Ec Qtd5R{gZoz'.%r'NPQUn')YwRSKOT?VY^`c|L儹\yрSe; QJict܌lWlTN52Bs8td]IXH(}׍ق0پҶW_XyCZP3hr |G&]Jݔ5eP|QIuɍ.7ZXѱdK%%'r3{:\8)jM׻ZsӢ!E_zP_닡qѐk{{&vư}1gޤwj BW͵ؔ_< #Iv-x^5bN*>fm m#xIg][Ud\|]Bض(r@TqKiJ*dhrn&C"F^C͙oS$Ss Sc񔅉F92{Nvbb 3jf*yeOMm9 Rxl:-/^n}cc[_RY g 9MaWԟۍ 9%R_=S1JvJ_ݒWĕ,Few*Sy~[OX`&sݱievjp9Ѓ{ Em1|G&Z(5Lo*&mNmD`8ֳ`?):\97p[ħȾ%qM'v2}{~$`Ax̧4ޣm֌-IgZ5?Pvw=yl6j:M[R Z8<Ľ[SN^ULAGf}n!oMP:|fZaۮQ(S ! 8FA'ދR.ǝx6V? d ,F0൘<ڿm\ W$`KRN2>vxQE\`L](S&{Ndj8I}ۮ=[x(%I n"}7?p6>[/ǃ#{3~ZVEώ#CR倩vՃeC%^j;MЋiAčb娪rcLmͷ@fj%"j^;ضcx\gaS!! I@vC HD:xŹpْg5Βup˸<'PiRMPW2nGhठU F㞟[w6(V娷>~rn,k)=A~ Q;cq!zvi4i_ph@ nD~R^ZGU7kSqߟ)vI1u.mhaYY5FJY; 1C>'󄫩us&}GXVY nsnI6]bL&CjfKk=l,mVagV8w LzY>PmxJڼ%qp UR$e/|Z#'Cq]{dώ[\N[w@f.+v},73,r{[BEl%D,?p'\=yi$vK@\EqMp^!e'܈au>Ggh#Hβ7h-Anv,U8t$,x|\moP|YlДU Z̠Ύ޾O2ymhkta}MDP(6|i±r(64tzHۛt#F#1 jP./҃ST@APcӃ|1xN[PEa=z9Rmmv -zL7RB_t<#8=PlbSޭVNA+PV"ַ"}EYE5ۊGEn p0ʓْØrXvTka-zu=5 nkJTXN9sa+n$(?HF[~ԛ?V`5xlRYnU[3 N)o_}-FDaTN#ghJix[4 }f :>'W|Oٗjy ͵lR wtX730o?N HɅd}"Ywl`/lGw\NR`QrXN#q=kW#rrU zOQXCc>RL6ՖAsPaTfǗB~(7Z$o=XXom~OgiLZ.@m1Sڇ~Ԩj :v$tV*Zg؀,VԈ~O J,4`.\ j>pܮpZRb@QIacw28ƌ;=xID$'i^ f3c8B YET͖hcQvVF˧H|~9LGxOw 0"4ZYFTU%DJӺf`Նc:W]=4SV)Zh1qa:y];\^~~{5XZv 2ոwNO Q̶;XtɥI-Ꙭmde}o}Q{lysk?iw?*P=:ڎяfY܋J>էu)>/i(9~sbcU&!,lЮ>]g Il?Sj3֙_-rH'3F0oD}iA F<^pXKF_.nw;h(?agLvJcC[Ğnl(lTk(֣J\&5J|f8?a$MwG^T}&rwp,L6.u_XKHDCG;t^gN 9ve?4C* :54G?X`51r6/H[9'[;i3Fk_˷fZh\X /s"aK\ uKR=Pu?JiHl&3 7ʴ0(濳^7kDVBnc@}P?@Tk$|^] ݳ^.خ۟'Bt-ݺ|^NjgJl蓙o9#RW& !V@P3+xFFSq27U7ϡrṀwfFe(SRҮ43Cyݯ` IYkz1}P׷k⺒$N;}ۼAAuu,*A82, T'*P?PC~Yv.:q!\A)+q.EYI|;s>vĺ|mIh.*L[JX@YxC.;W'hVz:.YGN!N/KB;&'UJ5Evqý4Cxz&b]UkZMMOfuᡧ0g=͓ѓ_9((ߤV&}2+ՙuKd>)<)z;)h~:6$>YCߪjP}&U\Y"7^blPPB,uR{[?BU47p絫Ob1O-'dG8%`raqPUa 3SN3j̬" .eUq2?dD2#ޜ1õwr<,&CXI` *㏌Bac"]SD^Bp,(ǽl,^CqUsI+ˉ؛D15|wjT$^SY^D)aˣ3 ZEYIrQMѬ+R3JvfoJDowۅw90?O'~)M>|FV38@YVٙWs H^^<ѭ ݟfew/k)RFb0VϬbQU {!y-'dvElZ+sQX ԏ9.tp*3 gYf|ϫFvs1m,7#tLk?~!H@vUyOStx[#Lؔ]yH[]+Wg}EJb/w;ؚ>r`T(g=c/;.d1T5n|z[o4cQOGI1^*Wch>?x\Á!->U y_خCEl7c=ĝ0})vM_b1~JWunqRi >skP ƌ-dVhi1XN({RF(,n4+ﾘsZhԵ$ˆ7isdS>vӛ=;6,p~#At[ ëmGq%fo!1As z>%Hv~ C5&"WK-+C)˝iYN[VWPӫMj-,帡]@S%. ér=xmVb1)Xxxz=I~p YX 7wy~]c*C,5A _8=i8XmXt4MOd˴)M"ؖyf߷}]P@%=ٌ;^`nZqm PklDْs3: ]yU]MaXg6@iDWcճ/A8k ۈ:uY_1s00hIÆlԯvNvڗbb#Cp\(2g Hqr`֥)Z\T~ql"muzErq×0 XcW`d8+v nȆ Optb25ͅ` A^7T kufw{ݳ48#a7$uVʘ4%TalQzOqtd8Fl}o,a,auXmJou/{lΛ;\.δf,j~|?M5槇nh,(V"[áؕ܈@]|2O}ms~l,{5] $;|tAUi}d78 xĔw/ȇg}ꄓ :Zwd?Mxñ]]n9mQlcN L'=ܺum 5> endobj 328 0 obj << /Length1 1545 /Length2 7046 /Length3 0 /Length 8080 /Filter /FlateDecode >> stream xڍx8m۾^j+j՞ !ԞUZԦFZVQ**}q|ߑH~y#BJ({:  Tt-A@(& rs18) G!;b` Qhy 1H.H.vD=]a Er|Nl|~HZZp+#`[FQ8|N]///a+Z(8h'2@ CM`Ge0F0^`w( ( @:@cM_+ݟ_`Fc1`/G0ƃ=p{`!ewàp/"`Y 頂ru"1h_SC!s\$ G:~pp1Ez@5U`!cP @(-!!@'_L|ܠa,?7 àR?4 {@)pC0{#IX k;`z0o-1U5C_Fee7OHT $-@ 8 yuv50@/e~?+衰z-@q ?e_;R@ ~r`W8Vl袰oWs_ u{UΈs!ap8Z u0c Nif`k H u`aG₽[ؖ6AϺjHK`R+q;P#Ql1Cj$ %"`D;E@auo@ Fz 0p7vDPߗ-F;kAñ 0xc/ߒ7 ͠ 2aίZϪX>.-G'XDcx?s!ʼ7P%S҈o4r18j=Byߏ:BP̎OW$QY[&\KvmT\7K\E'Ti,'J9;-91hܭ=L4MG/qN[cZe ,,y*vU%2W#g0>1[5GYD455gNrd~oKbGJuGC (CV۵,"䌍INr)sW9 Cv3k?ԝDZ7= Yc<{NCH}z,a`w_Ȧhi 48=o^nq3yu3ŵF?`іӽZSdL@MSa?ho~O澢ge { t=˻JAT.lCBR>\S5܍Yn&@DF;]Na'bSr"@rf1W4Жу\ؓq6Z(FGDtLھbkǚfl7u[~>ΰBDyCxB/}U/Xؽsp du*sg-f^ۏʪJpi՗A<~dQfߤhc!3Ha'XBA{!NJqc u=.V>_)^aOD,%(:jlX?dQ m"T|Ho?=oavs)j+teS)J#Տt{ՃɿE~vrnw(S-h/)~Oj:O:ԸFNJvE/G#*gր|aiT l1[wgfm)B"Ź&Шbݺ5bj ^]?ǡy=ߌl12C_<nai'>_0,Y~$_BT0I0W*|"S1o8vE<@j}9g7I6LJvGa8˿7f7#4RI-6Tu"eT0MBP<3-ˤ-ruნzH`505Ьi-ZDv=ƏZ5eoSH]4z1!3qv/WiqrL'r @{ɊzI6b&k`fâ&}: 7E8I=$#GG-1jUDzk~+ʩ3ozrТ0^#ŕj۾JEkTr Y!o(5;.r7gLI% PjoNePH?ij ===29b5OCkj)DjktOX[LA`#e6c< hR% e9&/3kF[9OKiE{s'f)]B#nuJCp8qmp/0}0_ fZo*L&;!ӝ$Gyvm J'l 8 NI&6K)ѻ9.BCP&ì~̴{`f]e{OE;PűY6,d`kuݟmSmqjf7 x+>w55ap `xu0sw'QnELFT㣆oDsX f]#R%Ҙ^g֌bK (j,iB-CûO]-n*Ԧm~"Z2㛟*]\ĎPn!]CQvK0~n?9~&G )jWsxI;E^1`f.4s*u[z$ȊvrsAyJ7ĦoT5M]WR ц.[vg0BPؕZWcmÜN0hkw(/b7)-GVGվ[fmTZKizۆA׌h\Y{Gt CEv/HF3 $qI~.57 dz4kQ)vƟc|-TTH[@yɷt/#HI ,Qh|9ܲQ\ZE>(n4? 'wqظiCӋ 3]LqkHݔnW~+\.*N"m,KZUYV@-A`~({9W JAa6vSYI i{4(VbHաnv@Z-!Y|A-idGgkYJ%4m_ R\z8~(= alTic"8=cܓ+qJܽ*q᭧'OnwzV=*4r}(uɍ)9Ɨoa7l+&"6jS{KilSt}Bނk*'焙3)Ӊ>gz’/(+F%MHg ?-!O 3yJly/ 8+5V;UVά Xw%v= cZΠ7[pbdppY٩?ΫZT~=;yvaXVX9Z ٳE<%c؆r`Ŵ/jK_0ڬO _psc>[aAQ Oe-VƜF=:-ŜU#b9ݭD|NL GaR񞮨~Z̀E{$"Bu²*I,K=!;d8IJEU~ۗXW#ָ[W|R\Ңgdc9Dq9zTܡ!&:Enuξ^H“{ڳN5lTL|'`$$i)`@3Z \vF$!DJWD]`#س@C@~ٺb 㟔Zk$CGy3!*bE LfItmB.IA@k4.މZehܸE$71AAy`{G6m%<oYOQѵǧ:;y< %=_m;GOe^{snʜ4NMl.Ҳ^~_1u! 8'3(N}o2XZ+XA] 6ɘZStHfLid"X{+TC\Ocy;b.+[yMWEy8tu @u4u/zĺwȜ1\69ʕB8E#c(=Y[W!ݭodnR? |; Q8 Xq];1gtV16ۤ"0 >3nC5";9"'[JZreÞS"!@/^Ń>h2C:hoUĤ&@z)EU\ ?K时ZTg+bȦ5-~^=Uz}~V Fݍ:_2X Vph/E r|JXSq㔻A gCM ƐcG3@\얔׸T)qC%MROī+Q)J*:G ^$ڋxq%G7Sy>9_eb!ōԔR9aO{a"}[W&e/7GX"?JxJXRPf'bz sTe vZm>ډbT [bmIF{٤q|8@g$Uh4>TeZҮ_O_|AԚybՆz&s)tiAd}%K<S_R?ym?]L< XFW F !M3TF%u6woF{);%^_dq/Cd4դkL?P{Ovp;ͽE"b'stD@4t-xSͨlqM'hi4IL{]|[ (W\@/'b#naZmzty1a jDWfr7PtBZ>Ow'MDAQ%sRv7?տ6xG@G0Rnsqvv6~w[nG&Œ1m%qzLHPL25-\?4l z1w*c0*bxߗ]4FQΌT W|#8u~[>%+*&s-ӜJ˒{[OMܔ\rt 53JJ#xR2vlf?}>v! |yQ6 04~A`:bqQ''{ I<#{Ô -U,|`^nYvPSQ*߲bOYWq>Bm΂znVf>9#ݺtC,jݦ8yYg[I@Veޫ5}WhL{'QzA]⇂Ns>t"c'M.BvcR/ap,J/݋L/OP箯ݜgS$kxO0fMDYAF{"Ӂ )8e )pYbXY[(;X Eܮ\@&~V.8'79TY1+l">=(\8|+$d<UP7vb^{]QpcY{QY{W94s6O݂WGW}､49 _(ez?@q۵0NnU2x&On)LP;Cm/i浶 3 TGsea ]%̑f NVg|))J=MM'{ERl{+"xq-iqk %uʺrqNF@y-3J&{UyVMF84/;ACU:g ! W9ƃO ܪi%RP"ZśyI݇  r9K#_ܔ9āU6Nv9P ze@oMm~{`N\wdW|Ss-]hjϼq!c֐RCa ;`st`yJRt39~Ĝ[l,)r#FSSqoI[JJSwȐVcQU"IGciy.&Y.zxgIAky&|C9-<xI)BؗSM9}b|Sp*ls;/t$$^mR2Y tV2Z<~+}.FDYأ̓RƔ$oA무#Fy+JŴ:c DsP'?坚f myi)rFKUKCb%)u(=*|C2OznUR-b-S" w.#=(ޔL1L - Uq~[}u˶ӽ@ ~t5%1>\;}k96 l endstream endobj 329 0 obj << /Type /FontDescriptor /FontName /UFMTYJ+CMSY10 /Flags 4 /FontBBox [-29 -960 1116 775] /Ascent 750 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 40 /XHeight 431 /CharSet (/F/bar/braceleft/braceright/minus/multiply/negationslash/similar) /FontFile 328 0 R >> endobj 330 0 obj << /Length1 1413 /Length2 6232 /Length3 0 /Length 7198 /Filter /FlateDecode >> stream xڍvT6H HI )!] JI " H7)!)- %J(<=;g}}'>< BI@QSD@ ' &4#PHD!'@@@ADD$@M0pp*\vh옿6<w9 wC@&mwN:(Rh$?'FOЃ<0a@ L #([' `' 鎭 ap7;W]?@_g_P @'8F{A urGaP!6Ρ.vG8 0E3v'?%{nDE aH0.W \M,DfG" QQaQ l7v }]P.-a ~C= ߁H aa@@XX?Ձ"䟆jH[ *r  Z(?7@lo]./T0NNܿGp+d  MN5q&8wT źCiU80"G 0 'rGz` aMg}c/wԿ*#mP_nnPoVc""֥0oy`$ -[ɯkHqsF~ĸ5oU`p/ $nCUhI<'Յ8p4Taꨫ5FsG&x y'D(w-+z~b{LBamov;h"LChluSm;dKfB?hپeƱ31f1P{0J"X){,&on7Azghcjl = ߺp))&bu~5g-6>#R &ża$W%5ծ_h ="ndH' Uк/)P,29I.܍d T؇UP4T̴}|3}8Ynu{Ke#y8x>zF=3i~ÎY[+CVtH1>52 P'M涳2 2[ér7HHE] >\\9FKag  &})ߜ3Ϧ+ r[h.%mv&(׫a_u /k,w8.˝N~S#[Lֿ ϯ2}nC뾼hPwqbinQeLSb2ijlRTpl=4(FbSn?y-A]PsXL 9U%e:[ s%%?aaf2v0#?UNhRW$RH'Y#]Q`1,?_s;/Hk/Q!)!\gz?UVԹDZftO j?й<xSRx\*EZ>G_y0TW՛z.u͔c>4-#t!u=-aIgV7u/.iƏj gGZbB.&K/SӖ ]5!2'U*| ~/<Է͒yy+oMJWjm' h-6 ~BgWa@#-BrWko/OK':Xu.|LvԑզS,B@Sk$J"Y[;}(πq/$J RR.|eN _Mk)DAuX=2~uF ߙZ%hPWR_go*;(Wt_/0@wձIoyEeE!jÿxEε,ժޓK|}tviBf{2k3G_ei4hhLQ0\:2Vr.ވ?d$dC!7%_J)]kwD&Ռί=cn[C -܏$D2M?ƃoU+Wyt*XiX2Rѓm-aj_[|JFfqdg{ѧAB<զzzT .R&:u%^Ɋd1HŲ"q{yǿ h l% O7"D?Dt&>$Z꨽ q nhzdښlG9,93;h{Fv\9L7gZȡqfᖺVaٳ V+ݦ#tv c$dɏA6>|=^̣;UHL&ƫ֟ZNZ2)Zmi^~ZD*уm}W4I}-+ ?Pf;I]a偸 jKX3.=:R?Q%0Hzn!-кyJMβ ZZ,ή e]l˒U#Z Sy޿J}u3U)eO{XJ0ply-MG]ܺh1Aoϸi:{'{B޾t|U<|wgTV͜.)nm›` 3/`,["Ok\ S~R _Z?)4ޙ+TJ}A5s# <"*A}@LF#aS+>3gLt.9F~ TmR!b)Ԙ6쨾_|GK޲KWgά}м.g Lk $ f#vdwgk8[Zkl&ɭ! xxfrg$$f95U$"H7u2ch|4IEZܝYmn,ݺzL9Px c z*nD<8LFxDzGeKjʗ%+}=27'dFJ4M ]U ;T=rT.n^Gf Iy񋒒yt͐;89̎mgM{Tχ_nɄ~qbYF|WiMg`t vU܊1`tfj̈z'H l5BŇbUwR;=ED5#xNcXPƽx<2V/-pȌJ~fF^6:DcR*EI&"8Ϡ׽XUyIWK=VnIIV a1衮z*ʠj"R" Zׂhf-k">wE=E0?HbduKNۆUqJOm v*7˓Q[/ZTZCFFWnk4sY7`V8כ31?" JE2LW|40X,Q݃ʏKCT1[87и$ @"{zÈBx@6Cs!^}*TDU${;uYbޱsy(['@T'q}vaRϵ{̮]W7b^Y5YCgפ(~/XV:'a3 uo% mnO2E@'4׌3yMASԯWvY|q sP[UPeo~zVEg`/H;A Ƭ XJv|~~ʃɌ߈`v5[}@E:vJ iRKkN\4:KyuQgHN,}&tƒ,^,cbB\>0G+? dD1B['Eo/شJNȗZ5dj4q'x]5/xsjOŴXxC7%:ë;;.̕i*?ak9֊'=#=Krxbm!ō$c>NE4xƄBg/g.(ߟW;hT[o;>/yG;h)+Y k4AR٢ٕJٛg\`;G52a⥐M/r;Wj׽r>1He3)nbr)m̉?Op߃߿tI+'; xZ{q*k3U zI;]6^t8tE'#@p7ڕXlb,'xo=Mo~h 'b,)}~7m^rdN7wFW<սѬ i٪~=IQQXi⹱GEflog{w%`$mv 2Dl5vgy®Cm]˧决d~NK=4^П}Q|-pt@%DClaq\ڼ~:28ʇCݬѸxQ4ˀx4sW:}ihА|ۨW܎)?=ư ՈM7Ic:{܉U!lf]@YmkobZU~C>ժ.9͗iQܣi42-u'ʠymU+iFa}`=! $mAh1BbJOsm ='IPqjNK^:Lzf590?KaI[{:U_*]ޘ:z7[)M+EӬ7;;M$Xj`PibIܵ7&o|'avI{)`Z 5AU43*'Yv9RDCÇm!E<`%ƗO:@yB5beW_?&0*rk_q8/ckjHyќ\ '@ 3BAI['D== zPj;jcs'd/&7Ȓ}ü%w P|ipt=)e-giA#Fm_eE^bn3/K?PQ7aro<_nl= rJ.}G! endstream endobj 331 0 obj << /Type /FontDescriptor /FontName /XMIFGE+CMSY5 /Flags 4 /FontBBox [21 -944 1448 791] /Ascent 750 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 56 /XHeight 431 /CharSet (/infinity/minus) /FontFile 330 0 R >> endobj 332 0 obj << /Length1 1570 /Length2 7305 /Length3 0 /Length 8364 /Filter /FlateDecode >> stream xڍtTo6]²4HHH .KKw7)Rtt7twK W};{γs53\s2kpK#̠ 8+U1п`V= _YG(HO8@HX+7(<D*wwYZ!Qi~C8 QQGvPG VP;TFH.nDڋ<`;'$#+ iІ:A]_*!`Z: + @0pCe5=Wo ? @v`; n B jrQP% @P7Wx]w{o#a@Y@QN`( ߆"0` QwxQxy{9n/|Z:Zj\*&#pxrܢ xgwQM0QnռpK ?3AA'Py$`p$5V~~p3,BP9٠c:j ` Z>jt|(-Pg`FQ / 8"a pkovw/?ZqvtDbQ}A!&AAetܫ8MaH7Vji2/K5BF&8݌[2璔h29=-PFspr2~ýFXF_?,ʿ^wn(  fNCFKg5mcD0,"{ cHRu ]cDbdh.ܗbR{gg3:;ު}* !!PaPuBc![{&.mӮbDONk(;jSjhcgUbnn- +al55+VO& m X2#tv[e#>ոXXoIo `*1֙Q F}:^3yEJJ-{Pm2Mp{B @K<C4uEuK%6".٢ٴ}ּY0Io&~ J`(27&G to2|@ܐ|tOa{8,0>TI̯ Υxn}T)k}Rp,g~$/ωw0G7ʜSo ٷsI*.,;N˜td/luce2}18 *tz8z*Ot)R_0[O3XaT-a O%i}(ɋ }!#3rj8<[3}"Ԩ钋}gN&Gϔ7YCBLީ}3|̷?_ 3Sl.eRڍcϖЛAnOwemO'A\MByc\@\ u,sRo'IX/?zE $-&C{OPDR^~ [MXxxIE!FsfpQF87'`E ,>eƫː>&;uJ%'%, _zz}A.K~#ZKsBp^T* O lp=&%>< '9iwT!eD]>a+ lV {7y80=Հ)XVT)7C>K6̈X+!nn}]N \yAa47&^0)M.W<.Kꦸ.S(jH*/%s4a23AS?cfϦY@'zϬ1˕>,<؆% -P6a KS~^&䃵4~}~f8AM69hS-Rc0Pd=4:׆c}kX]Z"!m ymX&[G?qU,琦Ӻ~KRmw7/ :#+8<̜/鷸B~BD+/z~b$nhdzM"!d$UyZsCb"xX1!@[w^^?ɛHqbm8h=1~ُqYл [tYj;֌ܕm͒/?o!}'ly݃X:d懍.Tz{oi o3PYbE"Ӿmj:v'D w+^DmZ%5;u}T|$H-.]=ݜ倷ƁԎsJo^Q6AIَ7HökYar ~Ǒ}?=Y֢DfIMlЪ$å0^q VE-b) >{zs.'xP^ LEd"t$46MQ$iݚ=5U 'Iuà*KLJ5@2ḃs XUO{BvLw ,1Chu@߷G>~krVApq F./8P{*'¦ M:=먬ߵ?%,zM8Bf3.2XrK_ypC͒~Ƶ1_ec& %cxwԲW &/U& VK_"SXRD"|,L)D~\z:[M -y52̮,JZXD:.#nk k",u=G}^ g\Ȏ4>oXPTW_kļ:9C@㇂ _N?~#'lVy6?qX]Ǫu1%"-7}Z9]|>^+_}k 告| |/9wD!2۬Sr_l2QLM?\"*WѴ5d)`wJ^rWJ(9Ōyh2Bw39jåA]6|6H_Lr=Jԡ{v@V{ݦ [2¤=cwSN/7KXqj^Sc8FMTw] Ե6^ꂡ,W]/]! 3;[DOtGV۶Viukj[M(2S{MJo`l>?l8m$M)AFLe[[SI-ssA.GLۄ k+;g܄VSwI8S)ϟ6%ܔeXj0!R]BJG׷~êKrwK?/r/?klc%1| sO6$''v w&^}񍝌f@*) fLS+"WSS;/_,fH}ip||Z`6^br杛N_ՙP.SE$ﴂ$J@f{?2!j꙳>t:Dj[tljVf3g.XS޽|-d#OwYiO4wj M$Ls>Դ^k\yIxYNՔ̊XfU*gH<{v6{ gImcv Dx*gyaJ E9]L@"~Ce:5'd3aM(ite6V+iVWthNXSf-FwΊV :;/F9/0kc8 %ZHkeG c$2_l.qڝ3F\eu|0Ou:D]B56mgJiAÆfxW_Vt6 Q߈`ls+?k>l+>85C@, H ;nlXB-pek}dԦ\?3M'RR("[] =+gT") p=㻴) ^-s9+&y8qbm ͛Cͨ=R8#% `ǽ@҂'頋8Hk)u{ .XCky\s:7}"{?9^2촿_GoowYq:~ e彤s|zͧs|'7 {gc= +$vTa =%cM-5D}BtQL7*-AdYyYfppK*y'?NxS5@ǝ@2Q{cB EKv jnnW?bO^NX_>oiy\XؼPdxB6o:8xnC%(at+r8)NoɄ4:г 1iKقwsFTN@1vv9[/cm1ۋ*|F= S~P # 9_յ2]R֑f1U+ޣ3j9=U3S 7ʾrM<+:Q}Pچޭp mtUDjgwY ܍F>K?z½]}-He)磾|CV|4L4X$ʯyq_]H ڄVDMkF]2Aln/]d4jQkZ|h5`S(|l Ԩ41hC\BfVOX{x\ՌH*=C]MOϝt[ Lt'|TA_K8kf=1B bo&}cdTS dC˟!H?OtijLyĀfKӻؐ$Ӿ-&\ y K3z2f /b0.&F f&?;\˿^Iy6h^奻8VQb.;h6]Џc;L`Fqo_:*zAY)ald{}/wD.UC=X&>Q^֗?\ֹcOsӸ_400#&-U$Ah1^-,rc#bv6dkk_K2pњս6 |c> дzǾ-Au)ܟ^+fdaIʼkKiFU7?Fw#k1UC俿l:+)Rks?'e3 30lkCIdz?ؽ7m+(Um</)bd.eL4!a5sת:6K:P v]LO.#*]paY,`>x1;3?QI šwF^&nA\N4/Ɠ00)3YV4< endstream endobj 333 0 obj << /Type /FontDescriptor /FontName /QIYSQL+CMSY7 /Flags 4 /FontBBox [-15 -951 1251 782] /Ascent 750 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 49 /XHeight 431 /CharSet (/arrowright/asteriskmath/element/infinity/lessequal/minus/multiply/negationslash/radical) /FontFile 332 0 R >> endobj 334 0 obj << /Length1 1606 /Length2 5348 /Length3 0 /Length 6140 /Filter /FlateDecode >> 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 335 0 obj << /Type /FontDescriptor /FontName /GVHTSJ+NimbusMonL-Bold /Flags 4 /FontBBox [-43 -278 681 871] /Ascent 623 /CapHeight 552 /Descent -126 /ItalicAngle 0 /StemV 101 /XHeight 439 /CharSet (/i/m/o/p/s/t) /FontFile 334 0 R >> endobj 336 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Я) > endobj 338 0 obj << /Length1 1630 /Length2 16141 /Length3 0 /Length 16998 /Filter /FlateDecode >> 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ͻ> endobj 340 0 obj << /Length1 1166 /Length2 2936 /Length3 0 /Length 3685 /Filter /FlateDecode >> stream xuSy<['YK.ɮ'XŒ-ƒ}6=c̘Y5r#J MY"k$Y*,Y;۽9=#}i!&DUCָET4 8* #PTGPd@aB XTIC$HxAѴ@Hx)D R/V $:2vβG~"pMMM@ K3A HکHa @2iN,eQwdTBI"WRd0ĀȎfF82f EWUb0!/:FRr$i'L S@WiVw\٦P$*j:Y$z}YRO̝Ŋ96U8hIM:Ev>]f"j[#8d5\Hʼ6cHb6dUZװ>(!65h&*Qrt93|-Y?*.xkn?|/h1V5P,Ew6(Y37u>:5LMQ.!H5!4hV2ϸ4^*K )ɕYO >Pn{I]z&F}ز4 8.ȰJ &[bŨ ^o^Q7MQӞEԗfq겟?a#ȒA_J5yc2׷L U-q X%HЫ>94|4JL.v\xxXٚ]aadv-,no^ꌉOc53HX݈;w/¡ McRW [[=L1IgqqŤreR_LKitvBkiJrj; ]FVr'!}鐍IKMb+WҒKdS9͇%^Leg^ lF"" ~bB 7792k}^ٰw-J2e ~&mn(舔T]|y+bTҐzOrnW;Lsw #)Zfk5i҃ޱ3i}Yi L'%l9 ŪbKz+? _,$>J;?&Ox49YQltZCfduG=?]xz35&jYGKGzaϞ"'w{[!?t8~Jx$TeՄ'' +-VUox?->|3vQ,}瑑[/ml۝bLS%fi˒kEdӌUx;<ڥdtR>XBe˅@3zr1 I`擆k./W1^RL+y ۏ[q}|yLPo[rז,?`Z$s sa.R=>NL<=9!K1wVh.ةb$nhûqUW fхNOPKZLJ}~,V¼Wc 䵕1]:7<6߽ LX)R[w$Phirkm)}ԹZC4i¢Gq(l-엞hEI8YVr+SZx0jGXJmc2xmuig 't̫nQAc3]8r%<6&Uo֭>(.Y[#Ej[&iyn>AxβpAV]YlzNhoL.qg=1zyO3ХrKZ/J.o&*I(3]W:bɭ ˝zH0ɶmnsΪLg=b5aU'/ 0yxlGٷ NMp`EFNqVAMQro󤦆CD&Ɍl0A/z0d\FTjq ܩZώ&.zƺ:Z3Tf(T:!TQU>1Z<\wNUm—]8t7]1iǛaș-Ul5> endobj 342 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> endobj 344 0 obj << /Length1 1642 /Length2 4693 /Length3 0 /Length 5517 /Filter /FlateDecode >> 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 345 0 obj << /Type /FontDescriptor /FontName /VCHGJK+NimbusRomNo9L-MediItal /Flags 4 /FontBBox [-200 -324 996 964] /Ascent 688 /CapHeight 688 /Descent -209 /ItalicAngle -15 /StemV 120 /XHeight 462 /CharSet (/m/s) /FontFile 344 0 R >> endobj 346 0 obj << /Length1 1630 /Length2 19014 /Length3 0 /Length 19836 /Filter /FlateDecode >> stream xڬct]&vvl۶͊m۶mvRqŶQQqz޷O}~15qM\sͱ7 =#7@YVޞKNWCF&djbio'jb 05L\\\0d{O'Ks  J1y毧_kGSS) %%/WHڙ:]l,ƦvΦT3{'Ϳc{;Js% 08;[u306uGE p0utv t;ڹ큋=_ ۿ`.N.QE?-f-M])_0.vSbL,l = d4\-3Z_t?/:8x_V3KgS3z&1]6agVL:_ gf&ahbog 015aw@2 B -jc#ohwcY46N?C[K0w0)ÿm3K #=㿅&.3C=\/j+T-,!*S;Z_?0fP z:T#go? {9t̜L߄Y}7!g9C'KߺU37gtT\ LN6vurKߪ7505Y_7 ti` u(oV-) ψ6o\>w<>O3.%YMAsĠWy}$ Ψ~?W?u*ĭ(8)<3ё;G4yd<~D).N_on59uj^+Oq{LW,B+F2aq%I"z=+RkMk\q[W$2HJv)%M$92ԣf9Xq~U u@ժf 5^(ҍY2vzteԲ y|Sd8InY]hEw>$cyGܶm!䎑'{yHkc _0=l)ۇlՒ揓/cMվDX2iiՉ>ݫNb?H<߰b MyDY#,ƍ4H~g0g9ӄntkGc5Fق~LoATot:D9Be/'ע,zcj͗:4g:lͺAl%XYkN*JVzyZ<(MڛʒiJTkK6ֲ"Uz4:#=y;1=))ڸ5DJ4^jQX,MC!@L 7:ꯞ j_EYX<,1Xc<7Z@_*"1~/,%#L6TXwAeZ|'b@.'=F 閦͎`'KLU`⟁\umƏJP,El/C8br?'Nz: ҝr 2=rĪJ/'ՆDj,ݒ_{Zf5&vۭO7wVi`*gtͭs&,P_Vxs8k,s l4l6~YFђbvG|&w:% s5ӟ, * O}]E'_92*-=I˹4O"c'x;S/<Ոq^ [bAg3ow;?3ciKUx+"E!eE,T X@EZyf"_CVUֲLWCG:xq$դY6n߆)T&ܛr}îfϰ~|hOA @mKڃ||!/H‡O!g Ո8u4q8Kدv\ Pv^ٚ8m늾q%/# bp Ǹ3,⽚R><1:xv}MsxKC6h/HPR,qX^p6|leo꩕;SmMg%Ef#pe yjf#jQ<'}"n]ȝz`'y􊿱_5"$F>1mkTqh$-1u?'K Vh$->jsZSCHV"aR)F]u }Qڦz[E|%%WC$\FaUAa?Fj-Z95{V *lB;zj}ZĴTEbpݷҍ[p̡HnIF\0Zjp:ױ{2_xW.A`1sW؅^%0(z>̈ 6ψ2G,sa+wlj2rABP"9Wsa`u︋;fF ,pT&Q}7Rx dN`фNzdh%PPu>o@,yP,PGF}8= \83(7oDJ{4=EJμVzPQ 4q8I/7mzUSmQj3_EGmf-fde3=Pm|0 wAke4S5.ܴ'  =fۑufZiacjMcV?ZXU-鶠MNE'* s΋%>p0÷$V_= uW?&(xק}qڗ Y&GuR:*\"+5 Yb݈h)(S+iXSj9B br*vMkLCwP)܌X̐>3g}\Ă -؞W ,=W&@xp*@Iq6I|Ojz>DzlzH")曦ӛE|=Rq]d{^*/tPuf%PzrJ o/iHe:3<雟W@*0/ yi fo#K5ȨT9\y(SdaC1{]B*i>l$sI cG=vuW,p~T qMOmtn1+lc !wpL`^ p%nlY;hGX y 缝) D)Ca2Xy?ikOxk>Vz1Y}]Byһ<I)<^C_HF +T" )Nv;%ʗt/LjKfa*쁽C, ٕc}qG ޼@Z`,s?z_MwE$sUr%ΰS[K\NJ*9V[ =²N@p- IDWu͸xqHЗ9Pb⨻4լC .G 2 $H,œ3?#^Y>L GbGRKwA*ɪY] wE{(}XgBbxXJih F7t W2d5CMbl+`T/w,b/3`t`NoRhi-YݖfrD+ qRGm*[ZNUvT5*#-C4=uBX/~ @Jpm𼽍N!d{nU4Ig¸1;Wxa6e tC1?"u G;(,F='Ub{anjT$ E:cڑ^6*'~v46X*qLie|v7pb2oޢޝ}#뇋.PD~9SkHOD*)ğUTHO4u7(90%涡5]|ؙ5Zػ2lȏQLʖ @!W%ńgztdrIMYZcRM̵'x>zQ2-ڄ{脤2 zhBxv-e/{G#IW!q3C_9)y wwT*瘨v8piΣ^ͬyxn]s#vxZ60V1RT._:^?4@3?Ey qhR43T}~R}y=%AS MhQI^H3ً6+\2 =@cNH );V9A85l IZda?v]S PicfK;UXP1]Т,#+Ѥ|&к*lٵ~ V&6)p%Z>iBh8iӫ /mzם~=(EМd=.1xN.p 7R_ +a8ׯ؟Hex6TyvEeuF8ݛ/vT>53WL'ﳌ-7AD RD PK}* tD7jج3>- E,G%.LyT9m{,3Ku Oix9iK1'i6:Z:eLys9۞ٱ"T}`>z;:!;ʤyb~3 *1h O mǝV}8(.3&APDZwXhsNP"};fRՏwDKJ_GYq: ,* 6c adReӆ 8p VTYPDGSTO 8(wB!Q ѻߙꄪX\w2Knr1>?\XSvê깢brݽyDPEKL] H^IfȻKpyD mctNUoc0)̣[~[8*|F1Lʹvo--v% &9]oƑv}@]vmJ;JM>r6aF %y,-*iHO̢0r7`"}-7#A_u3i`쟩2q5T#*ܱL_ ʋ _-2/:⒗r+cԔ"i<֦MEI=Dj a k@B)1 Jtԕ'2Bi'X6fB[aL3À:PPdc/fڀN8VnF3ChQÓh@( 3a|!kr. ¦QJiVAF Hv] gDN*K?%VҴr1}vi(G0.+b*K<7xpv+9F$dP D_U^-UZ :R87-<&|Qh:"Z;Q ǵClEq =Ll7$-D1aqp8xnW>&bH U#J )lHZBQɎ K1HVH_S>EH_gdr[Z><:9P_mE[3ᖪ3,߃x$ VV ߱(u@С+Oɹf)?XoߚTZaݽ7Yms Yi7yD;$ƩN ֏jCE~u biu:X%=S ,}\ ieOGu UfU3p<3$a]=0YC~7b };'h>dv!I ;۔4naʛڭ)Ь @Ƀz *PWd:gxϪE*lZL {t |l*7X)Q-pf骺&#_.G<З:QL%I 2=."uk.ÒkuWqxbw$_MjDžcDu`e==O%kTl Dv/(gCnh9Fqi:B41e1Ix|*ŏ4U\BFvjg 7}B#Dw@],q-C(ovԋFG?v. ܺR ßd܂%tفI^PڎuT0CgG z墘Xr:WGkq||5G;tϝY5h2gX?+%<NNCgT7 0yFBz2 2H1F$vӢ#4e^V{+QFiifh_`sNF2~B[؀pF%a5e7nrTz@a&`S~A,]rP#Ny!kt P+ˎl0{{pA F[ F5vVwʑ{2C6$ɐk?I߅evN>zXדTg }.%aLZ|-Սs)>L 7HL5:u@, :/N*TS_{[ ~SO6Z~Yj̻,aN*2{n[l. 1I,gP鏒sDoF4i DH4q R:V_U*O.潞{`G Ed,}:q\GWmY3kQOI\?BLI=ԥh ƍ3A>Р@'*m纬h Tv63qMGCL: BRl=Ձog6!nD /FD0 ze/Vx0tַ:,han"A2[RIUw"d3֯ڦ?]w)ᧃ^Jޭ{%CoǺFWT)ZgtXÿQcptjYDF]Qtt3=鸧u$ݬUqs I`j L`"d-߽q=AYLԱ#oi=+6ќ='#zm-+Cm"GK5"?SoQR9,=2|HX sd0ysnJ!1N xz]!xuX"߆E0Q6q,Ae Ho*~/Cj2iğ'͋䎹&,!s{V#'̀KKĐbBv 3uDCP-n#=琌Fhȇ~ĖW?PnuR!&ǥ@^K{-˳dq2P򌹰ϩII}v-nQW`wz]8K%8/Vj޴~QvRV B ~4oݻc3\nzU81Z12͕ݕRQ`M=V:G[|!?؜y~Hh99wB9Rd;SϣrgAnWO 0l c bPVT;ދo+m< ӤA1eQtNQ9 Oq__4Y0gu?N%gR !pƣ]zZr/ft0J~7߉.Čb/$8{ N٭|=?_ awC{E'py/"ng47'ˬ(Sw'#$ܫ&t  w1ʗOB >N~m$x۔uS `w2?o1 j0- jl>v l=+IЛ<;?s8mV_.ǹ!*dqcq.o7j|^ި975C(XBRƉ `~7P7.6'טVd\G믦mɮz('Mé ;AX0JwFBU}o4ҡu*s_\?<co;9#dZ=]TZnOLt@E6~ {tDIYy˴hX3M lq_Q e  5"<4ӧiOAe{,6 讇8Y==rxd]k_2fP#!KYI,Ǻo/6:ɢyP]QHSι-Rhrަ=\ ΫJ !yiwPs"IYo2Ω"C4+|ďr_a#&9%}_ɄFdv,B.M:z;^62ߣ6&BfPL9 V*˴Sޘ'82=B5Iړ4j UG nbmfAc161k D7AX_%i[,! 1(JyH?$ƔOn?s 62%{Aaļ!Ba³ Id:z5% xp^t_լo$&.LQD d2@E D#*|M _$42_`#)KolN?;ó#۝b/(y5Nuu'լOz]znrq!NhER7E~Z& Z4d"VʋYrɰ,RӸ4`bvy; Bqy/јl,զPs6H v"yǝsO>0Զo=9]*}a=8YіS{&"ɍQl@">O4=~`ϵiVs04RJůũ <x%|].1s F\5: RzQ8} :s26$Rݏp>TF~IdΝwKϬM_^S]9L 6rwu;ΛtkNFz=uČb9EbcS:K.?h߅sbEtd&z[-iy f+.n]`dY̍dKt+ZͼKRLkQв/rj|Xr-ɔXDǎѹxzz.T|IEX dM$zDZ2!_QwܵO ӗ 5elzȬ$:~~16]V3k̚KRXߕ-NR^z5.8~j.tlsn S]8n; O6Tu 陦g(aSЉ2K3:J+Q|φP- ,xq<|+{ūS|"GY9zvIiV h3AZxʼn ܑ$G[>Uhp}uwM& 408ڱqz&Bs(Ha8eǪQfY_H:AT,DǮU`V5fZ0O[p~kEXZ@/S"~Hݞ ϴaRM,z"ypuW"xYٴ#eCw;xP}[XSF7^ٝ_>n6r~rA^6KACe4UxE 6ذaycA1mr$61R)q~`r|$n~ځ];igRa%;ҡG eF{Ie .sټ&yk J=τIhO>OZF]p1C:[6z9GNa8(=|,autṗ~dnyu‹fW I`~$|>Xۏo؆&`x9Pp+{ۋ'jbca-N#" 4$pgN`x B{Td;~P2tA)"bGiU޵Xzn c7aKMbͩ7?a'S jѯ_lbdnc4E|1c[$9KZd8Xx0 OBWi"[Rg+'"/2T :I 񐺤R}gIqer /g>i@y ;7MS꘲wώA Tɽ~EW&h_{cg>qa&jh9~ d*yϺCo4Jx vU9h !(؊ΦV&VwI1 '8KnY`@47VmB}@PWH *)@R_tI,:YvT#$ xShȒܞQA_?:=h4s#IR+[%:UvWK!N9_8/cjb,o^mQ\>ŐgNBt/ХwnGNnPq5-8g8Ty|&|=Ab(d}uT'N2ہⓐXiz&|aUp&(ͦKpflTD8G zfu/1F?.ߋM,%MZcc,w190kS_}ffC}4I 5(MX}F(1G(@L{էZ1A`Uua^y;H֭Jr+B4*y5܂mjҊAS%D_A>)B\ p*`Y"yn&р)ٌ\Ŏpn1QY"+ (P?rP'd0K>.k&'n2 ZwF v $h{b,OW"Zf6](T>(2ShTfDm{A6`i*b{pú[AR^! ((8Ti=n؁};EAO} ~N:;6Z5yoydg!, S~G0-Qw0~2,6fB,X r%1S:rPE#&'=h"uP$"4s@`S69KոE*`GaXToxI]}%CkiVgO*]F!LSXrj%"xPFrA [EXival_"dWM-]ˬ0cCssW+NK(IlAJM9ƍ/=ʩnj-kmCIQg2T-_O@2+'-U3Q .bwf4;S<]HD+O&**`q{Q8|f'-)lC3 gm<~(=qz`9a2ޱy3Mc5ك.; ]cZsbblc^%Nq;?1;b)NEIxCw;7Ἆ')lZUQ"j|hdOa/9!UtsڝCi &\/YUvmiQp1Zl-i9v^鵞U6-;*u:A\bͤq+('z2P5LDzQ !a4t)\g@4@2RL`=_c`ge{zx"0/_4@ݎ^ˍ| >:r}HvK~y"D-C'DMgʱ9N( N$ [Y_y1jr`d8yw6~-B8a@A teWÝŒ򉃻VCuU Z#PMZvGJʘ}|;]ս֤YG`B9 ^"2xbiPԣ3 ѥ*HCc)X(mLWN8jZ%x?>8+Ί4#gp#v ""!gҊcR~$ͤ!z3:~B%E]`Jxz]Bzgs[xir=M)'͛L^b^eo+]Oa6 U q OHl u4hTa2t\zCӪmpeAz -Y*~_֑ѽ\y$k^]?U֠ Ij)H!@<{4L{٥XGj.)JN}(B-ЧMܭl?Th!ƌ2~ʎ'C63@ʸ$* 6&cg=f"%|Jq¨@ {#zŲ/.ٙl4l{iu7AY՘PCjM#%{:6'%y,:+>Ugۙq-mDl}ڂ)"ؤߛ1 Y} cv}K$?׼u^g&0A:"ҸYեȒl+ĔEWKo;][g<+^"G)yQWĭA<8AH:vDuy[u_!HJpN<̦.aM i1ّ[~9Ŭ'NR1 fr~(0I@bg.xrtҼXFiG[.4&Wl%C^\ȼc\5vM4X+r4of5fǨn# '$hj Wf#gd=!GE05"d![7)N8_o]7Tƶg{߃FpaӁ&;P O^=)yJI^FmM οL2ܣ8s9~K9t}14ՐN =ٰC"݇wU"iѹeJ$rނ}a;W#ޅ~Nn t䮹"I,VG@G݇ Zr8/Y-᧬a wL=SɰE-$7-&-"Ѿy!־~줼 o;vWF/OucԿ; 0pߠwk_rOC~5{<+ W.-0aK.oN Zgq;E_ZyxIBŔƬuE.y)XC3h/z6tAMuIV(:}Krh]NI݊Icr}x,~yxD ce:'4d ˽}1Hݸ)%ֈ-5p;{/>j`QN6n%h3NHN~u]1Aϟ\]Vƾq.i u'@V2Q3ϡ[gEDF\1ͅjE0Y(56Dm5ّ}fWJ* cZtd~5U,Q–U_rRcMVN t9mEM }DЯѾˌYvֳ)%=K`@ afW;+ TSz8*3"]m<} ߖhg&˴ŃĒ0Qd53pcI8NTtiPfHHCql(^X턎pn\ zV9_9Z!$H*_tG 2e{萞6 `4 ̑U| 4)Q>14yc=]HtȅHi >jRBrA3WaFKG"䉥@ȱDʠ\vl_><)ؓgu1,!/Q7*aVd/U0\ (2y?=zbjAY 4Nj2ShW k P0z;v(U8'ettw鈿8m,G$bY]t㹠?H?};:8̘|\UmD,t YɔT÷Oed[8.S;N~Vm[ܡ6) ?v X7J<($^aN03j Q 2^|0NWc0;>Eߺ)(Fvdbz69J! endstream endobj 347 0 obj << /Type /FontDescriptor /FontName /CCDXSB+NimbusRomNo9L-Regu /Flags 4 /FontBBox [-168 -281 1000 924] /Ascent 678 /CapHeight 651 /Descent -216 /ItalicAngle 0 /StemV 85 /XHeight 450 /CharSet (/A/B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/R/S/T/U/V/W/Y/Z/a/asciitilde/b/bracketleft/bracketright/bullet/c/colon/comma/d/e/eacute/eight/emdash/endash/equal/exclam/f/fi/five/fl/four/g/h/hyphen/i/j/k/l/m/n/nine/o/one/p/parenleft/parenright/percent/period/q/quotedbl/quotedblleft/quotedblright/quoteleft/quoteright/r/s/semicolon/seven/six/slash/t/three/two/u/udieresis/v/w/x/y/z/zero) /FontFile 346 0 R >> endobj 348 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 292 0 obj << /Type /Encoding /Differences [2/fi/fl 30/grave/quotesingle 33/exclam/quotedbl/numbersign/dollar/percent/ampersand/quoteright/parenleft/parenright/asterisk/plus/comma/hyphen/period/slash/zero/one/two/three/four/five/six/seven/eight/nine/colon/semicolon/less/equal/greater 64/at/A/B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/bracketleft 93/bracketright 96/quoteleft/a/b/c/d/e/f/g/h/i/j/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z/braceleft/bar/braceright/asciitilde 147/quotedblleft/quotedblright/bullet/endash/emdash 233/eacute 252/udieresis] >> endobj 109 0 obj << /Type /Font /Subtype /Type1 /BaseFont /UAGOMC+CMBX10 /FontDescriptor 313 0 R /FirstChar 49 /LastChar 49 /Widths 297 0 R >> endobj 21 0 obj << /Type /Font /Subtype /Type1 /BaseFont /YHJIXX+CMEX10 /FontDescriptor 315 0 R /FirstChar 0 /LastChar 112 /Widths 301 0 R >> endobj 8 0 obj << /Type /Font /Subtype /Type1 /BaseFont /QDOZHF+CMMI10 /FontDescriptor 317 0 R /FirstChar 11 /LastChar 122 /Widths 307 0 R >> endobj 104 0 obj << /Type /Font /Subtype /Type1 /BaseFont /GGCSTO+CMMI5 /FontDescriptor 319 0 R /FirstChar 15 /LastChar 120 /Widths 299 0 R >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /BaseFont /YPEFWL+CMMI7 /FontDescriptor 321 0 R /FirstChar 14 /LastChar 120 /Widths 305 0 R >> endobj 9 0 obj << /Type /Font /Subtype /Type1 /BaseFont /YWLPPL+CMR10 /FontDescriptor 323 0 R /FirstChar 22 /LastChar 120 /Widths 306 0 R >> endobj 67 0 obj << /Type /Font /Subtype /Type1 /BaseFont /UZEWHU+CMR5 /FontDescriptor 325 0 R /FirstChar 0 /LastChar 61 /Widths 300 0 R >> endobj 19 0 obj << /Type /Font /Subtype /Type1 /BaseFont /PPERUW+CMR7 /FontDescriptor 327 0 R /FirstChar 0 /LastChar 120 /Widths 303 0 R >> endobj 20 0 obj << /Type /Font /Subtype /Type1 /BaseFont /UFMTYJ+CMSY10 /FontDescriptor 329 0 R /FirstChar 0 /LastChar 106 /Widths 302 0 R >> endobj 108 0 obj << /Type /Font /Subtype /Type1 /BaseFont /XMIFGE+CMSY5 /FontDescriptor 331 0 R /FirstChar 0 /LastChar 49 /Widths 298 0 R >> endobj 18 0 obj << /Type /Font /Subtype /Type1 /BaseFont /QIYSQL+CMSY7 /FontDescriptor 333 0 R /FirstChar 0 /LastChar 112 /Widths 304 0 R >> endobj 149 0 obj << /Type /Font /Subtype /Type1 /BaseFont /GVHTSJ+NimbusMonL-Bold /FontDescriptor 335 0 R /FirstChar 105 /LastChar 116 /Widths 295 0 R /Encoding 292 0 R >> endobj 5 0 obj << /Type /Font /Subtype /Type1 /BaseFont /MPDEZG+NimbusMonL-Regu /FontDescriptor 337 0 R /FirstChar 30 /LastChar 148 /Widths 310 0 R /Encoding 292 0 R >> endobj 136 0 obj << /Type /Font /Subtype /Type1 /BaseFont /UJXKBR+NimbusMonL-ReguObli /FontDescriptor 339 0 R /FirstChar 31 /LastChar 126 /Widths 296 0 R /Encoding 292 0 R >> endobj 281 0 obj << /Type /Font /Subtype /Type1 /BaseFont /FYVMNP+NimbusSanL-Regu /FontDescriptor 341 0 R /FirstChar 80 /LastChar 115 /Widths 293 0 R /Encoding 292 0 R >> endobj 6 0 obj << /Type /Font /Subtype /Type1 /BaseFont /XOSZRV+NimbusRomNo9L-Medi /FontDescriptor 343 0 R /FirstChar 2 /LastChar 122 /Widths 309 0 R /Encoding 292 0 R >> endobj 220 0 obj << /Type /Font /Subtype /Type1 /BaseFont /VCHGJK+NimbusRomNo9L-MediItal /FontDescriptor 345 0 R /FirstChar 109 /LastChar 115 /Widths 294 0 R /Encoding 292 0 R >> endobj 4 0 obj << /Type /Font /Subtype /Type1 /BaseFont /CCDXSB+NimbusRomNo9L-Regu /FontDescriptor 347 0 R /FirstChar 2 /LastChar 252 /Widths 311 0 R /Encoding 292 0 R >> endobj 7 0 obj << /Type /Font /Subtype /Type1 /BaseFont /KUIVWV+NimbusRomNo9L-ReguItal /FontDescriptor 349 0 R /FirstChar 2 /LastChar 122 /Widths 308 0 R /Encoding 292 0 R >> endobj 11 0 obj << /Type /Pages /Count 6 /Parent 350 0 R /Kids [2 0 R 16 0 R 23 0 R 34 0 R 37 0 R 65 0 R] >> endobj 71 0 obj << /Type /Pages /Count 6 /Parent 350 0 R /Kids [69 0 R 89 0 R 102 0 R 106 0 R 112 0 R 124 0 R] >> endobj 129 0 obj << /Type /Pages /Count 6 /Parent 350 0 R /Kids [127 0 R 131 0 R 134 0 R 138 0 R 141 0 R 144 0 R] >> endobj 150 0 obj << /Type /Pages /Count 6 /Parent 350 0 R /Kids [147 0 R 152 0 R 155 0 R 158 0 R 161 0 R 164 0 R] >> endobj 169 0 obj << /Type /Pages /Count 6 /Parent 350 0 R /Kids [167 0 R 171 0 R 175 0 R 183 0 R 186 0 R 189 0 R] >> endobj 194 0 obj << /Type /Pages /Count 6 /Parent 350 0 R /Kids [192 0 R 197 0 R 200 0 R 209 0 R 212 0 R 215 0 R] >> endobj 221 0 obj << /Type /Pages /Count 6 /Parent 351 0 R /Kids [218 0 R 223 0 R 226 0 R 229 0 R 232 0 R 235 0 R] >> endobj 240 0 obj << /Type /Pages /Count 6 /Parent 351 0 R /Kids [238 0 R 242 0 R 245 0 R 248 0 R 251 0 R 254 0 R] >> endobj 260 0 obj << /Type /Pages /Count 6 /Parent 351 0 R /Kids [258 0 R 262 0 R 270 0 R 273 0 R 276 0 R 279 0 R] >> endobj 285 0 obj << /Type /Pages /Count 3 /Parent 351 0 R /Kids [283 0 R 287 0 R 290 0 R] >> endobj 350 0 obj << /Type /Pages /Count 36 /Parent 352 0 R /Kids [11 0 R 71 0 R 129 0 R 150 0 R 169 0 R 194 0 R] >> endobj 351 0 obj << /Type /Pages /Count 21 /Parent 352 0 R /Kids [221 0 R 240 0 R 260 0 R 285 0 R] >> endobj 352 0 obj << /Type /Pages /Count 57 /Kids [350 0 R 351 0 R] >> endobj 353 0 obj << /Type /Catalog /Pages 352 0 R >> endobj 354 0 obj << /Producer (pdfTeX-1.40.10) /Creator (TeX) /CreationDate (D:20151117151249Z) /ModDate (D:20151117151249Z) /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.1415926-1.40.10-2.2 (TeX Live 2009/Debian) kpathsea version 5.0.0) >> endobj xref 0 355 0000000000 65535 f 0000002472 00000 n 0000002367 00000 n 0000000015 00000 n 0000416665 00000 n 0000415800 00000 n 0000416315 00000 n 0000416836 00000 n 0000414357 00000 n 0000414784 00000 n 0000414642 00000 n 0000417011 00000 n 0000007612 00000 n 0000009294 00000 n 0000015268 00000 n 0000006468 00000 n 0000006360 00000 n 0000002606 00000 n 0000415487 00000 n 0000415064 00000 n 0000415204 00000 n 0000414215 00000 n 0000011261 00000 n 0000007504 00000 n 0000006638 00000 n 0000008941 00000 n 0000009172 00000 n 0000009218 00000 n 0000010831 00000 n 0000011059 00000 n 0000011105 00000 n 0000011198 00000 n 0000016521 00000 n 0000014650 00000 n 0000014542 00000 n 0000011424 00000 n 0000018377 00000 n 0000015160 00000 n 0000014774 00000 n 0000016170 00000 n 0000016399 00000 n 0000016445 00000 n 0000017359 00000 n 0000017524 00000 n 0000017626 00000 n 0000017708 00000 n 0000017795 00000 n 0000017885 00000 n 0000017979 00000 n 0000018058 00000 n 0000018217 00000 n 0000022784 00000 n 0000023398 00000 n 0000024036 00000 n 0000024699 00000 n 0000025354 00000 n 0000026011 00000 n 0000026689 00000 n 0000027374 00000 n 0000029075 00000 n 0000029771 00000 n 0000030589 00000 n 0000031330 00000 n 0000032215 00000 n 0000021788 00000 n 0000021680 00000 n 0000018485 00000 n 0000414925 00000 n 0000028090 00000 n 0000022676 00000 n 0000021958 00000 n 0000417120 00000 n 0000023192 00000 n 0000023352 00000 n 0000023830 00000 n 0000023990 00000 n 0000024493 00000 n 0000024653 00000 n 0000025148 00000 n 0000025308 00000 n 0000025805 00000 n 0000025965 00000 n 0000026483 00000 n 0000026643 00000 n 0000027168 00000 n 0000027328 00000 n 0000027884 00000 n 0000028044 00000 n 0000032986 00000 n 0000028967 00000 n 0000028305 00000 n 0000029565 00000 n 0000029725 00000 n 0000030383 00000 n 0000030543 00000 n 0000031124 00000 n 0000031284 00000 n 0000032009 00000 n 0000032169 00000 n 0000032779 00000 n 0000032939 00000 n 0000036733 00000 n 0000036622 00000 n 0000033167 00000 n 0000414499 00000 n 0000040829 00000 n 0000040718 00000 n 0000036927 00000 n 0000415346 00000 n 0000414072 00000 n 0000042838 00000 n 0000044986 00000 n 0000042727 00000 n 0000041049 00000 n 0000043957 00000 n 0000044123 00000 n 0000044228 00000 n 0000044311 00000 n 0000044399 00000 n 0000044490 00000 n 0000044585 00000 n 0000044665 00000 n 0000044825 00000 n 0000048831 00000 n 0000048720 00000 n 0000045118 00000 n 0000052628 00000 n 0000052516 00000 n 0000048990 00000 n 0000417234 00000 n 0000056019 00000 n 0000055907 00000 n 0000052848 00000 n 0000058489 00000 n 0000058377 00000 n 0000056190 00000 n 0000415969 00000 n 0000060631 00000 n 0000060519 00000 n 0000058605 00000 n 0000062714 00000 n 0000062602 00000 n 0000060736 00000 n 0000066328 00000 n 0000066216 00000 n 0000062885 00000 n 0000069424 00000 n 0000069312 00000 n 0000066489 00000 n 0000415628 00000 n 0000417351 00000 n 0000072192 00000 n 0000072080 00000 n 0000069542 00000 n 0000074463 00000 n 0000074351 00000 n 0000072353 00000 n 0000075659 00000 n 0000075547 00000 n 0000074612 00000 n 0000078228 00000 n 0000078116 00000 n 0000075764 00000 n 0000081114 00000 n 0000081002 00000 n 0000078355 00000 n 0000083782 00000 n 0000083670 00000 n 0000081251 00000 n 0000417468 00000 n 0000086225 00000 n 0000086113 00000 n 0000083965 00000 n 0000087671 00000 n 0000092771 00000 n 0000087559 00000 n 0000086362 00000 n 0000089549 00000 n 0000089693 00000 n 0000089793 00000 n 0000089830 00000 n 0000090073 00000 n 0000096241 00000 n 0000096129 00000 n 0000092926 00000 n 0000099782 00000 n 0000099670 00000 n 0000096369 00000 n 0000103444 00000 n 0000103332 00000 n 0000099931 00000 n 0000105394 00000 n 0000105282 00000 n 0000103583 00000 n 0000417585 00000 n 0000108226 00000 n 0000106310 00000 n 0000106198 00000 n 0000105532 00000 n 0000117455 00000 n 0000108114 00000 n 0000106404 00000 n 0000114128 00000 n 0000114272 00000 n 0000114372 00000 n 0000114477 00000 n 0000114514 00000 n 0000114757 00000 n 0000121119 00000 n 0000121007 00000 n 0000117576 00000 n 0000123649 00000 n 0000123537 00000 n 0000121313 00000 n 0000125925 00000 n 0000125813 00000 n 0000123800 00000 n 0000129575 00000 n 0000129463 00000 n 0000126087 00000 n 0000416486 00000 n 0000417702 00000 n 0000131640 00000 n 0000131528 00000 n 0000129746 00000 n 0000133674 00000 n 0000133562 00000 n 0000131745 00000 n 0000135328 00000 n 0000135216 00000 n 0000133779 00000 n 0000137314 00000 n 0000137202 00000 n 0000135433 00000 n 0000139147 00000 n 0000139035 00000 n 0000137463 00000 n 0000142093 00000 n 0000141981 00000 n 0000139252 00000 n 0000417819 00000 n 0000144186 00000 n 0000144074 00000 n 0000142276 00000 n 0000149063 00000 n 0000148951 00000 n 0000144370 00000 n 0000152304 00000 n 0000152192 00000 n 0000149282 00000 n 0000154762 00000 n 0000154650 00000 n 0000152465 00000 n 0000157163 00000 n 0000157051 00000 n 0000154900 00000 n 0000160553 00000 n 0000158895 00000 n 0000158783 00000 n 0000157302 00000 n 0000417936 00000 n 0000165154 00000 n 0000160441 00000 n 0000158989 00000 n 0000161932 00000 n 0000162076 00000 n 0000162176 00000 n 0000162213 00000 n 0000162456 00000 n 0000167816 00000 n 0000167704 00000 n 0000165309 00000 n 0000170438 00000 n 0000170326 00000 n 0000167932 00000 n 0000170967 00000 n 0000170855 00000 n 0000170532 00000 n 0000172675 00000 n 0000172563 00000 n 0000171048 00000 n 0000416144 00000 n 0000175431 00000 n 0000175319 00000 n 0000172828 00000 n 0000418053 00000 n 0000178219 00000 n 0000178107 00000 n 0000175523 00000 n 0000179557 00000 n 0000179445 00000 n 0000178300 00000 n 0000413513 00000 n 0000179638 00000 n 0000179801 00000 n 0000179848 00000 n 0000179915 00000 n 0000180318 00000 n 0000180341 00000 n 0000180694 00000 n 0000181346 00000 n 0000181751 00000 n 0000182447 00000 n 0000183065 00000 n 0000183774 00000 n 0000184479 00000 n 0000185137 00000 n 0000185690 00000 n 0000186331 00000 n 0000186806 00000 n 0000187283 00000 n 0000187760 00000 n 0000188734 00000 n 0000195743 00000 n 0000195966 00000 n 0000206209 00000 n 0000206713 00000 n 0000224960 00000 n 0000225323 00000 n 0000235961 00000 n 0000236238 00000 n 0000250514 00000 n 0000250850 00000 n 0000264535 00000 n 0000264874 00000 n 0000273020 00000 n 0000273293 00000 n 0000284068 00000 n 0000284396 00000 n 0000292596 00000 n 0000292880 00000 n 0000300198 00000 n 0000300431 00000 n 0000308915 00000 n 0000309222 00000 n 0000315482 00000 n 0000315721 00000 n 0000334231 00000 n 0000334781 00000 n 0000351900 00000 n 0000352480 00000 n 0000356285 00000 n 0000356529 00000 n 0000371821 00000 n 0000372225 00000 n 0000377862 00000 n 0000378103 00000 n 0000398060 00000 n 0000398662 00000 n 0000413146 00000 n 0000418146 00000 n 0000418262 00000 n 0000418364 00000 n 0000418434 00000 n 0000418487 00000 n trailer << /Size 355 /Root 353 0 R /Info 354 0 R /ID [ ] >> startxref 418742 %%EOF msm/tests/0000755000175100001440000000000012622641761012235 5ustar hornikusersmsm/tests/test_base.R0000644000175100001440000000004612505076152014325 0ustar hornikuserslibrary(testthat) test_check("msm") msm/tests/testthat/0000755000175100001440000000000012622641761014075 5ustar hornikusersmsm/tests/testthat/test_analyticp.r0000644000175100001440000006713512505076150017311 0ustar hornikuserscontext("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.r0000644000175100001440000000766712620415526020532 0ustar hornikuserscontext("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) 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_that(hmm, has_accurate_derivs()) }) 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_that(hmm, has_accurate_derivs()) }) 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_that(hmm, has_accurate_derivs()) }) 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_that(hmm, has_accurate_derivs()) }) ## 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_that(hmm, has_accurate_derivs()) }) ## analytic derivatives options(msm.test.analytic.derivatives=NULL) ## censoring? msm/tests/testthat/test_utils.r0000644000175100001440000001332012505076150016450 0ustar hornikuserscontext("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") }) 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.r0000644000175100001440000001666412575517770017643 0ustar hornikuserscontext("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 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.r0000644000175100001440000013365012575517733016622 0ustar hornikuserscontext("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_that(cav.msm <- msm(state~years, subject=PTNUM, data = cav, qmatrix = twoway4.q, obstype=obstype, deathexact = TRUE, fixedpars=TRUE), not(throws_error())) # 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_that(cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = oneway4.q, ematrix=ematrix, initprobs=c(2,1,1,1), fixedpars=TRUE), not(throws_error())) # 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.r0000644000175100001440000000636412575506023017141 0ustar hornikuserscontext("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_that(crudeinits.msm(state ~ years, PTNUM, oneway4.q, cav), not(throws_error())) 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.r0000644000175100001440000002417212575520013017442 0ustar hornikuserscontext("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.r0000644000175100001440000000325112505076151015533 0ustar hornikuserstwoway4.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 has_accurate_derivs <- function(){ if (!isTRUE(getOption("msm.test.analytic.derivatives"))) stop("msm.test.analytic.derivatives option not set") function(object){ deriv.error <- object$paramdata$deriv.test$error["nd"] passed <- deriv.error < 1e-04 expectation(passed, paste("derivative error is", deriv.error)) } } msm/tests/testthat/test_deriv.r0000644000175100001440000002563112505076151016432 0ustar hornikusers## 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) test_that("analytic derivatives match numeric",{ cav.msm <- msm(state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, death = TRUE, fixedpars=TRUE) expect_that(cav.msm, has_accurate_derivs()) cav.msm <- msm( state ~ years, subject=PTNUM, data = cav, qmatrix = twoway4.q, death = FALSE, fixedpars=TRUE) expect_that(cav.msm, has_accurate_derivs()) 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_that(cav.msm, has_accurate_derivs()) 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_that(psor.msm, has_accurate_derivs()) 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_that(psor.msm, has_accurate_derivs()) 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_that(psor.msm, has_accurate_derivs()) psor.msm <- msm(state ~ months, subject=ptnum, data=psor, qmatrix = psor.0.q, covariates = ~ollwsdrt+hieffusn, death=TRUE, fixedpars=TRUE) expect_that(psor.msm, has_accurate_derivs()) msmtest5 <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, exacttimes=TRUE, fixedpars=TRUE) expect_that(msmtest5, has_accurate_derivs()) msmtest5 <- msm(state ~ time, qmatrix = fiveq, subject = ptnum, data = bos, exacttimes=TRUE, qconstraint=c(1,2,1,2,1,2,1), fixedpars=TRUE) expect_that(msmtest5, has_accurate_derivs()) msmtest5 <- msm(state ~ time, qmatrix = fiveq, covariates = ~time, subject = ptnum, data = bos, exacttimes=TRUE, fixedpars=TRUE) expect_that(msmtest5, has_accurate_derivs()) 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_that(msmtest5, has_accurate_derivs()) }) 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_that(tm, has_accurate_derivs()) }) 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_that(tm, has_accurate_derivs()) }) 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_that(tm, has_accurate_derivs()) }) 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_that(tm, has_accurate_derivs()) }) 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_that(tm, has_accurate_derivs()) }) 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_that(misc.msm, has_accurate_derivs()) misc.msm <- msm(state ~ years, subject = PTNUM, data = cav[1:2,], qmatrix = oneway4.q, ematrix=ematrix, fixedpars=TRUE) expect_that(misc.msm, has_accurate_derivs()) 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_that(misc.msm, has_accurate_derivs()) }) ## 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_that(tm, has_accurate_derivs()) }) 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_that(sim.hid, has_accurate_derivs()) }) 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_that(sim.hid, has_accurate_derivs()) }) 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_that(sim.hid, has_accurate_derivs()) }) 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_that(sim.hid, has_accurate_derivs()) }) 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_that(sim.hid, has_accurate_derivs()) }) options(msm.test.analytic.derivatives=NULL) msm/src/0000755000175100001440000000000012622641761011662 5ustar hornikusersmsm/src/hmm.c0000644000175100001440000000734112622641761012614 0ustar hornikusers#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/Makevars0000644000175100001440000000006112622641761013353 0ustar hornikusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) msm/src/lik.c0000644000175100001440000015347112622641761012620 0ustar hornikusers/* ***************************************************************** 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){ /* "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 a 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)))) { 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.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.c0000644000175100001440000000647312622641761013653 0ustar hornikusers#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.c0000644000175100001440000015710112622641761014017 0ustar hornikusers/* 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 *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/doc/0000755000175100001440000000000012622641761012427 5ustar hornikusersmsm/src/doc/Makefile0000644000175100001440000000152712622641761014074 0ustar hornikusers### This directory contains the sources for the manual "Multi-state ### modelling with R: the msm package" which is included in the source ### package as inst/doc/msm-manual.pdf, and in the installed package as ### doc/msm-manual.pdf. ### ### To build msm-manual.pdf, first the msm package must be ### installed. Then type ### ### make ### ### Or equivalently, open R in this directory and run ### ### Sweave("msm-manual.Rnw") ### ### Exit from R. The resulting LaTeX file, msm-manual.tex, can be ### compiled to PDF with the shell command ### ### texi2dvi msm-manual.tex LATEX=msm-manual.tex PDF=msm-manual.pdf all: $(LATEX) $(PDF) $(LATEX): R --vanilla --slave -e Sweave\(\'msm-manual.Rnw\'\) $(PDF): texi2dvi msm-manual.tex clean: rm -f msm-manual*.pdf msm-manual.tex msm-manual*.eps *.dvi *.toc *.aux *.bbl *.blg *.log *~ Rplots.pdf msm/src/doc/figures/0000755000175100001440000000000012622641761014073 5ustar hornikusersmsm/src/doc/figures/general.pdf0000644000175100001440000000463012622364163016204 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/p3q16.pdf0000644000175100001440000000205612622364164015442 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/illdeath.pdf0000644000175100001440000000327712622364163016363 0ustar hornikusers%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/src/doc/figures/p5q1_4_6_8_11_12_16.pdf0000644000175100001440000000240412622364164017363 0ustar hornikusers%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/src/doc/figures/p4q13569.pdf0000644000175100001440000000231412622364164015701 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/p3q14.pdf0000644000175100001440000000205412622364164015436 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/p3q12.pdf0000644000175100001440000000206412622364164015435 0ustar hornikusers%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/src/doc/figures/p2q1.pdf0000644000175100001440000000200412622364163015343 0ustar hornikusers%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/src/doc/figures/p2q12.pdf0000644000175100001440000000203312622364164015430 0ustar hornikusers%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/src/doc/figures/p5q1_6_11_16.pdf0000644000175100001440000000217312622364164016412 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/p3q124.pdf0000644000175100001440000000210212622364164015512 0ustar hornikusers%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/src/doc/figures/hidden.pdf0000644000175100001440000000502312622364163016017 0ustar hornikusers%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/src/doc/figures/p3q135.pdf0000644000175100001440000000211112622364164015514 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/sampling.pdf0000644000175100001440000000440012622364164016375 0ustar hornikusers%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/src/doc/figures/p5q1_6_7_11_12.pdf0000644000175100001440000000222512622364164016632 0ustar hornikusers%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/src/doc/figures/p4q159.pdf0000644000175100001440000000212412622364164015527 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/multistate.pdf0000644000175100001440000000415212622364163016761 0ustar hornikusers%PDF-1.3 %쏢 5 0 obj <> 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/src/doc/figures/p3q1246.pdf0000644000175100001440000000214712622364164015611 0ustar hornikusers%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/src/doc/figures/fev_viterbi.pdf0000644000175100001440000001157112622364163017075 0ustar hornikusers%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/src/doc/msm-manual.Rnw0000644000175100001440000035644012622364163015200 0ustar hornikusers%%\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{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/src/doc/Sweave-local.sty0000644000175100001440000000102512622364163015506 0ustar hornikusers\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/src/doc/msm.bib0000644000175100001440000004613112622364163013704 0ustar hornikusers@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/src/hmm.h0000644000175100001440000000304312622641761012614 0ustar hornikusers 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/NAMESPACE0000644000175100001440000000441012622613433012304 0ustar hornikusersuseDynLib(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/0000755000175100001440000000000012622641761012004 5ustar hornikusersmsm/data/bos4.rda0000644000175100001440000000675412505076161013353 0ustar hornikusers͜_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.rda0000644000175100001440000025443112505076160014126 0ustar hornikusers]\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/0000755000175100001440000000000012622641761011274 5ustar hornikusersmsm/R/utils.R0000644000175100001440000004247312505076167012573 0ustar hornikusers### 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 ret[p < 0 | p > 1] <- NaN ind <- (p > 0 & p < 1) if (any(ind)) { hind <- seq(along=p)[ind] h <- function(y) { args$q <- y (do.call(pdist, args) - p)[hind[i]] } 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.R0000644000175100001440000004617712617145751012221 0ustar hornikusers### 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), 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, 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, 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.R0000644000175100001440000000541112505076170012711 0ustar hornikusers## 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.R0000644000175100001440000004544612505076170012373 0ustar hornikusers### 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.R0000644000175100001440000027275412620420374012225 0ustar hornikusersmsm <- 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) if (emodel$npars==0) emodel <- list(misc=FALSE, npars=0, ndpars=0) # user supplied degenerate ematrix with no misclassification ### 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) ### 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 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)) if (length(miss.state) > 0) 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 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 is 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 } } } 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)) 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) if (p$foundse && !p$fixed){ intenscov <- p$covmat[parinds, parinds] intensse <- sqrt(diag(as.matrix(intenscov))) semat <- lmat <- umat <- t(model$imatrix) fixed <- array(FALSE, dim=dim(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)){ fixed[i,i] <- all(fixed[i,-i][model$imatrix[i,-i]==1]) } if (whichp=="misc") fixed[which(x$hmodel$model==match("identity", .msm.HMODELS)),] <- TRUE dimnames(semat) <- dimnames(mat) } else { semat <- lmat <- umat <- fixed <- 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.R0000644000175100001440000002210712505076167012523 0ustar hornikusersmsm.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.R0000644000175100001440000002745412616472252012563 0ustar hornikusersderiv.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.R0000644000175100001440000000626212505076167013037 0ustar hornikusers## 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.R0000644000175100001440000026747712605160210013153 0ustar hornikusers### 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.R0000644000175100001440000003473512505076167012517 0ustar hornikusersdraic.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(initstate)) 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 (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) 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(initstate)) 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) 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.R0000644000175100001440000004236612505076167012565 0ustar hornikusers### 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.R0000644000175100001440000001330412505076170013321 0ustar hornikusers ### 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.R0000644000175100001440000001456612505076170013443 0ustar hornikusers### 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.R0000644000175100001440000010735112505076170013071 0ustar hornikusers### 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") 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/0000755000175100001440000000000012622641761013103 5ustar hornikusersmsm/vignettes/_region_.tex0000644000175100001440000024322512611134647015414 0ustar hornikusers\message{ !name(msm-manual.Rnw.tex)} \message{ !name(msm-manual.Rnw) !offset(838) } \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 \message{ !name(msm-manual.Rnw.tex) !offset(-1781) } msm/MD50000644000175100001440000001543412623033544011405 0ustar hornikusers9af70dd0f6c8446fc2bd969367a59bb6 *ChangeLog 9df07c3033e9a69b29e3511afe0931f4 *DESCRIPTION 03d50885cd1792f686cd0ddcfaf244a4 *NAMESPACE c3e8bb90abd277f56413e4c508a6833c *R/boot.R 8b7f8323654de2c622caf77cc6e68151 *R/constants.R 0bfe7241f81077ce90cd168954c1c70b *R/draic.R 40288b7bca9c27eb11c27b0044e86fe9 *R/hmm-dists.R ca78965b167729b2aad54aa15c65870f *R/hmm.R a7121691da84554e437247da5da2b523 *R/msm.R 7c4fa51638caa9fd7819e73e206b60f2 *R/mstate.R a0d0b4080044ca84d7555a56c6a3bd2e *R/olddata.R fc42a0fca95c8674f23b79337ee55e8b *R/optim.R f16122da7e4b28ec6f0fcd088fde0ae3 *R/outputs.R e17113eac817aea9125dcd1ebc1431dd *R/pearson.R 92eab74d4d79c795257ca76cb676149a *R/phase.R c3f3898979b11b85f088e3f4c9c11780 *R/simul.R 9145455212eca4557e84b7446ec80102 *R/utils.R 91275819754efca551c7371eb0c14f06 *build/vignette.rds 2e83efb31c764734aa67ed4e686c7fc1 *data/bos3.rda 21080bd2b47eb8885142701c92c14c73 *data/bos4.rda 35ea8ffa25baf02ee38f4ccb5fdc0446 *data/msmdata.rda f8474ef9e0f949bccbb4e244a4ac472c *inst/CITATION e2a351802e381fd64e3f4150840deabe *inst/NEWS 54c1e3ff4ea988f6bcd576d8d6e2caf0 *inst/doc/msm-manual.R d6f9f28da8f9b30edef8fe1b1f5a17ca *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 4bc99aeb9fbf72e37d54ed3e8f48de47 *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 ef5a67059528e877e69cce5627e0b375 *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 8976bd0da49fd54ae102544b0154a968 *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 b2954670e5c7bfca19cb6bb42e3f5e32 *src/doc/Makefile 8206c9091e718652d132378ade48f125 *src/doc/Sweave-local.sty 3f41f9a36481dd33390cfaf81ee2ca5c *src/doc/figures/fev_viterbi.pdf e3889cf40ff59689f1a6cfac011c7115 *src/doc/figures/general.pdf 06f4bff6b071901d1120c7431193c59d *src/doc/figures/hidden.pdf af3adf546c0c77610b76919d15607a18 *src/doc/figures/illdeath.pdf 2d8ca6ab876fe50cf7bfee4724fdcbc3 *src/doc/figures/multistate.pdf 8ec73693aa663c3a367f7bd5ea663c7c *src/doc/figures/p2q1.pdf 7f89c5f85f787b2b41c623cbf366d042 *src/doc/figures/p2q12.pdf 04f638273c713543f6dad7c71778df07 *src/doc/figures/p3q12.pdf 98c0baea7a7468465b6d5fba30a62cfa *src/doc/figures/p3q124.pdf 634cc49ae5959dbfaab98007521e3150 *src/doc/figures/p3q1246.pdf 0ae4b74fa9984b26cdaf3a37ef0ec733 *src/doc/figures/p3q135.pdf 5178056951a81e36e697d91d6f655348 *src/doc/figures/p3q14.pdf 1d88c1377297306389a460a8a5598ff2 *src/doc/figures/p3q16.pdf a54418b47ce58e6fa28c500af30d5566 *src/doc/figures/p4q13569.pdf 0bbc74d48ecbcee9199ebea6811bf377 *src/doc/figures/p4q159.pdf 684cf4d5299dab735d4ddf4fdaedcca4 *src/doc/figures/p5q1_4_6_8_11_12_16.pdf 3fa510d2be43accb7ce3cbbe125c93a5 *src/doc/figures/p5q1_6_11_16.pdf 2de6c2326f3031d048c31b507d6a2f20 *src/doc/figures/p5q1_6_7_11_12.pdf 2ea085b4ec235c4882c6a0958c9362a5 *src/doc/figures/sampling.pdf ca84dda89590a95c45c0511aea35fde8 *src/doc/msm-manual.Rnw be6c66fe663712eea54faf33c2861c3b *src/doc/msm.bib a75b5dc8161768aa323eb071bcbaee57 *src/hmm.c e4a9fe89d526a0892e18cec78c422faa *src/hmm.h bb7bac5595e06b42ebc854645da8565b *src/hmmderiv.c 8b1bd3316fcfd0ed7a02007b110f0cc5 *src/lik.c c974cb25cb327452ab24b4c3c8ddf548 *src/msm.h 387527989c4743003456924f96baea67 *src/pijt.c 7a2c53c3ce4c4dd37a62ef4dfcc35ce3 *tests/test_base.R 2922239c3c75d5dd2969f95740ed4595 *tests/testthat/helper.r 2c29e599c4974ef47222a7f154b47a54 *tests/testthat/test_analyticp.r 3638588d7fb5751b881f1b7c145fa45d *tests/testthat/test_datasumm.r 3853a80210c452288ad24e9a67846f5e *tests/testthat/test_deriv.r f83ae7f02d95d1c648682d8c92248a44 *tests/testthat/test_models.r 6b81a41d2360192710a56341478a6531 *tests/testthat/test_models_hmm.r d84f2ee21248739b9d5f3c251cafa119 *tests/testthat/test_models_hmmmulti.r f0d4892d5a1fee58f53fd02eb8bbc9f8 *tests/testthat/test_models_misc.r e9e48c58a5cffdde6650621cd87a8591 *tests/testthat/test_utils.r 6b43dbd59aec30d599c7e55d057b3843 *vignettes/_region_.tex msm/build/0000755000175100001440000000000012622641761012172 5ustar hornikusersmsm/build/vignette.rds0000644000175100001440000000034112622641761014527 0ustar hornikusers}Q0 'jLxS/^  Ao>X cv}0!PbRJ`ϹJruB.t